Commit 3109d63f authored by Eric S. Raymond's avatar Eric S. Raymond

Initial revision

parent 76550a57
;;; lselect.el --- Lucid interface to X Selections
;; Keywords: emulations
;; This won't completely work until we support or emulate Lucid-style extents.
;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
;; Based on Lucid's selection code.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Code:
;;; The selection code requires us to use certain symbols whose names are
;;; all upper-case; this may seem tasteless, but it makes there be a 1:1
;;; correspondence between these symbols and X Atoms (which are upcased.)
(fset 'x-get-cutbuffer 'x-get-cut-buffer)
(fset 'x-store-cutbuffer 'x-set-cut-buffer)
(or (find-face 'primary-selection)
(make-face 'primary-selection))
(or (find-face 'secondary-selection)
(make-face 'secondary-selection))
(defun x-get-secondary-selection ()
"Return text selected from some X window."
(x-get-selection-internal 'SECONDARY 'STRING))
(defvar primary-selection-extent nil
"The extent of the primary selection; don't use this.")
(defvar secondary-selection-extent nil
"The extent of the secondary selection; don't use this.")
(defun x-select-make-extent-for-selection (selection previous-extent face)
;; Given a selection, this makes an extent in the buffer which holds that
;; selection, for highlighting purposes. If the selection isn't associated
;; with a buffer, this does nothing.
(let ((buffer nil)
(valid (and (extentp previous-extent)
(extent-buffer previous-extent)
(buffer-name (extent-buffer previous-extent))))
start end)
(cond ((stringp selection)
;; if we're selecting a string, lose the previous extent used
;; to highlight the selection.
(setq valid nil))
((consp selection)
(setq start (min (car selection) (cdr selection))
end (max (car selection) (cdr selection))
valid (and valid
(eq (marker-buffer (car selection))
(extent-buffer previous-extent)))
buffer (marker-buffer (car selection))))
((extentp selection)
(setq start (extent-start-position selection)
end (extent-end-position selection)
valid (and valid
(eq (extent-buffer selection)
(extent-buffer previous-extent)))
buffer (extent-buffer selection)))
)
(if (and (not valid)
(extentp previous-extent)
(extent-buffer previous-extent)
(buffer-name (extent-buffer previous-extent)))
(delete-extent previous-extent))
(if (not buffer)
;; string case
nil
;; normal case
(if valid
(set-extent-endpoints previous-extent start end)
(setq previous-extent (make-extent start end buffer))
;; use same priority as mouse-highlighting so that conflicts between
;; the selection extent and a mouse-highlighted extent are resolved
;; by the usual size-and-endpoint-comparison method.
(set-extent-priority previous-extent mouse-highlight-priority)
(set-extent-face previous-extent face)))))
(defun x-own-selection (selection &optional type)
"Make a primary X Selection of the given argument.
The argument may be a string, a cons of two markers, or an extent.
In the latter cases the selection is considered to be the text
between the markers, or the between extents endpoints."
(interactive (if (not current-prefix-arg)
(list (read-string "Store text for pasting: "))
(list (cons ;; these need not be ordered.
(copy-marker (point-marker))
(copy-marker (mark-marker))))))
(or type (setq type 'PRIMARY))
(x-set-selection selection type)
(cond ((eq type 'PRIMARY)
(setq primary-selection-extent
(x-select-make-extent-for-selection
selection primary-selection-extent 'primary-selection)))
((eq type 'SECONDARY)
(setq secondary-selection-extent
(x-select-make-extent-for-selection
selection secondary-selection-extent 'secondary-selection))))
selection)
(defun x-own-secondary-selection (selection &optional type)
"Make a secondary X Selection of the given argument. The argument may be a
string or a cons of two markers (in which case the selection is considered to
be the text between those markers.)"
(interactive (if (not current-prefix-arg)
(list (read-string "Store text for pasting: "))
(list (cons ;; these need not be ordered.
(copy-marker (point-marker))
(copy-marker (mark-marker))))))
(x-own-selection selection 'SECONDARY))
(defun x-own-clipboard (string)
"Paste the given string to the X Clipboard."
(x-own-selection string 'CLIPBOARD))
(defun x-disown-selection (&optional secondary-p)
"Assuming we own the selection, disown it. With an argument, discard the
secondary selection instead of the primary selection."
(x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
(defun x-dehilight-selection (selection)
"for use as a value of x-lost-selection-hooks."
(cond ((eq selection 'PRIMARY)
(if primary-selection-extent
(let ((inhibit-quit t))
(delete-extent primary-selection-extent)
(setq primary-selection-extent nil)))
(if zmacs-regions (zmacs-deactivate-region)))
((eq selection 'SECONDARY)
(if secondary-selection-extent
(let ((inhibit-quit t))
(delete-extent secondary-selection-extent)
(setq secondary-selection-extent nil)))))
nil)
(setq x-lost-selection-hooks 'x-dehilight-selection)
(defun x-notice-selection-requests (selection type successful)
"for possible use as the value of x-sent-selection-hooks."
(if (not successful)
(message "Selection request failed to convert %s to %s"
selection type)
(message "Sent selection %s as %s" selection type)))
(defun x-notice-selection-failures (selection type successful)
"for possible use as the value of x-sent-selection-hooks."
(or successful
(message "Selection request failed to convert %s to %s"
selection type)))
;(setq x-sent-selection-hooks 'x-notice-selection-requests)
;(setq x-sent-selection-hooks 'x-notice-selection-failures)
;;; Random utility functions
(defun x-kill-primary-selection ()
"If there is a selection, delete the text it covers, and copy it to
both the kill ring and the Clipboard."
(interactive)
(or (x-selection-owner-p) (error "emacs does not own the primary selection"))
(setq last-command nil)
(or primary-selection-extent
(error "the primary selection is not an extent?"))
(save-excursion
(set-buffer (extent-buffer primary-selection-extent))
(kill-region (extent-start-position primary-selection-extent)
(extent-end-position primary-selection-extent)))
(x-disown-selection nil))
(defun x-delete-primary-selection ()
"If there is a selection, delete the text it covers *without* copying it to
the kill ring or the Clipboard."
(interactive)
(or (x-selection-owner-p) (error "emacs does not own the primary selection"))
(setq last-command nil)
(or primary-selection-extent
(error "the primary selection is not an extent?"))
(save-excursion
(set-buffer (extent-buffer primary-selection-extent))
(delete-region (extent-start-position primary-selection-extent)
(extent-end-position primary-selection-extent)))
(x-disown-selection nil))
(defun x-copy-primary-selection ()
"If there is a selection, copy it to both the kill ring and the Clipboard."
(interactive)
(setq last-command nil)
(or (x-selection-owner-p) (error "emacs does not own the primary selection"))
(or primary-selection-extent
(error "the primary selection is not an extent?"))
(save-excursion
(set-buffer (extent-buffer primary-selection-extent))
(copy-region-as-kill (extent-start-position primary-selection-extent)
(extent-end-position primary-selection-extent))))
(defun x-yank-clipboard-selection ()
"If someone owns a Clipboard selection, insert it at point."
(interactive)
(setq last-command nil)
(let ((clip (x-get-clipboard)))
(or clip (error "there is no clipboard selection"))
(push-mark)
(insert clip)))
;;; lselect.el ends here.
;;; select.el --- lisp portion of standard selection support.
;; Keywords: internal
;; Copyright (c) 1993 Free Software Foundation, Inc.
;; Based partially on earlier release by Lucid.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Code:
;; This is for temporary compatibility with pre-release Emacs 19.
(fset 'x-selection 'x-get-selection)
(defun x-get-selection (&optional type data-type)
"Return the value of an X Windows selection.
The argument TYPE (default `PRIMARY') says which selection,
and the argument DATA-TYPE (default `STRING') says how to convert the data."
(x-get-selection-internal (or type 'PRIMARY) (or data-type 'STRING)))
(defun x-get-clipboard ()
"Return text pasted to the clipboard."
(x-get-selection-internal 'CLIPBOARD 'STRING))
(defun x-set-selection (type data)
"Make an X Windows selection of type TYPE and value DATA.
The argument TYPE (default `PRIMARY') says which selection,
and DATA specifies the contents. DATA may be a string,
a symbol, an integer (or a cons of two integers or list of two integers),
or a cons of two markers pointing to the same buffer.
In the last case, the selection is considered to be the text
between the markers.
The data may also be a vector of valid non-vector selection values."
(interactive (if (not current-prefix-arg)
(list (read-string "Store text for pasting: "))
(list (cons ;; these need not be ordered.
(copy-marker (point-marker))
(copy-marker (mark-marker))))))
;; This is for temporary compatibility with pre-release Emacs 19.
(if (stringp type)
(setq type (intern type)))
(or (x-valid-simple-selection-p data)
(and (vectorp data)
(let ((valid t)
(i (1- (length data))))
(while (>= i 0)
(or (x-valid-simple-selection-p (aref data i))
(setq valid nil))
(setq i (1- i)))
valid))
(signal 'error (list "invalid selection" data)))
(or type (setq type 'PRIMARY))
(if data
(x-own-selection-internal type data)
(x-disown-selection-internal type))
data)
(defun x-valid-simple-selection-p (data)
(or (stringp data)
(symbolp data)
(integerp data)
(and (consp data)
(integerp (car data))
(or (integerp (cdr data))
(and (consp (cdr data))
(integerp (car (cdr data))))))
;;; (and (fboundp 'extentp)
;;; (extentp data))
(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))))))
;;; Cut Buffer support
(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.
Cut buffers are considered obsolete; you should use selections instead."
(x-get-cut-buffer-internal
(if which-one
(aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3
CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7]
which-one)
'CUT_BUFFER0)))
(defun x-set-cut-buffer (string)
"Store STRING into the X server's primary cut buffer.
The previous value of the primary cut buffer is rotated to the secondary
cut buffer, and the second to the third, and so on (there are 8 buffers.)
Cut buffers are considered obsolete; you should use selections instead."
;; Check the data type of STRING.
(substring string 0 0)
(x-rotate-cut-buffers-internal 1)
(x-store-cut-buffer-internal 'CUT_BUFFER0 string))
;;; Functions to convert the selection into various other selection types.
;;; Every selection type that Emacs handles is implemented this way, except
;;; for TIMESTAMP, which is a special case.
(defun xselect-convert-to-string (selection type value)
(cond ((stringp value)
value)
;;; ((extentp value)
;;; (save-excursion
;;; (set-buffer (extent-buffer value))
;;; (buffer-substring (extent-start-position value)
;;; (extent-end-position value))))
((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))))
(save-excursion
(set-buffer (or (marker-buffer (car value))
(error "selection is in a killed buffer")))
(buffer-substring (car value) (cdr value))))
(t nil)))
(defun xselect-convert-to-length (selection type value)
(let ((value
(cond ((stringp value)
(length value))
;;; ((extentp value)
;;; (extent-length value))
((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)))))))
(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))
(while rest
(cond ((memq (car rest) (cdr rest))
(setcdr rest (delq (car rest) (cdr rest))))
((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret
(setcdr rest (cdr (cdr rest))))
(t
(setq rest (cdr rest)))))
(apply 'vector all)))
(defun xselect-convert-to-delete (selection type value)
(x-disown-selection-internal selection)
;; A return value of nil means that we do not know how to do this conversion,
;; and replies with an "error". A return value of NULL means that we have
;; done the conversion (and any side-effects) but have no value to return.
'NULL)
(defun xselect-convert-to-filename (selection type value)
(cond
;;; ((extentp value)
;;; (buffer-file-name (or (extent-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"))))
(t nil)))
(defun xselect-convert-to-charpos (selection type value)
(let (a b tmp)
(cond ((cond
;;; ((extentp value)
;;; (setq a (extent-start-position value)
;;; b (extent-end-position value)))
((and (consp value)
(markerp (car value))
(markerp (cdr value)))
(setq a (car value)
b (cdr value))))
(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)
(cond ((cond ((and (consp value)
(markerp (car value))
(markerp (cdr value)))
(setq a (marker-position (car value))
b (marker-position (cdr value))
buf (marker-buffer (car value))))
;;; ((extentp value)
;;; (setq buf (extent-buffer value)
;;; a (extent-start-position value)
;;; b (extent-end-position value)))
)
(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))
(cons (ash b -16) (logand b 65535))))))))
(defun xselect-convert-to-colno (selection type value)
(let (a b buf tmp)
(cond ((cond ((and (consp value)
(markerp (car value))
(markerp (cdr value)))
(setq a (car value)
b (cdr value)
buf (marker-buffer a)))
;;; ((extentp value)
;;; (setq buf (extent-buffer value)
;;; a (extent-start-position value)
;;; b (extent-end-position value)))
)
(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))
(cons 'SPAN
(vector (cons (ash a -16) (logand a 65535))
(cons (ash b -16) (logand b 65535))))))))
(defun xselect-convert-to-os (selection type size)
(symbol-name system-type))
(defun xselect-convert-to-host (selection type size)
(system-name))
(defun xselect-convert-to-user (selection type size)
(user-full-name))
(defun xselect-convert-to-class (selection type size)
x-emacs-application-class)
;; We do not try to determine the name Emacs was invoked with,
;; because it is not clean for a program's behavior to depend on that.
(defun xselect-convert-to-name (selection type size)
"emacs")
(defun xselect-convert-to-integer (selection type value)
(and (integerp value)
(cons (ash value -16) (logand value 65535))))
(defun xselect-convert-to-atom (selection type value)
(and (symbolp value) value))
(defun xselect-convert-to-identity (selection type value) ; used internally
(vector value))
(setq selection-converter-alist
'((TEXT . xselect-convert-to-string)
(STRING . xselect-convert-to-string)
(TARGETS . xselect-convert-to-targets)
(LENGTH . xselect-convert-to-length)
(DELETE . xselect-convert-to-delete)
(FILE_NAME . xselect-convert-to-filename)
(CHARACTER_POSITION . xselect-convert-to-charpos)
(LINE_NUMBER . xselect-convert-to-lineno)
(COLUMN_NUMBER . xselect-convert-to-colno)
(OWNER_OS . xselect-convert-to-os)
(HOST_NAME . xselect-convert-to-host)
(USER . xselect-convert-to-user)
(CLASS . xselect-convert-to-class)
(NAME . xselect-convert-to-name)
(ATOM . xselect-convert-to-atom)
(INTEGER . xselect-convert-to-integer)
(_EMACS_INTERNAL . xselect-convert-to-identity)
))
(provide 'select)
;;; select.el ends here.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment