bug#902: select-active-regions only half-working

[David De La Harpe Golden]

Stefan Monnier wrote:

> An alternative is to use not a function but a buffer (which would mean
> "use the region's content, if active").


Yeah, allowing a function might be a giant bit too open-ended.
Attached please find buffer-passing implementation.








Index: lisp/select.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/select.el,v
retrieving revision 1.44
diff -U 8 -r1.44 select.el
--- lisp/select.el      12 Jun 2008 03:56:16 -0000      1.44
+++ lisp/select.el      9 Sep 2008 19:02:15 -0000
@@ -123,16 +123,20 @@
 integer (or a cons of two integers or list of two integers).
 
 The selection may also be a cons of two markers pointing to the same buffer,
 or an overlay.  In these cases, the selection is considered to be the text
 between the markers *at whatever time the selection is examined*.
 Thus, editing done in the buffer after you specify the selection
 can alter the effective value of the selection.
 
+The selection may also be a buffer object. In that case, the selection is
+considered to be the region between the mark and point, if any, in that
+buffer, *at whatever time the selection is examined*.
+
 The data may also be a vector of valid non-vector selection values.
 
 The return value is DATA.
 
 Interactively, this command sets the primary selection.  Without
 prefix argument, it reads the selection in the minibuffer.  With
 prefix argument, it uses the text of the region as the selection value ."
   (interactive (if (not current-prefix-arg)
@@ -170,17 +174,18 @@
       (and (consp data)
           (markerp (car data))
           (markerp (cdr data))
           (marker-buffer (car data))
           (marker-buffer (cdr data))
           (eq (marker-buffer (car data))
               (marker-buffer (cdr data)))
           (buffer-name (marker-buffer (car data)))
-          (buffer-name (marker-buffer (cdr data))))))
+          (buffer-name (marker-buffer (cdr data))))
+      (bufferp data)))
 
 ;;; Cut Buffer support
 
 (declare-function x-get-cut-buffer-internal "xselect.c")
 
 (defun x-get-cut-buffer (&optional which-one)
   "Returns the value of one of the 8 X server cut-buffers.
 Optional arg WHICH-ONE should be a number from 0 to 7, defaulting to 0.
@@ -229,17 +234,24 @@
                (markerp (cdr value)))
           (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
               (signal 'error
                       (list "markers must be in the same buffer"
                             (car value) (cdr value))))
           (save-excursion
             (set-buffer (or (marker-buffer (car value))
                             (error "selection is in a killed buffer")))
-            (setq str (buffer-substring (car value) (cdr value))))))
+            (setq str (buffer-substring (car value) (cdr value)))))
+
+         ((bufferp value)
+          (save-excursion
+            (set-buffer value)
+            (if (and (mark t) (point))
+                (setq str (buffer-substring (mark t) (point)))
+              (setq str "")))))
 
     (when str
       ;; If TYPE is nil, this is a local request, thus return STR as
       ;; is.  Otherwise, encode STR.
       (if (not type)
          str
        (setq coding (or next-selection-coding-system selection-coding-system))
        (if coding
@@ -304,17 +316,23 @@
               ((and (consp value)
                     (markerp (car value))
                     (markerp (cdr value)))
                (or (eq (marker-buffer (car value))
                        (marker-buffer (cdr value)))
                    (signal 'error
                            (list "markers must be in the same buffer"
                                  (car value) (cdr value))))
-               (abs (- (car value) (cdr value)))))))
+               (abs (- (car value) (cdr value))))
+              ((bufferp value)
+               (save-excursion
+                 (set-buffer value)
+                 (if (and (mark t) (point))
+                     (abs (- (point) (mark t)))
+                   0))))))
     (if value ; force it to be in 32-bit format.
        (cons (ash value -16) (logand value 65535))
       nil)))
 
 (defun xselect-convert-to-targets (selection type value)
   ;; return a vector of atoms, but remove duplicates first.
   (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
         (rest all))
@@ -338,28 +356,36 @@
   (cond ((overlayp value)
         (buffer-file-name (or (overlay-buffer value)
                               (error "selection is in a killed buffer"))))
        ((and (consp value)
              (markerp (car value))
              (markerp (cdr value)))
         (buffer-file-name (or (marker-buffer (car value))
                               (error "selection is in a killed buffer"))))
+       ((bufferp value)
+        (buffer-file-name value))
        (t nil)))
 
 (defun xselect-convert-to-charpos (selection type value)
   (let (a b tmp)
     (cond ((cond ((overlayp value)
                  (setq a (overlay-start value)
                        b (overlay-end value)))
                 ((and (consp value)
                       (markerp (car value))
                       (markerp (cdr value)))
                  (setq a (car value)
-                       b (cdr value))))
+                       b (cdr value)))
+                ((bufferp value)
+                 (save-excursion
+                   (set-buffer value)
+                   (and (mark t) (point)
+                        (setq a (mark t)
+                              b (point))))))
           (setq a (1- a) b (1- b)) ; zero-based
           (if (< b a) (setq tmp a a b b tmp))
           (cons 'SPAN
                 (vector (cons (ash a -16) (logand a 65535))
                         (cons (ash b -16) (logand b 65535))))))))
 
 (defun xselect-convert-to-lineno (selection type value)
   (let (a b buf tmp)
@@ -368,16 +394,23 @@
                       (markerp (cdr value)))
                  (setq a (marker-position (car value))
                        b (marker-position (cdr value))
                        buf (marker-buffer (car value))))
                 ((overlayp value)
                  (setq buf (overlay-buffer value)
                        a (overlay-start value)
                        b (overlay-end value)))
+                ((bufferp value)
+                 (save-excursion
+                   (set-buffer value)
+                   (and (mark t) (point)
+                        (setq buf value
+                              a (mark t)
+                              b (point)))))
                 )
           (save-excursion
             (set-buffer buf)
             (setq a (count-lines 1 a)
                   b (count-lines 1 b)))
           (if (< b a) (setq tmp a a b b tmp))
           (cons 'SPAN
                 (vector (cons (ash a -16) (logand a 65535))
@@ -390,16 +423,23 @@
                       (markerp (cdr value)))
                  (setq a (car value)
                        b (cdr value)
                        buf (marker-buffer a)))
                 ((overlayp value)
                  (setq buf (overlay-buffer value)
                        a (overlay-start value)
                        b (overlay-end value)))
+                ((bufferp value)
+                 (save-excursion
+                   (set-buffer value)
+                   (and (mark t) (point)
+                        (setq buf value
+                              a (mark t)
+                              b (point)))))
                 )
           (save-excursion
             (set-buffer buf)
             (goto-char a)
             (setq a (current-column))
             (goto-char b)
             (setq b (current-column)))
           (if (< b a) (setq tmp a a b b tmp))
Index: lisp/simple.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/simple.el,v
retrieving revision 1.945
diff -U 8 -r1.945 simple.el
--- lisp/simple.el      15 Aug 2008 00:30:44 -0000      1.945
+++ lisp/simple.el      9 Sep 2008 19:02:18 -0000
@@ -3416,44 +3416,55 @@
 is active, and returns an integer or nil in the usual way.
 
 If you are using this in an editing command, you are most likely making
 a mistake; see the documentation of `set-mark'."
   (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive)
       (marker-position (mark-marker))
     (signal 'mark-inactive nil)))
 
+(defcustom select-active-regions nil
+  "If non-nil, an active region automatically becomes the window selection.
+
+In conjunction with this, to ape some other X11 apps, you might want to:
+rebind mouse-2 to `mouse-yank-primary', set `x-select-enable-primary' to nil,
+set `x-select-enable-clipboard' to non-nil, set `mouse-drag-copy-region'
+to nil, and turn on `transient-mark-mode'."
+  :type 'boolean
+  :group 'killing
+  :version "23.1")
+
 ;; Many places set mark-active directly, and several of them failed to also
 ;; run deactivate-mark-hook.  This shorthand should simplify.
 (defsubst deactivate-mark ()
   "Deactivate the mark by setting `mark-active' to nil.
 \(That makes a difference only in Transient Mark mode.)
 Also runs the hook `deactivate-mark-hook'."
   (when transient-mark-mode
+    (and mark-active select-active-regions
+         (x-selection-owner-p nil)
+         (x-set-selection nil (x-get-selection nil)))
     (if (or (eq transient-mark-mode 'lambda)
            (and (eq (car-safe transient-mark-mode) 'only)
                 (null (cdr transient-mark-mode))))
        (setq transient-mark-mode nil)
       (if (eq (car-safe transient-mark-mode) 'only)
          (setq transient-mark-mode (cdr transient-mark-mode)))
       (setq mark-active nil)
       (run-hooks 'deactivate-mark-hook))))
 
 (defun activate-mark ()
   "Activate the mark."
   (when (mark t)
     (setq mark-active t)
     (unless transient-mark-mode
-      (setq transient-mark-mode 'lambda))))
+      (setq transient-mark-mode 'lambda))
+    (when select-active-regions
+      (x-set-selection nil (current-buffer)))))
 
-(defcustom select-active-regions nil
-  "If non-nil, an active region automatically becomes the window selection."
-  :type 'boolean
-  :group 'killing
-  :version "23.1")
 
 (defun set-mark (pos)
   "Set this buffer's mark to POS.  Don't use this function!
 That is to say, don't use this function unless you want
 the user to see that the mark has moved, and you want the previous
 mark position to be lost.
 
 Normally, when a new mark is set, the old one should go on the stack.
@@ -3466,20 +3477,22 @@
 store it in a Lisp variable.  Example:
 
    (let ((beg (point))) (forward-line 1) (delete-region beg (point)))."
 
   (if pos
       (progn
        (setq mark-active t)
        (run-hooks 'activate-mark-hook)
-       (and select-active-regions
-            (x-set-selection
-             nil (buffer-substring (region-beginning) (region-end))))
-       (set-marker (mark-marker) pos (current-buffer)))
+       (set-marker (mark-marker) pos (current-buffer))
+       (when select-active-regions
+         (x-set-selection nil (current-buffer))))
+    (and mark-active select-active-regions
+        (x-selection-owner-p nil)
+        (x-set-selection nil (x-get-selection nil)))
     ;; Normally we never clear mark-active except in Transient Mark mode.
     ;; But when we actually clear out the mark value too,
     ;; we must clear mark-active in any mode.
     (setq mark-active nil)
     (run-hooks 'deactivate-mark-hook)
     (set-marker (mark-marker) nil)))
 
 (defcustom use-empty-active-region nil
Index: lisp/mouse.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/mouse.el,v
retrieving revision 1.347
diff -U 8 -r1.347 mouse.el
--- lisp/mouse.el       11 Aug 2008 01:23:05 -0000      1.347
+++ lisp/mouse.el       9 Sep 2008 19:02:20 -0000
@@ -906,16 +906,17 @@
 (defun mouse-drag-track (start-event  &optional
                                      do-mouse-drag-region-post-process)
     "Track mouse drags by highlighting area between point and cursor.
 The region will be defined with mark and point, and the overlay
 will be deleted after return.  DO-MOUSE-DRAG-REGION-POST-PROCESS
 should only be used by mouse-drag-region."
   (mouse-minibuffer-check start-event)
   (setq mouse-selection-click-count-buffer (current-buffer))
+  (deactivate-mark)
   (let* ((original-window (selected-window))
          ;; We've recorded what we needed from the current buffer and
          ;; window, now let's jump to the place of the event, where things
          ;; are happening.
          (_ (mouse-set-point start-event))
          (echo-keystrokes 0)
         (start-posn (event-start start-event))
         (start-point (posn-point start-posn))
@@ -950,17 +951,16 @@
     (if (< (point) start-point)
        (goto-char start-point))
     (setq start-point (point))
     (if remap-double-click ;; Don't expand mouse overlay in links
        (setq click-count 0))
     (mouse-move-drag-overlay mouse-drag-overlay start-point start-point
                              click-count)
     (overlay-put mouse-drag-overlay 'window start-window)
-    (deactivate-mark)
     (let (event end end-point last-end-point)
       (track-mouse
        (while (progn
                 (setq event (read-event))
                  (or (mouse-movement-p event)
                      (memq (car-safe event) '(switch-frame select-window))))
           (if (memq (car-safe event) '(switch-frame select-window))
              nil
@@ -1352,16 +1352,19 @@
 (defun mouse-yank-primary (click)
   "Insert the primary selection at the position clicked on.
 Move point to the end of the inserted text.
 If `mouse-yank-at-point' is non-nil, insert at point
 regardless of where you click."
   (interactive "e")
   ;; Give temporary modes such as isearch a chance to turn off.
   (run-hooks 'mouse-leave-buffer-hook)
+  ;; if region is active and _is_ primary (due to select-active-regions)
+  ;; avoid doubling upon repeated consecutive clicks.
+  (and select-active-regions (deactivate-mark))
   (or mouse-yank-at-point (mouse-set-point click))
   (let ((primary (x-get-selection 'PRIMARY)))
     (if primary
         (insert (x-get-selection 'PRIMARY))
       (error "No primary selection"))))
 
 (defun mouse-kill-ring-save (click)
   "Copy the region between point and the mouse click in the kill ring.

2008-09-09 David De La Harpe Golden <david@harpegolden.net>

        * select.el: allow x-set-selection to take a buffer object
                     that is inspected on-demand to obtain selection data
                     from its region.

        * simple.el: lazy implementation of select-active-regions.

        * mouse.el:  fix time-ordering of deactivate-mark operations
                     in mouse drag tracking.
                     Avoid double insertion in mouse-yank-primary
                     when select-active-regions is on.