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 362683f4e10fc5c31a25a3816dc13bce3add09ec..5cb2009062b23219bffe378502bdd21ca71145cc 100644 (file)
--- 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 318afd57ddb60c4dfdee182b4fb00434a4554dd3..87933878c059e29d3034db6b5bfe12b0f1d12b31 100644 (file)
--- 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 d9d6a24c713c3bdc5b5e8a4b663dc81334a32e59..ab9c9cecb0e06d3a676c8dc88d986848b2093bd1 100644 (file)
--- 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))
 \f
 ;;;; Yanking
 
@@ -266,26 +267,28 @@ comes the newest one."
          set-current-mark!)))
 \f
 (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 f4c3610992f4cecda8c9c0466e62910a658b2acd..790393d686b6368bea7cb4e717187b04f6849c8c 100644 (file)
--- 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 @@
 \f
 ;;;; 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 9d9cdc7243456172317ac8bf4752c71e2007f132..86c1be952ae27242d31b672c9ba1e5e4380fb1a8 100644 (file)
--- 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 @@
 \f
 ;;;; 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 @@
 \f
 ;;;; 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)))