From: Chris Hanson Date: Wed, 6 Mar 2002 20:05:44 +0000 (+0000) Subject: Rewrite mechanism that controls whether PRIMARY or CLIPBOARD selection X-Git-Tag: 20090517-FFI~2206 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5d0b246a06c635e592c29355e8b6b63ec85e7947;p=mit-scheme.git Rewrite mechanism that controls whether PRIMARY or CLIPBOARD selection is used on X. Now cut and paste are separately configurable, and the defaults are different for each. This should provide better behavior on older systems while making the default more usable on newer ones. --- diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm index 362683f4e..5cb200906 100644 --- a/v7/src/edwin/dos.scm +++ b/v7/src/edwin/dos.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dos.scm,v 1.52 2000/03/23 03:19:08 cph Exp $ +;;; $Id: dos.scm,v 1.53 2002/03/06 20:05:13 cph Exp $ ;;; -;;; Copyright (c) 1992-2000 Massachusetts Institute of Technology +;;; Copyright (c) 1992-2000, 2002 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -16,7 +16,8 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;;; 02111-1307, USA. ;;;; Win32 Customizations for Edwin @@ -72,15 +73,16 @@ (define cut-and-paste-active? #t) -(define (os/interprogram-cut string push?) - push? +(define (os/interprogram-cut string context) + context (if cut-and-paste-active? (win32-clipboard-write-text (let ((string (convert-newline-to-crlf string))) ;; Some programs can't handle strings over 64k. (if (fix:< (string-length string) #x10000) string ""))))) -(define (os/interprogram-paste) +(define (os/interprogram-paste context) + context (if cut-and-paste-active? (let ((text (win32-clipboard-read-text))) (and text diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 318afd57d..87933878c 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.280 2002/02/03 03:38:54 cph Exp $ +$Id: edwin.pkg,v 1.281 2002/03/06 20:05:22 cph Exp $ Copyright (c) 1989-2002 Massachusetts Institute of Technology @@ -1026,6 +1026,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (files "xterm") (parent (edwin screen)) (export (edwin) + edwin-variable$x-cut-to-clipboard + edwin-variable$x-paste-from-clipboard os/interprogram-cut os/interprogram-paste x-root-window-size diff --git a/v7/src/edwin/kilcom.scm b/v7/src/edwin/kilcom.scm index d9d6a24c7..ab9c9cecb 100644 --- a/v7/src/edwin/kilcom.scm +++ b/v7/src/edwin/kilcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: kilcom.scm,v 1.71 1999/01/02 06:11:34 cph Exp $ +;;; $Id: kilcom.scm,v 1.72 2002/03/06 20:05:30 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989-1999 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-1999, 2002 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -16,7 +16,8 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;;; 02111-1307, USA. ;;;; Kill Commands @@ -180,14 +181,14 @@ The command \\[yank] can retrieve it from there. (define (kill-string mark #!optional point) (let ((point (if (default-object? point) (current-point) point))) - (kill-ring-save (extract-string mark point) (mark<= point mark)) + (kill-ring-save (extract-string mark point) (mark<= point mark) point) (delete-string mark point))) (define (copy-string mark #!optional point) (let ((point (if (default-object? point) (current-point) point))) - (kill-ring-save (extract-string mark point) (mark<= point mark)))) + (kill-ring-save (extract-string mark point) (mark<= point mark) point))) -(define (kill-ring-save string forward?) +(define (kill-ring-save string forward? context) (command-message-receive append-next-kill-tag (lambda () (let ((kill-ring (ref-variable kill-ring))) @@ -198,28 +199,28 @@ The command \\[yank] can retrieve it from there. (string-append (car kill-ring) string) (string-append string (car kill-ring))))) (set-car! kill-ring string) - (set-variable! kill-ring-yank-pointer kill-ring) - (os/interprogram-cut string #f)))) + (set-variable! kill-ring-yank-pointer kill-ring context) + (os/interprogram-cut string context)))) (lambda () - (kill-ring-save-1 string) - (os/interprogram-cut string #t))) + (kill-ring-save-1 string context) + (os/interprogram-cut string context))) (set-command-message! append-next-kill-tag)) -(define (kill-ring-save-1 string) +(define (kill-ring-save-1 string context) (let ((strings - (let ((kill-ring (ref-variable kill-ring)) - (kill-ring-max (ref-variable kill-ring-max))) + (let ((kill-ring (ref-variable kill-ring context)) + (kill-ring-max (ref-variable kill-ring-max context))) (if (zero? kill-ring-max) '() (let ((strings (cons string kill-ring))) (if (> (length strings) kill-ring-max) (set-cdr! (list-tail strings (- kill-ring-max 1)) '())) strings))))) - (set-variable! kill-ring strings) - (set-variable! kill-ring-yank-pointer strings))) + (set-variable! kill-ring strings context) + (set-variable! kill-ring-yank-pointer strings context))) (define append-next-kill-tag - "Append Next Kill") + (list 'APPEND-NEXT-KILL)) ;;;; Yanking @@ -266,26 +267,28 @@ comes the newest one." set-current-mark!))) (define (yank offset before? set-current-mark!) - (let ((start (mark-right-inserting-copy (current-point)))) - (let ((end (mark-left-inserting-copy start))) - (insert-string (let ((paste (and (= offset 0) (os/interprogram-paste)))) - (if (and paste - (not (string-null? paste)) - (let ((kill-ring (ref-variable kill-ring))) - (or (null? kill-ring) - (not (string=? paste (car kill-ring)))))) - (begin - (kill-ring-save-1 paste) - paste) - (begin - ((ref-command rotate-yank-pointer) offset) - (car (ref-variable kill-ring-yank-pointer))))) - start) - (mark-temporary! end) - (mark-temporary! start) - (if before? - (begin (set-current-mark! end) (set-current-point! start)) - (begin (set-current-mark! start) (set-current-point! end))))) + (let* ((point (current-point)) + (start (mark-right-inserting-copy point)) + (end (mark-left-inserting-copy start))) + (insert-string (let ((paste + (and (= offset 0) (os/interprogram-paste point)))) + (if (and paste + (not (string-null? paste)) + (let ((kill-ring (ref-variable kill-ring point))) + (or (null? kill-ring) + (not (string=? paste (car kill-ring)))))) + (begin + (kill-ring-save-1 paste point) + paste) + (begin + ((ref-command rotate-yank-pointer) offset) + (car (ref-variable kill-ring-yank-pointer point))))) + start) + (mark-temporary! end) + (mark-temporary! start) + (if before? + (begin (set-current-mark! end) (set-current-point! start)) + (begin (set-current-mark! start) (set-current-point! end)))) (set-command-message! un-kill-tag)) (define un-kill-tag diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm index f4c361099..790393d68 100644 --- a/v7/src/edwin/os2.scm +++ b/v7/src/edwin/os2.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: os2.scm,v 1.50 2000/07/28 15:15:33 cph Exp $ +;;; $Id: os2.scm,v 1.51 2002/03/06 20:05:35 cph Exp $ ;;; -;;; Copyright (c) 1994-2000 Massachusetts Institute of Technology +;;; Copyright (c) 1994-2000, 2002 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -16,7 +16,8 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;;; 02111-1307, USA. ;;;; OS/2 Customizations for Edwin @@ -58,14 +59,15 @@ ;;;; OS/2 Clipboard Interface -(define (os/interprogram-cut string push?) - push? +(define (os/interprogram-cut string context) + context (os2-clipboard-write-text (let ((string (convert-newline-to-crlf string))) ;; Some programs can't handle strings over 64k. (if (fix:< (string-length string) #x10000) string "")))) -(define (os/interprogram-paste) +(define (os/interprogram-paste context) + context (let ((text (os2-clipboard-read-text))) (and text (convert-crlf-to-newline text)))) diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index 9d9cdc724..86c1be952 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: xterm.scm,v 1.68 2002/01/29 04:14:03 cph Exp $ +;;; $Id: xterm.scm,v 1.69 2002/03/06 20:05:44 cph Exp $ ;;; ;;; Copyright (c) 1989-2002 Massachusetts Institute of Technology ;;; @@ -999,10 +999,13 @@ ;;;; Selection Source -(define enable-x-clipboard? #t) +(define-variable x-cut-to-clipboard + "If true, cutting text copies to the clipboard. +In either case, it is copied to the primary selection." + #t + boolean?) -(define (os/interprogram-cut string push?) - push? +(define (os/interprogram-cut string context) (if (eq? x-display-type (current-display-type)) (let ((xterm (screen-xterm (selected-screen)))) (let ((own-selection @@ -1013,7 +1016,7 @@ last-focus-time string)))) (own-selection 'PRIMARY) - (if enable-x-clipboard? + (if (ref-variable x-cut-to-clipboard context) (own-selection 'CLIPBOARD)))))) (define (own-selection display selection window time value) @@ -1175,12 +1178,18 @@ ;;;; Selection Sink -(define (os/interprogram-paste) +(define-variable x-paste-from-clipboard + "If true, pasting text copies from the clipboard. +Otherwise, it is copied from the primary selection." + #f + boolean?) + +(define (os/interprogram-paste context) (and (eq? x-display-type (current-display-type)) - (xterm/interprogram-paste (screen-xterm (selected-screen))))) + (xterm/interprogram-paste (screen-xterm (selected-screen)) context))) -(define (xterm/interprogram-paste xterm) - (or (and enable-x-clipboard? +(define (xterm/interprogram-paste xterm context) + (or (and (ref-variable x-paste-from-clipboard context) (xterm/interprogram-paste-1 xterm 'CLIPBOARD)) (xterm/interprogram-paste-1 xterm 'PRIMARY)))