home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / x11 / xselect.el < prev    next >
Encoding:
Text File  |  1993-03-14  |  16.9 KB  |  475 lines
  1. ;; Elisp interface to X Selections.
  2. ;; Copyright (C) 1990 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20.  
  21. ;;; The selection code requires us to use certain symbols whose names are
  22. ;;; all upper-case; this may seem tasteless, but it makes there be a 1:1
  23. ;;; correspondence between these symbols and X Atoms (which are upcased.)
  24.  
  25. (make-face 'primary-selection)
  26. (make-face 'secondary-selection)
  27.  
  28. (defun x-get-selection ()
  29.   "Return text selected from some X window."
  30.   (x-get-selection-internal 'PRIMARY 'STRING))
  31.  
  32. (defun x-get-secondary-selection ()
  33.   "Return text selected from some X window."
  34.   (x-get-selection-internal 'SECONDARY 'STRING))
  35.  
  36. (defun x-get-clipboard ()
  37.   "Return text pasted to the clipboard."
  38.   (x-get-selection-internal 'CLIPBOARD 'STRING))
  39.  
  40.  
  41. (defvar primary-selection-extent nil
  42.   "The extent of the primary selection; don't use this.")
  43.  
  44. (defvar secondary-selection-extent nil
  45.   "The extent of the secondary selection; don't use this.")
  46.  
  47.  
  48. (defun x-select-make-extent-for-selection (selection previous-extent face)
  49.   ;; Given a selection, this makes an extent in the buffer which holds that
  50.   ;; selection, for highlighting purposes.  If the selection isn't associated
  51.   ;; with a buffer, this does nothing.
  52.   (let ((buffer nil)
  53.     (valid (and (extentp previous-extent)
  54.             (extent-buffer previous-extent)
  55.             (buffer-name (extent-buffer previous-extent))))
  56.     start end)
  57.     (cond ((stringp selection)
  58.        ;; if we're selecting a string, lose the previous extent used
  59.        ;; to highlight the selection.
  60.        (setq valid nil))
  61.       ((consp selection)
  62.        (setq start (min (car selection) (cdr selection))
  63.          end (max (car selection) (cdr selection))
  64.          valid (and valid
  65.                 (eq (marker-buffer (car selection))
  66.                 (extent-buffer previous-extent)))
  67.          buffer (marker-buffer (car selection))))
  68.       ((extentp selection)
  69.        (setq start (extent-start-position selection)
  70.          end (extent-end-position selection)
  71.          valid (and valid
  72.                 (eq (extent-buffer selection)
  73.                 (extent-buffer previous-extent)))
  74.          buffer (extent-buffer selection)))
  75.       )
  76.     (if (and (not valid)
  77.          (extentp previous-extent)
  78.          (extent-buffer previous-extent)
  79.          (buffer-name (extent-buffer previous-extent)))
  80.     (delete-extent previous-extent))
  81.     (if (not buffer)
  82.     ;; string case
  83.     nil
  84.       ;; normal case
  85.       (if valid
  86.       (set-extent-endpoints previous-extent start end)
  87.     (setq previous-extent (make-extent start end buffer))
  88.     ;; use same priority as mouse-highlighting so that conflicts between
  89.     ;; the selection extent and a mouse-highlighted extent are resolved
  90.     ;; by the usual size-and-endpoint-comparison method.
  91.     (set-extent-priority previous-extent mouse-highlight-priority)
  92.     (set-extent-face previous-extent face)))))
  93.  
  94.  
  95. (defun x-own-selection (selection &optional type)
  96.   "Make a primary X Selection of the given argument.  
  97. The argument may be a string, a cons of two markers, or an extent.  
  98. In the latter cases the selection is considered to be the text 
  99. between the markers, or the between extents endpoints."
  100.   (interactive (if (not current-prefix-arg)
  101.            (list (read-string "Store text for pasting: "))
  102.          (list (cons ;; these need not be ordered.
  103.             (copy-marker (point-marker))
  104.             (copy-marker (mark-marker))))))
  105.   (or (stringp selection)
  106.       (extentp selection)
  107.       (and (consp selection)
  108.        (markerp (car selection))
  109.        (markerp (cdr selection))
  110.        (marker-buffer (car selection))
  111.        (marker-buffer (cdr selection))
  112.        (eq (marker-buffer (car selection))
  113.            (marker-buffer (cdr selection)))
  114.        (buffer-name (marker-buffer (car selection)))
  115.        (buffer-name (marker-buffer (cdr selection))))
  116.       (signal 'error (list "invalid selection" selection)))
  117.   (or type (setq type 'PRIMARY))
  118.   (x-own-selection-internal type selection)
  119.   (cond ((eq type 'PRIMARY)
  120.      (setq primary-selection-extent
  121.            (x-select-make-extent-for-selection
  122.         selection primary-selection-extent 'primary-selection)))
  123.     ((eq type 'SECONDARY)
  124.      (setq secondary-selection-extent
  125.            (x-select-make-extent-for-selection
  126.         selection secondary-selection-extent 'secondary-selection))))
  127.   ;; kludgoriffic!
  128.   (if (and zmacs-regions (eq type 'PRIMARY) (not (consp selection)))
  129.       (setq zmacs-region-stays t))
  130.   selection)
  131.  
  132.  
  133. (defun x-own-secondary-selection (selection &optional type)
  134.   "Make a secondary X Selection of the given argument.  The argument may be a 
  135. string or a cons of two markers (in which case the selection is considered to
  136. be the text between those markers.)"
  137.   (interactive (if (not current-prefix-arg)
  138.            (list (read-string "Store text for pasting: "))
  139.          (list (cons ;; these need not be ordered.
  140.             (copy-marker (point-marker))
  141.             (copy-marker (mark-marker))))))
  142.   (x-own-selection selection 'SECONDARY))
  143.  
  144.  
  145. (defun x-own-clipboard (string)
  146.   "Paste the given string to the X Clipboard."
  147.   (x-own-selection string 'CLIPBOARD))
  148.  
  149.  
  150. (defun x-disown-selection (&optional secondary-p)
  151.   "Assuming we own the selection, disown it.  With an argument, discard the
  152. secondary selection instead of the primary selection."
  153.   (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
  154.  
  155. (defun x-dehilight-selection (selection)
  156.   "for use as a value of x-lost-selection-hooks."
  157.   (cond ((eq selection 'PRIMARY)
  158.      (if primary-selection-extent
  159.          (let ((inhibit-quit t))
  160.            (delete-extent primary-selection-extent)
  161.            (setq primary-selection-extent nil)))
  162.      (if zmacs-regions (zmacs-deactivate-region)))
  163.     ((eq selection 'SECONDARY)
  164.      (if secondary-selection-extent
  165.          (let ((inhibit-quit t))
  166.            (delete-extent secondary-selection-extent)
  167.            (setq secondary-selection-extent nil)))))
  168.   nil)
  169.  
  170. (setq x-lost-selection-hooks 'x-dehilight-selection)
  171.  
  172. (defun x-notice-selection-requests (selection type successful)
  173.   "for possible use as the value of x-sent-selection-hooks."
  174.   (if (not successful)
  175.       (message "Selection request failed to convert %s to %s"
  176.            selection type)
  177.     (message "Sent selection %s as %s" selection type)))
  178.  
  179. (defun x-notice-selection-failures (selection type successful)
  180.   "for possible use as the value of x-sent-selection-hooks."
  181.   (or successful
  182.       (message "Selection request failed to convert %s to %s"
  183.            selection type)))
  184.  
  185. ;(setq x-sent-selection-hooks 'x-notice-selection-requests)
  186. ;(setq x-sent-selection-hooks 'x-notice-selection-failures)
  187.  
  188.  
  189. ;;; Selections in killed buffers
  190. ;;; this function is called by kill-buffer as if it were on the 
  191. ;;; kill-buffer-hook (though it isn't really.)
  192.  
  193. (defun xselect-kill-buffer-hook ()
  194.   ;; Probably the right thing is to write a C function to return a list
  195.   ;; of the selections which emacs owns, since it could concievably own
  196.   ;; a user-defined selection type that we've never heard of.
  197.   (xselect-kill-buffer-hook-1 'PRIMARY)
  198.   (xselect-kill-buffer-hook-1 'SECONDARY)
  199.   (xselect-kill-buffer-hook-1 'CLIPBOARD))
  200.  
  201. (defun xselect-kill-buffer-hook-1 (selection)
  202.   (let (value)
  203.     (if (and (x-selection-owner-p selection)
  204.          (setq value (x-get-selection-internal selection '_EMACS_INTERNAL))
  205.          ;; The _EMACS_INTERNAL selection type has a converter registered
  206.          ;; for it that does no translation.  This only works if emacs is
  207.          ;; requesting the selection from itself.  We could have done this
  208.          ;; by writing a C function to return the raw selection data, and
  209.          ;; that might be the right way to do this, but this was easy.
  210.          (or (and (consp value)
  211.               (markerp (car value))
  212.               (eq (current-buffer) (marker-buffer (car value))))
  213.          (and (extentp value)
  214.               (eq (current-buffer) (extent-buffer value)))))
  215.     (x-disown-selection-internal selection))))
  216.  
  217.  
  218. ;;; Cut Buffer support
  219.  
  220. (defun x-get-cutbuffer (&optional which-one)
  221.   "Returns the value of one of the 8 X server cut-buffers.  Optional arg
  222. WHICH-ONE should be a number from 0 to 7, defaulting to 0.
  223. Cut buffers are considered obsolete\; you should use selections instead."
  224.   (x-get-cutbuffer-internal
  225.    (if which-one
  226.        (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3
  227.           CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7]
  228.          which-one)
  229.      'CUT_BUFFER0)))
  230.  
  231. (defun x-store-cutbuffer (string)
  232.   "Store the given string into the X server's primary cut buffer.
  233. The previous value of the primary cut buffer is rotated to the secondary
  234. cut buffer, and the second to the third, and so on (there are 8 buffers.)
  235. Cut buffers are considered obsolete\; you should use selections instead."
  236.   (or (stringp string) (error "must be a string"))
  237.   (x-rotate-cutbuffers-internal 1)
  238.   (x-store-cutbuffer-internal 'CUT_BUFFER0 string))
  239.  
  240.  
  241. ;;; Random utility functions
  242.  
  243. (defun x-kill-primary-selection ()
  244.   "If there is a selection, delete the text it covers, and copy it to 
  245. both the kill ring and the Clipboard."
  246.   (interactive)
  247.   (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
  248.   (setq last-command nil)
  249.   (or primary-selection-extent
  250.       (error "the primary selection is not an extent?"))
  251.   (save-excursion
  252.     (set-buffer (extent-buffer primary-selection-extent))
  253.     (kill-region (extent-start-position primary-selection-extent)
  254.          (extent-end-position primary-selection-extent)))
  255.   (x-disown-selection nil))
  256.  
  257. (defun x-delete-primary-selection ()
  258.   "If there is a selection, delete the text it covers *without* copying it to
  259. the kill ring or the Clipboard."
  260.   (interactive)
  261.   (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
  262.   (setq last-command nil)
  263.   (or primary-selection-extent
  264.       (error "the primary selection is not an extent?"))
  265.   (save-excursion
  266.     (set-buffer (extent-buffer primary-selection-extent))
  267.     (delete-region (extent-start-position primary-selection-extent)
  268.            (extent-end-position primary-selection-extent)))
  269.   (x-disown-selection nil))
  270.  
  271. (defun x-copy-primary-selection ()
  272.   "If there is a selection, copy it to both the kill ring and the Clipboard."
  273.   (interactive)
  274.   (setq last-command nil)
  275.   (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
  276.   (or primary-selection-extent
  277.       (error "the primary selection is not an extent?"))
  278.   (save-excursion
  279.     (set-buffer (extent-buffer primary-selection-extent))
  280.     (copy-region-as-kill (extent-start-position primary-selection-extent)
  281.              (extent-end-position primary-selection-extent))))
  282.  
  283. (defun x-yank-clipboard-selection ()
  284.   "If someone owns a Clipboard selection, insert it at point."
  285.   (interactive)
  286.   (setq last-command nil)
  287.   (let ((clip (x-get-clipboard)))
  288.     (or clip (error "there is no clipboard selection"))
  289.     (push-mark)
  290.     (insert clip)))
  291.  
  292.  
  293. ;;; Functions to convert the selection into various other selection types.
  294. ;;; Every selection type that emacs handles is implemented this way, except
  295. ;;; for TIMESTAMP, which is a special case.
  296.  
  297. (defun xselect-convert-to-string (selection type value)
  298.   (cond ((stringp value)
  299.      value)
  300.     ((extentp value)
  301.      (save-excursion
  302.        (set-buffer (extent-buffer value))
  303.        (buffer-substring (extent-start-position value)
  304.                  (extent-end-position value))))
  305.     ((and (consp value)
  306.           (markerp (car value))
  307.           (markerp (cdr value)))
  308.      (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
  309.          (signal 'error
  310.              (list "markers must be in the same buffer"
  311.                (car value) (cdr value))))
  312.      (save-excursion
  313.        (set-buffer (or (marker-buffer (car value))
  314.                (error "selection is in a killed buffer")))
  315.        (buffer-substring (car value) (cdr value))))
  316.     (t nil)))
  317.  
  318. (defun xselect-convert-to-length (selection type value)
  319.   (let ((value
  320.      (cond ((stringp value)
  321.         (length value))
  322.            ((extentp value)
  323.         (extent-length value))
  324.            ((and (consp value)
  325.              (markerp (car value))
  326.              (markerp (cdr value)))
  327.         (or (eq (marker-buffer (car value))
  328.             (marker-buffer (cdr value)))
  329.             (signal 'error
  330.                 (list "markers must be in the same buffer"
  331.                   (car value) (cdr value))))
  332.         (abs (- (car value) (cdr value)))))))
  333.     (if value ; force it to be in 32-bit format.
  334.     (cons (ash value -16) (logand value 65535))
  335.       nil)))
  336.  
  337. (defun xselect-convert-to-targets (selection type value)
  338.   ;; return a vector of atoms, but remove duplicates first.
  339.   (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
  340.      (rest all))
  341.     (while rest
  342.       (cond ((memq (car rest) (cdr rest))
  343.          (setcdr rest (delq (car rest) (cdr rest))))
  344.         ((eq (car (cdr rest)) '_EMACS_INTERNAL)  ; shh, it's a secret
  345.          (setcdr rest (cdr (cdr rest))))
  346.         (t
  347.          (setq rest (cdr rest)))))
  348.     (apply 'vector all)))
  349.  
  350. (defun xselect-convert-to-delete (selection type value)
  351.   (x-disown-selection-internal selection)
  352.   ;; A return value of nil means that we do not know how to do this conversion,
  353.   ;; and replies with an "error".  A return value of NULL means that we have
  354.   ;; done the conversion (and any side-effects) but have no value to return.
  355.   'NULL)
  356.  
  357. (defun xselect-convert-to-filename (selection type value)
  358.   (cond ((extentp value)
  359.      (buffer-file-name (or (extent-buffer value)
  360.                    (error "selection is in a killed buffer"))))
  361.     ((and (consp value)
  362.           (markerp (car value))
  363.           (markerp (cdr value)))
  364.      (buffer-file-name (or (marker-buffer (car value))
  365.                    (error "selection is in a killed buffer"))))
  366.     (t nil)))
  367.  
  368. (defun xselect-convert-to-charpos (selection type value)
  369.   (let (a b tmp)
  370.     (cond ((cond ((extentp value)
  371.           (setq a (extent-start-position value)
  372.             b (extent-end-position value)))
  373.          ((and (consp value)
  374.                (markerp (car value))
  375.                (markerp (cdr value)))
  376.           (setq a (car value)
  377.             b (cdr value))))
  378.        (setq a (1- a) b (1- b)) ; zero-based
  379.        (if (< b a) (setq tmp a a b b tmp))
  380.        (cons 'SPAN
  381.          (vector (cons (ash a -16) (logand a 65535))
  382.              (cons (ash b -16) (logand b 65535))))))))
  383.  
  384. (defun xselect-convert-to-lineno (selection type value)
  385.   (let (a b buf tmp)
  386.     (cond ((cond ((extentp value)
  387.           (setq buf (extent-buffer value)
  388.             a (extent-start-position value)
  389.             b (extent-end-position value)))
  390.          ((and (consp value)
  391.                (markerp (car value))
  392.                (markerp (cdr value)))
  393.           (setq a (marker-position (car value))
  394.             b (marker-position (cdr value))
  395.             buf (marker-buffer (car value)))))
  396.        (save-excursion
  397.          (set-buffer buf)
  398.          (setq a (count-lines 1 a)
  399.            b (count-lines 1 b)))
  400.        (if (< b a) (setq tmp a a b b tmp))
  401.        (cons 'SPAN
  402.          (vector (cons (ash a -16) (logand a 65535))
  403.              (cons (ash b -16) (logand b 65535))))))))
  404.  
  405. (defun xselect-convert-to-colno (selection type value)
  406.   (let (a b buf tmp)
  407.     (cond ((cond ((extentp value)
  408.           (setq buf (extent-buffer value)
  409.             a (extent-start-position value)
  410.             b (extent-end-position value)))
  411.          ((and (consp value)
  412.                (markerp (car value))
  413.                (markerp (cdr value)))
  414.           (setq a (car value)
  415.             b (cdr value)
  416.             buf (marker-buffer a))))
  417.        (save-excursion
  418.          (set-buffer buf)
  419.          (goto-char a)
  420.          (setq a (current-column))
  421.          (goto-char b)
  422.          (setq b (current-column)))
  423.        (if (< b a) (setq tmp a a b b tmp))
  424.        (cons 'SPAN
  425.          (vector (cons (ash a -16) (logand a 65535))
  426.              (cons (ash b -16) (logand b 65535))))))))
  427.  
  428. (defun xselect-convert-to-os (selection type size)
  429.   (symbol-name system-type))
  430.  
  431. (defun xselect-convert-to-host (selection type size)
  432.   (system-name))
  433.  
  434. (defun xselect-convert-to-user (selection type size)
  435.   (user-full-name))
  436.  
  437. (defun xselect-convert-to-class (selection type size)
  438.   x-emacs-application-class)
  439.  
  440. (defun xselect-convert-to-name (selection type size)
  441.   invocation-name)
  442.  
  443. (defun xselect-convert-to-integer (selection type value)
  444.   (and (integerp value)
  445.        (cons (ash value -16) (logand value 65535))))
  446.  
  447. (defun xselect-convert-to-atom (selection type value)
  448.   (and (symbolp value) value))
  449.  
  450. (defun xselect-convert-to-identity (selection type value) ; used internally
  451.   (vector value))
  452.  
  453. (setq selection-converter-alist
  454.       '((TEXT . xselect-convert-to-string)
  455.     (STRING . xselect-convert-to-string)
  456.     (TARGETS . xselect-convert-to-targets)
  457.     (LENGTH . xselect-convert-to-length)
  458.     (DELETE . xselect-convert-to-delete)
  459.     (FILE_NAME . xselect-convert-to-filename)
  460.     (CHARACTER_POSITION . xselect-convert-to-charpos)
  461.     (LINE_NUMBER . xselect-convert-to-lineno)
  462.     (COLUMN_NUMBER . xselect-convert-to-colno)
  463.     (OWNER_OS . xselect-convert-to-os)
  464.     (HOST_NAME . xselect-convert-to-host)
  465.     (USER . xselect-convert-to-user)
  466.     (CLASS . xselect-convert-to-class)
  467.     (NAME . xselect-convert-to-name)
  468.     (ATOM . xselect-convert-to-atom)
  469.     (INTEGER . xselect-convert-to-integer)
  470.     (_EMACS_INTERNAL . xselect-convert-to-identity)
  471.     ))
  472.  
  473.  
  474. (provide 'xselect)
  475.