Mercurial > hg > xemacs-beta

comparison lisp/select.el @ 414:da8ed4261e83 r21-2-15

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-15
author cvs
date Mon, 13 Aug 2007 11:21:38 +0200
parents 697ef44129c6
children ebe98a74bd68
comparison
equal deleted inserted replaced
413:901169e5ca31 414:da8ed4261e83
29 ;;; Commentary: 29 ;;; Commentary:
30 30
31 ;; This file is dumped with XEmacs 31 ;; This file is dumped with XEmacs
32 32
33 ;;; Code: 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.")
34 42
35 (defun copy-primary-selection () 43 (defun copy-primary-selection ()
36 "Copy the selection to the Clipboard and the kill ring." 44 "Copy the selection to the Clipboard and the kill ring."
37 (interactive) 45 (interactive)
38 (and (console-on-window-system-p) 46 (and (console-on-window-system-p)
39 (cut-copy-clear-internal 'copy))) 47 (cut-copy-clear-internal 'copy)))
40 (define-obsolete-function-alias
41 'x-copy-primary-selection
42 'copy-primary-selection)
43 48
44 (defun kill-primary-selection () 49 (defun kill-primary-selection ()
45 "Copy the selection to the Clipboard and the kill ring, then delete it." 50 "Copy the selection to the Clipboard and the kill ring, then delete it."
46 (interactive "*") 51 (interactive "*")
47 (and (console-on-window-system-p) 52 (and (console-on-window-system-p)
48 (cut-copy-clear-internal 'cut))) 53 (cut-copy-clear-internal 'cut)))
49 (define-obsolete-function-alias
50 'x-kill-primary-selection
51 'kill-primary-selection)
52 54
53 (defun delete-primary-selection () 55 (defun delete-primary-selection ()
54 "Delete the selection without copying it to the Clipboard or the kill ring." 56 "Delete the selection without copying it to the Clipboard or the kill ring."
55 (interactive "*") 57 (interactive "*")
56 (and (console-on-window-system-p) 58 (and (console-on-window-system-p)
57 (cut-copy-clear-internal 'clear))) 59 (cut-copy-clear-internal 'clear)))
58 (define-obsolete-function-alias
59 'x-delete-primary-selection
60 'delete-primary-selection)
61 60
62 (defun yank-clipboard-selection () 61 (defun yank-clipboard-selection ()
63 "Insert the current Clipboard selection at point." 62 "Insert the current Clipboard selection at point."
64 (interactive "*") 63 (interactive "*")
65 (case (device-type (selected-device)) 64 (case (device-type (selected-device))
66 (x (x-yank-clipboard-selection)) 65 (x (x-yank-clipboard-selection))
67 (mswindows (mswindows-paste-clipboard)) 66 (mswindows (mswindows-paste-clipboard))
68 (otherwise nil))) 67 (otherwise nil)))
69 68
70 (defun selection-owner-p (&optional selection) 69 (define-device-method get-cutbuffer
71 "Return t if current XEmacs process owns the given Selection. 70 "Return the value of one of the cut buffers.
72 The arg should be the name of the selection in question, typically one 71 This will do nothing under anything other than X.")
73 of the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience, 72
74 the symbol nil is the same as PRIMARY, and t is the same as 73 (defun get-selection (&optional type data-type)
75 SECONDARY.)" 74 "Return the value of a Windows selection.
76 (interactive) 75 The argument TYPE (default `PRIMARY') says which selection,
77 (case (device-type (selected-device)) 76 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
78 (x (x-selection-owner-p selection)) 77 says how to convert the data."
79 (mswindows (mswindows-selection-owner-p selection)) 78 (or type (setq type 'PRIMARY))
80 (otherwise nil))) 79 (or data-type (setq data-type selected-text-type))
81 80 (let ((text
82 (defun selection-exists-p (&optional selection) 81 (if (consp data-type)
83 "Whether there is an owner for the given Selection. 82 (condition-case err
84 The arg should be the name of the selection in question, typically one 83 (get-selection-internal type (car data-type))
85 of the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience, 84 (selection-conversion-error
86 the symbol nil is the same as PRIMARY, and t is the same as 85 (if (cdr data-type)
87 SECONDARY." 86 (get-selection type (cdr data-type))
88 (interactive) 87 (signal (car err) (cdr err)))))
89 (case (device-type (selected-device)) 88 (get-selection-internal type data-type))))
90 (x (x-selection-exists-p selection)) 89 (when (and (consp text) (symbolp (car text)))
91 (mswindows (mswindows-selection-exists-p)) 90 (setq text (cdr text)))
92 (otherwise nil))) 91 (when (not (stringp text))
93 92 (error "Selection is not a string: %S" text))
93 text))
94
95 ;; FSFmacs calls this `x-set-selection', and reverses the
96 ;; arguments (duh ...). This order is more logical.
94 (defun own-selection (data &optional type) 97 (defun own-selection (data &optional type)
95 "Make an Windows selection of type TYPE and value DATA. 98 "Make an Windows selection of type TYPE and value DATA.
96 The argument TYPE (default `PRIMARY') says which selection, 99 The argument TYPE (default `PRIMARY') says which selection,
97 and DATA specifies the contents. DATA may be a string, 100 and DATA specifies the contents. DATA may be a string,
98 a symbol, an integer (or a cons of two integers or list of two integers). 101 a symbol, an integer (or a cons of two integers or list of two integers).
107 110
108 Interactively, the text of the region is used as the selection value." 111 Interactively, the text of the region is used as the selection value."
109 (interactive (if (not current-prefix-arg) 112 (interactive (if (not current-prefix-arg)
110 (list (read-string "Store text for pasting: ")) 113 (list (read-string "Store text for pasting: "))
111 (list (substring (region-beginning) (region-end))))) 114 (list (substring (region-beginning) (region-end)))))
112 (case (device-type (selected-device)) 115 ;FSFmacs huh?? It says:
113 (x (x-own-selection data type)) 116 ;; "This is for temporary compatibility with pre-release Emacs 19."
114 (mswindows (mswindows-own-selection data type)) 117 ;(if (stringp type)
115 (otherwise nil))) 118 ; (setq type (intern type)))
119 (or (valid-simple-selection-p data)
120 (and (vectorp data)
121 (let ((valid t)
122 (i (1- (length data))))
123 (while (>= i 0)
124 (or (valid-simple-selection-p (aref data i))
125 (setq valid nil))
126 (setq i (1- i)))
127 valid))
128 (signal 'error (list "invalid selection" data)))
129 (or type (setq type 'PRIMARY))
130 (if data
131 (own-selection-internal type data)
132 (disown-selection-internal type))
133 (cond ((eq type 'PRIMARY)
134 (setq primary-selection-extent
135 (select-make-extent-for-selection
136 data primary-selection-extent)))
137 ((eq type 'SECONDARY)
138 (setq secondary-selection-extent
139 (select-make-extent-for-selection
140 data secondary-selection-extent))))
141 (setq zmacs-region-stays t)
142 data)
143
144 (defun dehilight-selection (selection)
145 "for use as a value of `lost-selection-hooks'."
146 (cond ((eq selection 'PRIMARY)
147 (if primary-selection-extent
148 (let ((inhibit-quit t))
149 (if (consp primary-selection-extent)
150 (mapcar 'delete-extent primary-selection-extent)
151 (delete-extent primary-selection-extent))
152 (setq primary-selection-extent nil)))
153 (if zmacs-regions (zmacs-deactivate-region)))
154 ((eq selection 'SECONDARY)
155 (if secondary-selection-extent
156 (let ((inhibit-quit t))
157 (if (consp secondary-selection-extent)
158 (mapcar 'delete-extent secondary-selection-extent)
159 (delete-extent secondary-selection-extent))
160 (setq secondary-selection-extent nil)))))
161 nil)
162
163 (setq lost-selection-hooks 'dehilight-selection)
116 164
117 (defun own-clipboard (string) 165 (defun own-clipboard (string)
118 "Paste the given string to the Clipboard." 166 "Paste the given string to the X Clipboard."
119 (case (device-type (selected-device)) 167 (own-selection string 'CLIPBOARD))
120 (x (x-own-clipboard string))
121 (mswindows (mswindows-own-clipboard string))
122 (otherwise nil)))
123 168
124 (defun disown-selection (&optional secondary-p) 169 (defun disown-selection (&optional secondary-p)
125 "Assuming we own the selection, disown it. With an argument, discard the 170 "Assuming we own the selection, disown it. With an argument, discard the
126 secondary selection instead of the primary selection." 171 secondary selection instead of the primary selection."
127 (case (device-type (selected-device)) 172 (disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
128 (x (x-disown-selection secondary-p))
129 (mswindows (mswindows-disown-selection secondary-p))
130 (otherwise nil)))
131
132 173
133 ;; from x-init.el 174 ;; from x-init.el
134 ;; selections and active regions 175 ;; selections and active regions
135 176
136 ;; If and only if zmacs-regions is true: 177 ;; If and only if zmacs-regions is true:
216 (mouse-track-rectangle-p 257 (mouse-track-rectangle-p
217 (setq previous-extent (list previous-extent)) 258 (setq previous-extent (list previous-extent))
218 (default-mouse-track-next-move-rect start end previous-extent) 259 (default-mouse-track-next-move-rect start end previous-extent)
219 )) 260 ))
220 previous-extent)))) 261 previous-extent))))
221 (define-obsolete-function-alias
222 'x-select-make-extent-for-selection
223 'select-make-extent-for-selection)
224 262
225 ;; moved from x-select.el 263 ;; moved from x-select.el
226 (defun valid-simple-selection-p (data) 264 (defun valid-simple-selection-p (data)
227 (or (stringp data) 265 (or (stringp data)
228 ;FSFmacs huh?? (symbolp data) 266 ;FSFmacs huh?? (symbolp data)
240 (marker-buffer (cdr data)) 278 (marker-buffer (cdr data))
241 (eq (marker-buffer (car data)) 279 (eq (marker-buffer (car data))
242 (marker-buffer (cdr data))) 280 (marker-buffer (cdr data)))
243 (buffer-live-p (marker-buffer (car data))) 281 (buffer-live-p (marker-buffer (car data)))
244 (buffer-live-p (marker-buffer (cdr data)))))) 282 (buffer-live-p (marker-buffer (cdr data))))))
245 (define-obsolete-function-alias
246 'x-valid-simple-selection-p
247 'valid-simple-selection-p)
248 283
249 (defun cut-copy-clear-internal (mode) 284 (defun cut-copy-clear-internal (mode)
250 (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode)) 285 (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode))
251 (or (selection-owner-p) 286 (or (selection-owner-p)
252 (error "XEmacs does not own the primary selection")) 287 (error "XEmacs does not own the primary selection"))
285 (if rect-p 320 (if rect-p
286 (delete-rectangle s e) 321 (delete-rectangle s e)
287 (delete-region s e)))) 322 (delete-region s e))))
288 (disown-selection nil) 323 (disown-selection nil)
289 ))) 324 )))
290 (define-obsolete-function-alias 325
291 'x-cut-copy-clear-internal 326 ;;; Functions to convert the selection into various other selection
292 'cut-copy-clear-internal) 327 ;;; types. Every selection type that emacs handles is implemented
328 ;;; this way, except for TIMESTAMP, which is a special case. These are
329 ;;; all moved from x-select.el
330
331 (defun select-convert-to-text (selection type value)
332 (cond ((stringp value)
333 value)
334 ((extentp value)
335 (save-excursion
336 (set-buffer (extent-object value))
337 (save-restriction
338 (widen)
339 (buffer-substring (extent-start-position value)
340 (extent-end-position value)))))
341 ((and (consp value)
342 (markerp (car value))
343 (markerp (cdr value)))
344 (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
345 (signal 'error
346 (list "markers must be in the same buffer"
347 (car value) (cdr value))))
348 (save-excursion
349 (set-buffer (or (marker-buffer (car value))
350 (error "selection is in a killed buffer")))
351 (save-restriction
352 (widen)
353 (buffer-substring (car value) (cdr value)))))
354 (t nil)))
355
356 (defun select-convert-to-string (selection type value)
357 (let ((outval (select-convert-to-text selection type value)))
358 ;; force the string to be not in Compound Text format.
359 (if (stringp outval)
360 (cons 'STRING outval)
361 outval)))
362
363 (defun select-convert-to-compound-text (selection type value)
364 ;; converts to compound text automatically
365 (select-convert-to-text selection type value))
366
367 (defun select-convert-to-length (selection type value)
368 (let ((value
369 (cond ((stringp value)
370 (length value))
371 ((extentp value)
372 (extent-length value))
373 ((and (consp value)
374 (markerp (car value))
375 (markerp (cdr value)))
376 (or (eq (marker-buffer (car value))
377 (marker-buffer (cdr value)))
378 (signal 'error
379 (list "markers must be in the same buffer"
380 (car value) (cdr value))))
381 (abs (- (car value) (cdr value)))))))
382 (if value ; force it to be in 32-bit format.
383 (cons (ash value -16) (logand value 65535))
384 nil)))
385
386 (defun select-convert-to-targets (selection type value)
387 ;; return a vector of atoms, but remove duplicates first.
388 (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
389 (rest all))
390 (while rest
391 (cond ((memq (car rest) (cdr rest))
392 (setcdr rest (delq (car rest) (cdr rest))))
393 ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret
394 (setcdr rest (cdr (cdr rest))))
395 (t
396 (setq rest (cdr rest)))))
397 (apply 'vector all)))
398
399 (defun select-convert-to-delete (selection type value)
400 (disown-selection-internal selection)
401 ;; A return value of nil means that we do not know how to do this conversion,
402 ;; and replies with an "error". A return value of NULL means that we have
403 ;; done the conversion (and any side-effects) but have no value to return.
404 'NULL)
405
406 (defun select-convert-to-filename (selection type value)
407 (cond ((extentp value)
408 (buffer-file-name (or (extent-object value)
409 (error "selection is in a killed buffer"))))
410 ((and (consp value)
411 (markerp (car value))
412 (markerp (cdr value)))
413 (buffer-file-name (or (marker-buffer (car value))
414 (error "selection is in a killed buffer"))))
415 (t nil)))
416
417 (defun select-convert-to-charpos (selection type value)
418 (let (a b tmp)
419 (cond ((cond ((extentp value)
420 (setq a (extent-start-position value)
421 b (extent-end-position value)))
422 ((and (consp value)
423 (markerp (car value))
424 (markerp (cdr value)))
425 (setq a (car value)
426 b (cdr value))))
427 (setq a (1- a) b (1- b)) ; zero-based
428 (if (< b a) (setq tmp a a b b tmp))
429 (cons 'SPAN
430 (vector (cons (ash a -16) (logand a 65535))
431 (cons (ash b -16) (logand b 65535))))))))
432
433 (defun select-convert-to-lineno (selection type value)
434 (let (a b buf tmp)
435 (cond ((cond ((extentp value)
436 (setq buf (extent-object value)
437 a (extent-start-position value)
438 b (extent-end-position value)))
439 ((and (consp value)
440 (markerp (car value))
441 (markerp (cdr value)))
442 (setq a (marker-position (car value))
443 b (marker-position (cdr value))
444 buf (marker-buffer (car value)))))
445 (save-excursion
446 (set-buffer buf)
447 (save-restriction
448 (widen)
449 (goto-char a)
450 (beginning-of-line)
451 (setq a (1+ (count-lines 1 (point))))
452 (goto-char b)
453 (beginning-of-line)
454 (setq b (1+ (count-lines 1 (point))))))
455 (if (< b a) (setq tmp a a b b tmp))
456 (cons 'SPAN
457 (vector (cons (ash a -16) (logand a 65535))
458 (cons (ash b -16) (logand b 65535))))))))
459
460 (defun select-convert-to-colno (selection type value)
461 (let (a b buf tmp)
462 (cond ((cond ((extentp value)
463 (setq buf (extent-object value)
464 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 buf (marker-buffer a))))
472 (save-excursion
473 (set-buffer buf)
474 (goto-char a)
475 (setq a (current-column))
476 (goto-char b)
477 (setq b (current-column)))
478 (if (< b a) (setq tmp a a b b tmp))
479 (cons 'SPAN
480 (vector (cons (ash a -16) (logand a 65535))
481 (cons (ash b -16) (logand b 65535))))))))
482
483 (defun select-convert-to-sourceloc (selection type value)
484 (let (a b buf file-name tmp)
485 (cond ((cond ((extentp value)
486 (setq buf (or (extent-object value)
487 (error "selection is in a killed buffer"))
488 a (extent-start-position value)
489 b (extent-end-position value)
490 file-name (buffer-file-name buf)))
491 ((and (consp value)
492 (markerp (car value))
493 (markerp (cdr value)))
494 (setq a (marker-position (car value))
495 b (marker-position (cdr value))
496 buf (or (marker-buffer (car value))
497 (error "selection is in a killed buffer"))
498 file-name (buffer-file-name buf))))
499 (save-excursion
500 (set-buffer buf)
501 (save-restriction
502 (widen)
503 (goto-char a)
504 (beginning-of-line)
505 (setq a (1+ (count-lines 1 (point))))
506 (goto-char b)
507 (beginning-of-line)
508 (setq b (1+ (count-lines 1 (point))))))
509 (if (< b a) (setq tmp a a b b tmp))
510 (format "%s:%d" file-name a)))))
511
512 (defun select-convert-to-os (selection type size)
513 (symbol-name system-type))
514
515 (defun select-convert-to-host (selection type size)
516 (system-name))
517
518 (defun select-convert-to-user (selection type size)
519 (user-full-name))
520
521 (defun select-convert-to-class (selection type size)
522 x-emacs-application-class)
523
524 ;; We do not try to determine the name Emacs was invoked with,
525 ;; because it is not clean for a program's behavior to depend on that.
526 (defun select-convert-to-name (selection type size)
527 ;invocation-name
528 "xemacs")
529
530 (defun select-convert-to-integer (selection type value)
531 (and (integerp value)
532 (cons (ash value -16) (logand value 65535))))
533
534 (defun select-convert-to-atom (selection type value)
535 (and (symbolp value) value))
536
537 (defun select-convert-to-identity (selection type value) ; used internally
538 (vector value))
539
540 (setq selection-converter-alist
541 '((TEXT . select-convert-to-text)
542 (STRING . select-convert-to-string)
543 (COMPOUND_TEXT . select-convert-to-compound-text)
544 (TARGETS . select-convert-to-targets)
545 (LENGTH . select-convert-to-length)
546 (DELETE . select-convert-to-delete)
547 (FILE_NAME . select-convert-to-filename)
548 (CHARACTER_POSITION . select-convert-to-charpos)
549 (SOURCE_LOC . select-convert-to-sourceloc)
550 (LINE_NUMBER . select-convert-to-lineno)
551 (COLUMN_NUMBER . select-convert-to-colno)
552 (OWNER_OS . select-convert-to-os)
553 (HOST_NAME . select-convert-to-host)
554 (USER . select-convert-to-user)
555 (CLASS . select-convert-to-class)
556 (NAME . select-convert-to-name)
557 (ATOM . select-convert-to-atom)
558 (INTEGER . select-convert-to-integer)
559 (_EMACS_INTERNAL . select-convert-to-identity)
560 ))
293 561
294 ;;; select.el ends here 562 ;;; select.el ends here