XEmacs 21.2.32 "Kastor & Polydeukes".
[chise/xemacs-chise.git.1] / lisp / select.el
1 ;;; select.el --- Lisp interface to windows selections.
2
3 ;; Copyright (C) 1998 Andy Piper.
4 ;; Copyright (C) 1990, 1997 Free Software Foundation, Inc.
5 ;; Copyright (C) 1995 Sun Microsystems.
6
7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: extensions, dumped
9
10 ;; This file is part of XEmacs.
11
12 ;; XEmacs is free software; you can redistribute it and/or modify it
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; XEmacs is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20 ;; General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING.  If not, write to the 
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
26
27 ;;; Synched up with: Not in FSF
28
29 ;;; Commentary:
30
31 ;; This file is dumped with XEmacs 
32
33 ;;; Code:
34
35 (defvar selected-text-type
36   (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING)
37   "The type atom used to obtain selections from the X server.
38 Can be either a valid X selection data type, or a list of such types.
39 COMPOUND_TEXT and STRING are the most commonly used data types.
40 If a list is provided, the types are tried in sequence until
41 there is a successful conversion.")
42
43 (defvar selection-sets-clipboard nil 
44   "Controls the selection's relationship to the clipboard.
45 When non-nil, any operation that sets the primary selection will also
46 set the clipboard.")
47
48 (defun copy-primary-selection ()
49   "Copy the selection to the Clipboard and the kill ring."
50   (interactive)
51   (and (console-on-window-system-p)
52        (cut-copy-clear-internal 'copy)))
53
54 (defun kill-primary-selection ()
55   "Copy the selection to the Clipboard and the kill ring, then delete it."
56   (interactive "*")
57   (and (console-on-window-system-p)
58        (cut-copy-clear-internal 'cut)))
59
60 (defun delete-primary-selection ()
61   "Delete the selection without copying it to the Clipboard or the kill ring."
62   (interactive "*")
63   (and (console-on-window-system-p)
64        (cut-copy-clear-internal 'clear)))
65
66 (defun yank-clipboard-selection ()
67   "Insert the current Clipboard selection at point."
68   (interactive "*")
69   (when (console-on-window-system-p)
70     (setq last-command nil)
71     (setq this-command 'yank) ; so that yank-pop works.
72     (let ((clip (get-clipboard)))
73       (or clip (error "there is no clipboard selection"))
74       (push-mark)
75       (insert clip))))
76
77 (defun get-clipboard ()
78   "Return text pasted to the clipboard."
79   (get-selection 'CLIPBOARD))
80
81 (define-device-method get-cutbuffer
82   "Return the value of one of the cut buffers.
83 This will do nothing under anything other than X.")
84
85 (defun get-selection-no-error (&optional type data-type)
86   "Return the value of a window-system selection.
87 The argument TYPE (default `PRIMARY') says which selection,
88 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
89 says how to convert the data. Returns NIL if there is no selection"
90   (condition-case err (get-selection type data-type) (t nil)))
91
92 (defun get-selection (&optional type data-type)
93   "Return the value of a window-system selection.
94 The argument TYPE (default `PRIMARY') says which selection,
95 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
96 says how to convert the data. If there is no selection an error is signalled."
97   (or type (setq type 'PRIMARY))
98   (or data-type (setq data-type selected-text-type))
99   (let ((text
100          (if (consp data-type)
101              (condition-case err
102                  (get-selection-internal type (car data-type))
103                (selection-conversion-error
104                 (if (cdr data-type)
105                     (get-selection type (cdr data-type))
106                   (signal (car err) (cdr err)))))
107            (get-selection-internal type data-type))))
108     (when (and (consp text) (symbolp (car text)))
109       (setq text (cdr text)))
110     (when (not (stringp text))
111       (error "Selection is not a string: %S" text))
112     text))
113
114 ;; FSFmacs calls this `x-set-selection', and reverses the
115 ;; first two arguments (duh ...).  This order is more logical.
116 (defun own-selection (data &optional type append)
117   "Make a window-system selection of type TYPE and value DATA.
118 The argument TYPE (default `PRIMARY') says which selection,
119 and DATA specifies the contents.  DATA may be a string,
120 a symbol, an integer (or a cons of two integers or list of two integers).
121 If APPEND is non-nil, append the data to the existing selection data.
122
123 The selection may also be a cons of two markers pointing to the same buffer,
124 or an overlay.  In these cases, the selection is considered to be the text
125 between the markers *at whatever time the selection is examined*.
126 Thus, editing done in the buffer after you specify the selection
127 can alter the effective value of the selection.
128
129 The data may also be a vector of valid non-vector selection values.
130
131 Interactively, the text of the region is used as the selection value."
132   (interactive (if (not current-prefix-arg)
133                    (list (read-string "Store text for pasting: "))
134                  (list (substring (region-beginning) (region-end)))))
135   ;; calling own-selection-internal will mess this up, so preserve it.
136   (let ((zmacs-region-stays zmacs-region-stays))
137                                         ;FSFmacs huh??  It says:
138     ;; "This is for temporary compatibility with pre-release Emacs 19."
139                                         ;(if (stringp type)
140                                         ;    (setq type (intern type)))
141     (or (valid-simple-selection-p data)
142         (and (vectorp data)
143              (let ((valid t)
144                    (i (1- (length data))))
145                (while (>= i 0)
146                  (or (valid-simple-selection-p (aref data i))
147                      (setq valid nil))
148                  (setq i (1- i)))
149                valid))
150         (signal 'error (list "invalid selection" data)))
151     (or type (setq type 'PRIMARY))
152     (flet ((own-selection-1
153             (type data append)
154             (when append
155               (unless (stringp data)
156                 ;; kludge!
157                 (setq data (select-convert-to-text type 'STRING data))
158                 (if (stringp data)
159                     (setq data (concat (get-selection type) data)))))
160             (own-selection-internal type data)))
161       (if (null data)
162           (disown-selection-internal type)
163         (own-selection-1 type data append)
164         (when (and (eq type 'PRIMARY)
165                    selection-sets-clipboard)
166           (own-selection-internal 'CLIPBOARD data append))))
167     (cond ((eq type 'PRIMARY)
168            (setq primary-selection-extent
169                  (select-make-extent-for-selection
170                   data primary-selection-extent)))
171           ((eq type 'SECONDARY)
172            (setq secondary-selection-extent
173                  (select-make-extent-for-selection
174                   data secondary-selection-extent)))))
175   ;; zmacs-region-stays is for commands, not low-level functions.
176   ;; when behaving as the latter, we better not set it, or we will
177   ;; cause unwanted sticky-region behavior in kill-region and friends.
178   (if (interactive-p)
179       (setq zmacs-region-stays t))
180   data)
181
182 (defun dehilight-selection (selection)
183   "for use as a value of `lost-selection-hooks'."
184   (cond ((eq selection 'PRIMARY)
185          (if primary-selection-extent
186              (let ((inhibit-quit t))
187                (if (consp primary-selection-extent)
188                    (mapcar 'delete-extent primary-selection-extent)
189                  (delete-extent primary-selection-extent))
190                (setq primary-selection-extent nil)))
191          (if zmacs-regions (zmacs-deactivate-region)))
192         ((eq selection 'SECONDARY)
193          (if secondary-selection-extent
194              (let ((inhibit-quit t))
195                (if (consp secondary-selection-extent)
196                    (mapcar 'delete-extent secondary-selection-extent)
197                  (delete-extent secondary-selection-extent))
198                (setq secondary-selection-extent nil)))))
199   nil)
200
201 (setq lost-selection-hooks 'dehilight-selection)
202
203 (defun own-clipboard (string &optional append)
204   "Paste the given string to the window system Clipboard.
205 If APPEND is non-nil, append the string to the existing contents."
206   (own-selection string 'CLIPBOARD))
207
208 (defun disown-selection (&optional secondary-p)
209   "Assuming we own the selection, disown it.  With an argument, discard the
210 secondary selection instead of the primary selection."
211   (disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY))
212   (when (and selection-sets-clipboard
213              (or (not secondary-p)
214                  (eq secondary-p 'PRIMARY)
215                  (eq secondary-p 'CLIPBOARD)))
216     (disown-selection-internal 'CLIPBOARD)))
217
218 ;; from x-init.el
219 ;; selections and active regions
220
221 ;; If and only if zmacs-regions is true:
222
223 ;; When a mark is pushed and the region goes into the "active" state, we
224 ;; assert it as the Primary selection.  This causes it to be hilighted.
225 ;; When the region goes into the "inactive" state, we disown the Primary
226 ;; selection, causing the region to be dehilighted.
227
228 ;; Note that it is possible for the region to be in the "active" state
229 ;; and not be hilighted, if it is in the active state and then some other
230 ;; application asserts the selection.  This is probably not a big deal.
231
232 (defun activate-region-as-selection ()
233   (if (marker-buffer (mark-marker t))
234       (own-selection (cons (point-marker t) (mark-marker t)))))
235
236 ; moved from x-select.el
237 (defvar primary-selection-extent nil
238   "The extent of the primary selection; don't use this.")
239
240 (defvar secondary-selection-extent nil
241   "The extent of the secondary selection; don't use this.")
242
243 (defun select-make-extent-for-selection (selection previous-extent)
244   ;; Given a selection, this makes an extent in the buffer which holds that
245   ;; selection, for highlighting purposes.  If the selection isn't associated
246   ;; with a buffer, this does nothing.
247   (let ((buffer nil)
248         (valid (and (extentp previous-extent)
249                     (extent-object previous-extent)
250                     (buffer-live-p (extent-object previous-extent))))
251         start end)
252     (cond ((stringp selection)
253            ;; if we're selecting a string, lose the previous extent used
254            ;; to highlight the selection.
255            (setq valid nil))
256           ((consp selection)
257            (setq start (min (car selection) (cdr selection))
258                  end (max (car selection) (cdr selection))
259                  valid (and valid
260                             (eq (marker-buffer (car selection))
261                                 (extent-object previous-extent)))
262                  buffer (marker-buffer (car selection))))
263           ((extentp selection)
264            (setq start (extent-start-position selection)
265                  end (extent-end-position selection)
266                  valid (and valid
267                             (eq (extent-object selection)
268                                 (extent-object previous-extent)))
269                  buffer (extent-object selection)))
270           (t
271            (signal 'error (list "invalid selection" selection))))
272
273     (if valid
274         nil
275       (condition-case ()
276           (if (listp previous-extent)
277               (mapcar 'delete-extent previous-extent)
278             (delete-extent previous-extent))
279         (error nil)))
280
281     (if (not buffer)
282         ;; string case
283         nil
284       ;; normal case
285       (if valid
286           (set-extent-endpoints previous-extent start end)
287         (setq previous-extent (make-extent start end buffer))
288
289         ;; Make the extent be closed on the right, which means that if
290         ;; characters are inserted exactly at the end of the extent, the
291         ;; extent will grow to cover them.  This is important for shell
292         ;; buffers - suppose one makes a selection, and one end is at
293         ;; point-max.  If the shell produces output, that marker will remain
294         ;; at point-max (its position will increase).  So it's important that
295         ;; the extent exhibit the same behavior, lest the region covered by
296         ;; the extent (the visual indication), and the region between point
297         ;; and mark (the actual selection value) become different!
298         (set-extent-property previous-extent 'end-open nil)
299
300         (cond
301          (mouse-track-rectangle-p
302           (setq previous-extent (list previous-extent))
303           (default-mouse-track-next-move-rect start end previous-extent)
304           ))
305         previous-extent))))
306
307 ;; moved from x-select.el
308 (defun valid-simple-selection-p (data)
309   (or (stringp data)
310       ;FSFmacs huh?? (symbolp data)
311       (integerp data)
312       (and (consp data)
313            (integerp (car data))
314            (or (integerp (cdr data))
315                (and (consp (cdr data))
316                     (integerp (car (cdr data))))))
317       (extentp data)
318       (and (consp data)
319            (markerp (car data))
320            (markerp (cdr data))
321            (marker-buffer (car data))
322            (marker-buffer (cdr data))
323            (eq (marker-buffer (car data))
324                (marker-buffer (cdr data)))
325            (buffer-live-p (marker-buffer (car data)))
326            (buffer-live-p (marker-buffer (cdr data))))))
327
328 (defun cut-copy-clear-internal (mode)
329   (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode))
330   (or (selection-owner-p)
331       (error "XEmacs does not own the primary selection"))
332   (setq last-command nil)
333   (or primary-selection-extent
334       (error "the primary selection is not an extent?"))
335   (save-excursion
336     (let (rect-p b s e)
337       (cond
338        ((consp primary-selection-extent)
339         (setq rect-p t
340               b (extent-object (car primary-selection-extent))
341               s (extent-start-position (car primary-selection-extent))
342               e (extent-end-position (car (reverse primary-selection-extent)))))
343        (t
344         (setq rect-p nil
345               b (extent-object primary-selection-extent)
346               s (extent-start-position primary-selection-extent)
347               e (extent-end-position primary-selection-extent))))
348       (set-buffer b)
349       (cond ((memq mode '(cut copy))
350              (if rect-p
351                  (progn
352                    ;; why is killed-rectangle free?  Is it used somewhere?
353                    ;; should it be defvarred?
354                    (setq killed-rectangle (extract-rectangle s e))
355                    (kill-new (mapconcat #'identity killed-rectangle "\n")))
356                (copy-region-as-kill s e))
357              ;; Maybe killing doesn't own clipboard.  Make sure it happens.
358              ;; This memq is kind of grody, because they might have done it
359              ;; some other way, but owning the clipboard twice in that case
360              ;; wouldn't actually hurt anything.
361              (or (and (consp kill-hooks) (memq 'own-clipboard kill-hooks))
362                  (own-clipboard (car kill-ring)))))
363       (cond ((memq mode '(cut clear))
364              (if rect-p
365                  (delete-rectangle s e)
366                (delete-region s e))))
367       (disown-selection nil)
368       )))
369
370 ;;; Functions to convert the selection into various other selection
371 ;;; types.  Every selection type that emacs handles is implemented
372 ;;; this way, except for TIMESTAMP, which is a special case. These are
373 ;;; all moved from x-select.el
374
375 (defun select-convert-to-text (selection type value)
376   (cond ((stringp value)
377          value)
378         ((extentp value)
379          (save-excursion
380            (set-buffer (extent-object value))
381            (save-restriction
382              (widen)
383              (buffer-substring (extent-start-position value)
384                                (extent-end-position value)))))
385         ((and (consp value)
386               (markerp (car value))
387               (markerp (cdr value)))
388          (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
389              (signal 'error
390                      (list "markers must be in the same buffer"
391                            (car value) (cdr value))))
392          (save-excursion
393            (set-buffer (or (marker-buffer (car value))
394                            (error "selection is in a killed buffer")))
395            (save-restriction
396              (widen)
397              (buffer-substring (car value) (cdr value)))))
398         (t nil)))
399
400 (defun select-convert-to-string (selection type value)
401   (let ((outval (select-convert-to-text selection type value)))
402     ;; force the string to be not in Compound Text format.
403     (if (stringp outval)
404         (cons 'STRING outval)
405       outval)))
406
407 (defun select-convert-to-compound-text (selection type value)
408   ;; converts to compound text automatically
409   (select-convert-to-text selection type value))
410
411 (defun select-convert-to-length (selection type value)
412   (let ((value
413          (cond ((stringp value)
414                 (length value))
415                ((extentp value)
416                 (extent-length value))
417                ((and (consp value)
418                      (markerp (car value))
419                      (markerp (cdr value)))
420                 (or (eq (marker-buffer (car value))
421                         (marker-buffer (cdr value)))
422                     (signal 'error
423                             (list "markers must be in the same buffer"
424                                   (car value) (cdr value))))
425                 (abs (- (car value) (cdr value)))))))
426     (if value ; force it to be in 32-bit format.
427         (cons (ash value -16) (logand value 65535))
428       nil)))
429
430 (defun select-convert-to-targets (selection type value)
431   ;; return a vector of atoms, but remove duplicates first.
432   (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
433          (rest all))
434     (while rest
435       (cond ((memq (car rest) (cdr rest))
436              (setcdr rest (delq (car rest) (cdr rest))))
437             ((eq (car (cdr rest)) '_EMACS_INTERNAL)  ; shh, it's a secret
438              (setcdr rest (cdr (cdr rest))))
439             (t
440              (setq rest (cdr rest)))))
441     (apply 'vector all)))
442
443 (defun select-convert-to-delete (selection type value)
444   (disown-selection-internal selection)
445   ;; A return value of nil means that we do not know how to do this conversion,
446   ;; and replies with an "error".  A return value of NULL means that we have
447   ;; done the conversion (and any side-effects) but have no value to return.
448   'NULL)
449
450 (defun select-convert-to-filename (selection type value)
451   (cond ((extentp value)
452          (buffer-file-name (or (extent-object value)
453                                (error "selection is in a killed buffer"))))
454         ((and (consp value)
455               (markerp (car value))
456               (markerp (cdr value)))
457          (buffer-file-name (or (marker-buffer (car value))
458                                (error "selection is in a killed buffer"))))
459         (t nil)))
460
461 (defun select-convert-to-charpos (selection type value)
462   (let (a b tmp)
463     (cond ((cond ((extentp value)
464                   (setq a (extent-start-position value)
465                         b (extent-end-position value)))
466                  ((and (consp value)
467                        (markerp (car value))
468                        (markerp (cdr value)))
469                   (setq a (car value)
470                         b (cdr value))))
471            (setq a (1- a) b (1- b)) ; zero-based
472            (if (< b a) (setq tmp a a b b tmp))
473            (cons 'SPAN
474                  (vector (cons (ash a -16) (logand a 65535))
475                          (cons (ash b -16) (logand b 65535))))))))
476
477 (defun select-convert-to-lineno (selection type value)
478   (let (a b buf tmp)
479     (cond ((cond ((extentp value)
480                   (setq buf (extent-object value)
481                         a (extent-start-position value)
482                         b (extent-end-position value)))
483                  ((and (consp value)
484                        (markerp (car value))
485                        (markerp (cdr value)))
486                   (setq a (marker-position (car value))
487                         b (marker-position (cdr value))
488                         buf (marker-buffer (car value)))))
489            (save-excursion
490              (set-buffer buf)
491              (save-restriction
492                (widen)
493                (goto-char a)
494                (beginning-of-line)
495                (setq a (1+ (count-lines 1 (point))))
496                (goto-char b)
497                (beginning-of-line)
498                (setq b (1+ (count-lines 1 (point))))))
499            (if (< b a) (setq tmp a a b b tmp))
500            (cons 'SPAN
501                  (vector (cons (ash a -16) (logand a 65535))
502                          (cons (ash b -16) (logand b 65535))))))))
503
504 (defun select-convert-to-colno (selection type value)
505   (let (a b buf tmp)
506     (cond ((cond ((extentp value)
507                   (setq buf (extent-object value)
508                         a (extent-start-position value)
509                         b (extent-end-position value)))
510                  ((and (consp value)
511                        (markerp (car value))
512                        (markerp (cdr value)))
513                   (setq a (car value)
514                         b (cdr value)
515                         buf (marker-buffer a))))
516            (save-excursion
517              (set-buffer buf)
518              (goto-char a)
519              (setq a (current-column))
520              (goto-char b)
521              (setq b (current-column)))
522            (if (< b a) (setq tmp a a b b tmp))
523            (cons 'SPAN
524                  (vector (cons (ash a -16) (logand a 65535))
525                          (cons (ash b -16) (logand b 65535))))))))
526
527 (defun select-convert-to-sourceloc (selection type value)
528   (let (a b buf file-name tmp)
529     (cond ((cond ((extentp value)
530                   (setq buf (or (extent-object value)
531                                 (error "selection is in a killed buffer"))
532                         a (extent-start-position value)
533                         b (extent-end-position value)
534                         file-name (buffer-file-name buf)))
535                  ((and (consp value)
536                        (markerp (car value))
537                        (markerp (cdr value)))
538                   (setq a (marker-position (car value))
539                         b (marker-position (cdr value))
540                         buf (or (marker-buffer (car value))
541                                 (error "selection is in a killed buffer"))
542                         file-name (buffer-file-name buf))))
543            (save-excursion
544              (set-buffer buf)
545              (save-restriction
546                (widen)
547                (goto-char a)
548                (beginning-of-line)
549                (setq a (1+ (count-lines 1 (point))))
550                (goto-char b)
551                (beginning-of-line)
552                (setq b (1+ (count-lines 1 (point))))))
553            (if (< b a) (setq tmp a a b b tmp))
554            (format "%s:%d" file-name a)))))
555
556 (defun select-convert-to-os (selection type size)
557   (symbol-name system-type))
558
559 (defun select-convert-to-host (selection type size)
560   (system-name))
561
562 (defun select-convert-to-user (selection type size)
563   (user-full-name))
564
565 (defun select-convert-to-class (selection type size)
566   x-emacs-application-class)
567
568 ;; We do not try to determine the name Emacs was invoked with,
569 ;; because it is not clean for a program's behavior to depend on that.
570 (defun select-convert-to-name (selection type size)
571   ;invocation-name
572   "xemacs")
573
574 (defun select-convert-to-integer (selection type value)
575   (and (integerp value)
576        (cons (ash value -16) (logand value 65535))))
577
578 (defun select-convert-to-atom (selection type value)
579   (and (symbolp value) value))
580
581 (defun select-convert-to-identity (selection type value) ; used internally
582   (vector value))
583
584 (setq selection-converter-alist
585       '((TEXT . select-convert-to-text)
586         (STRING . select-convert-to-string)
587         (COMPOUND_TEXT . select-convert-to-compound-text)
588         (TARGETS . select-convert-to-targets)
589         (LENGTH . select-convert-to-length)
590         (DELETE . select-convert-to-delete)
591         (FILE_NAME . select-convert-to-filename)
592         (CHARACTER_POSITION . select-convert-to-charpos)
593         (SOURCE_LOC . select-convert-to-sourceloc)
594         (LINE_NUMBER . select-convert-to-lineno)
595         (COLUMN_NUMBER . select-convert-to-colno)
596         (OWNER_OS . select-convert-to-os)
597         (HOST_NAME . select-convert-to-host)
598         (USER . select-convert-to-user)
599         (CLASS . select-convert-to-class)
600         (NAME . select-convert-to-name)
601         (ATOM . select-convert-to-atom)
602         (INTEGER . select-convert-to-integer)
603         (_EMACS_INTERNAL . select-convert-to-identity)
604         ))
605
606 ;;; select.el ends here