Mercurial > hg > xemacs-beta
annotate lisp/select.el @ 5576:071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
lisp/ChangeLog addition:
2011-10-03 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (handle-pre-motion-command-current-command-is-motion):
Implement #'keysyms-equal with #'labels + (declare (inline ...)),
instead of abusing macrolet to the same end.
* specifier.el (let-specifier):
* mule/mule-cmds.el (describe-language-environment):
* mule/mule-cmds.el (set-language-environment-coding-systems):
* mule/mule-x-init.el (x-use-halfwidth-roman-font):
* faces.el (Face-frob-property):
* keymap.el (key-sequence-list-description):
* lisp-mode.el (construct-lisp-mode-menu):
* loadhist.el (unload-feature):
* mouse.el (default-mouse-track-check-for-activation):
Declare various labels inline in dumped files when that reduces
the size of the dumped image. Declaring labels inline is normally
only worthwhile for inner loops and so on, but it's reasonable
exercise of the related code to have these changes in core.
tests/ChangeLog addition:
2011-10-03 Aidan Kehoe <kehoea@parhasard.net>
* automated/case-tests.el (uni-mappings):
* automated/database-tests.el (delete-database-files):
* automated/hash-table-tests.el (iterations):
* automated/lisp-tests.el (test1):
* automated/lisp-tests.el (a):
* automated/lisp-tests.el (cl-floor):
* automated/lisp-tests.el (foo):
* automated/lisp-tests.el (list-nreverse):
* automated/lisp-tests.el (needs-lexical-context):
* automated/mule-tests.el (featurep):
* automated/os-tests.el (original-string):
* automated/os-tests.el (with):
* automated/symbol-tests.el (check-weak-list-unique):
Replace #'flet with #'labels where appropriate in these tests,
following my own advice on style in the docstrings of those
functions.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 03 Oct 2011 20:16:14 +0100 |
| parents | 5273dd66a1ba |
| children | cc1ec4c93a67 |
| rev | line source |
|---|---|
| 428 | 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. | |
| 851 | 6 ;; Copyright (C) 2002 Ben Wing. |
| 428 | 7 |
| 8 ;; Maintainer: XEmacs Development Team | |
| 9 ;; Keywords: extensions, dumped | |
| 10 | |
| 11 ;; This file is part of XEmacs. | |
| 12 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4783
diff
changeset
|
13 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4783
diff
changeset
|
14 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4783
diff
changeset
|
15 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4783
diff
changeset
|
16 ;; option) any later version. |
| 428 | 17 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4783
diff
changeset
|
18 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4783
diff
changeset
|
19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4783
diff
changeset
|
20 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4783
diff
changeset
|
21 ;; for more details. |
| 428 | 22 |
| 23 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4783
diff
changeset
|
24 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 25 |
| 26 ;;; Synched up with: Not in FSF | |
| 27 | |
| 28 ;;; Commentary: | |
| 29 | |
| 444 | 30 ;; This file is dumped with XEmacs |
| 428 | 31 |
| 32 ;;; Code: | |
| 33 | |
| 2624 | 34 ;; We prefer UTF8_STRING to COMPOUND_TEXT because, even though the latter |
| 35 ;; gives us more information when taking data from other XEmacs invocations, | |
| 36 ;; Mozilla will happily give us broken COMPOUND_TEXT where a non-broken | |
| 37 ;; UTF8_STRING is available. | |
| 38 (defvar selection-preferred-types | |
|
5364
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
39 `(UTF8_STRING ,@(and (featurep 'mule) '(COMPOUND_TEXT)) STRING |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
40 ,@(mapcan #'(lambda (format) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
41 (and (featurep format) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
42 (list (intern (format "image/%s" format))))) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
43 '(png gif jpeg tiff xpm xbm))) |
| 2624 | 44 "An ordered list of X11 type atoms for selections we want to receive. |
| 45 We prefer UTF8_STRING over COMPOUND_TEXT, for compatibility with a certain | |
| 46 widely-used browser suite, and COMPOUND_TEXT over STRING. (COMPOUND_TEXT | |
| 47 isn't available on non-Mule.) We also accept several image types. | |
| 48 | |
| 49 For compatibility, this can be a single atom. ") | |
| 50 | |
| 51 ;; Renamed because it was just ridiculous for it to be mostly image formats | |
| 52 ;; and named selected-text-type. | |
| 53 (define-obsolete-variable-alias 'selected-text-type 'selection-preferred-types) | |
| 428 | 54 |
| 444 | 55 (defvar selection-sets-clipboard nil |
| 428 | 56 "Controls the selection's relationship to the clipboard. |
| 57 When non-nil, any operation that sets the primary selection will also | |
| 58 set the clipboard.") | |
| 59 | |
| 60 (defun copy-primary-selection () | |
| 851 | 61 "Copy the selection to the Clipboard and the kill ring. |
| 62 This is similar to the command \\[kill-ring-save] except that it will | |
| 63 save to the Clipboard even if that command doesn't, and it handles rectangles | |
| 64 properly." | |
| 428 | 65 (interactive) |
| 66 (and (console-on-window-system-p) | |
| 67 (cut-copy-clear-internal 'copy))) | |
| 68 | |
| 69 (defun kill-primary-selection () | |
| 2624 | 70 "Copy the selection to the Clipboard and the kill ring, then delete it. |
| 851 | 71 This is similar to the command \\[kill-region] except that it will |
| 72 save to the Clipboard even if that command doesn't, and it handles rectangles | |
| 73 properly." | |
| 428 | 74 (interactive "*") |
| 75 (and (console-on-window-system-p) | |
| 76 (cut-copy-clear-internal 'cut))) | |
| 77 | |
| 78 (defun delete-primary-selection () | |
| 79 "Delete the selection without copying it to the Clipboard or the kill ring." | |
| 80 (interactive "*") | |
| 81 (and (console-on-window-system-p) | |
| 82 (cut-copy-clear-internal 'clear))) | |
| 83 | |
| 84 (defun yank-clipboard-selection () | |
| 85 "Insert the current Clipboard selection at point." | |
| 86 (interactive "*") | |
| 87 (when (console-on-window-system-p) | |
| 88 (setq last-command nil) | |
| 89 (setq this-command 'yank) ; so that yank-pop works. | |
| 90 (let ((clip (get-clipboard))) | |
| 91 (or clip (error "there is no clipboard selection")) | |
| 92 (push-mark) | |
| 93 (insert clip)))) | |
| 94 | |
| 95 (defun get-clipboard () | |
| 829 | 96 "Return text pasted to the clipboard. |
| 843 | 97 Not suitable for `interprogram-paste-function', use `get-clipboard-foreign'." |
| 98 (get-selection 'CLIPBOARD)) | |
| 99 | |
| 100 (defun get-clipboard-foreign () | |
| 101 "Return text pasted to the clipboard by another program. | |
| 829 | 102 See `interprogram-paste-function' for more information." |
| 843 | 103 (get-selection-foreign 'CLIPBOARD)) |
| 428 | 104 |
| 105 (define-device-method get-cutbuffer | |
| 106 "Return the value of one of the cut buffers. | |
| 107 This will do nothing under anything other than X.") | |
| 108 | |
| 109 (defun get-selection-no-error (&optional type data-type) | |
| 442 | 110 "Return the value of a window-system selection. |
| 2624 | 111 The argument TYPE (default `PRIMARY') says which selection, and the argument |
| 112 DATA-TYPE (defaulting to the value of `selection-preferred-types'), says how | |
| 113 to convert the data. Returns NIL if there is no selection." | |
| 442 | 114 (condition-case nil (get-selection type data-type) (t nil))) |
| 428 | 115 |
| 116 (defun get-selection (&optional type data-type) | |
| 843 | 117 "Return the value of a window-system selection. |
| 2624 | 118 The argument TYPE (default `PRIMARY') says which selection, and the argument |
| 119 DATA-TYPE (defaulting to the value of, and compatible with, | |
| 120 `selection-preferred-types') says how to convert the data. If | |
| 121 there is no selection an error is signalled. Not suitable in a | |
| 122 `interprogram-paste-function', q.v." | |
| 428 | 123 (or type (setq type 'PRIMARY)) |
| 2624 | 124 (or data-type (setq data-type selection-preferred-types)) |
| 829 | 125 (if (consp data-type) |
| 2624 | 126 ;; TARGETS is a vector; we want a list so we can memq --> append it to |
| 127 ;; nil. | |
| 128 (let ((targets (append (get-selection-internal type 'TARGETS) nil)) | |
| 129 res) | |
| 130 (catch 'converted | |
| 131 (if targets | |
| 132 (dolist (current-preference data-type) | |
| 3072 | 133 (condition-case nil |
| 2624 | 134 (if (and (memq current-preference targets) |
| 135 (setq res (get-selection-internal | |
| 136 type current-preference))) | |
| 137 (throw 'converted res)) | |
| 138 (selection-conversion-error | |
| 139 nil)))) | |
| 140 ;; The source app didn't offer us anything compatible in TARGETS, | |
| 141 ;; or they're not negotiating at all. (That is, we're probably not | |
| 142 ;; on X11.) Try to convert to the types specified by our caller, | |
| 143 ;; and throw an error if the last one of those fails. | |
| 144 (while data-type | |
| 145 (condition-case err | |
| 146 (progn | |
| 147 (setq res (get-selection-internal type (car data-type))) | |
| 2656 | 148 (if res (throw 'converted res) |
| 149 (signal 'selection-conversion-error nil))) | |
| 2624 | 150 (selection-conversion-error |
| 151 (if (cdr data-type) | |
| 2656 | 152 (setq data-type (cdr data-type)) |
| 2624 | 153 (signal (car err) (cdr err)))))))) |
| 829 | 154 (get-selection-internal type data-type))) |
| 428 | 155 |
| 847 | 156 (defun get-selection-foreign (&optional type data-type) |
| 157 "Return the value of a window-system selection, or nil if XEmacs owns it. | |
| 2624 | 158 The argument TYPE (default `PRIMARY') says which selection, and the argument |
| 159 DATA-TYPE (defaulting to the value of `selection-preferred-types' which see) | |
| 160 says how to convert the data. If there is no selection an error is | |
| 161 signalled. See `interprogram-paste-function' for more information." | |
| 847 | 162 (unless (selection-owner-p type) |
| 163 (get-selection type data-type))) | |
| 164 | |
| 428 | 165 ;; FSFmacs calls this `x-set-selection', and reverses the |
| 442 | 166 ;; first two arguments (duh ...). This order is more logical. |
| 167 (defun own-selection (data &optional type how-to-add data-type) | |
| 168 "Make a window-system selection of type TYPE and value DATA. | |
| 428 | 169 The argument TYPE (default `PRIMARY') says which selection, |
| 442 | 170 and DATA specifies the contents. DATA may be any lisp data type |
| 171 that can be converted using the function corresponding to DATA-TYPE | |
| 172 in `select-converter-alist'---strings are the usual choice, but | |
| 173 other types may be permissible depending on the DATA-TYPE parameter | |
| 851 | 174 \(if DATA-TYPE is not supplied, the default behavior is window |
| 442 | 175 system specific, but strings are always accepted). |
| 176 HOW-TO-ADD may be any of the following: | |
| 177 | |
| 178 'replace-all or nil -- replace all data in the selection. | |
| 179 'replace-existing -- replace data for specified DATA-TYPE only. | |
| 180 'append or t -- append data to existing DATA-TYPE data. | |
| 181 | |
| 182 DATA-TYPE is the window-system specific data type identifier | |
| 851 | 183 \(see `register-selection-data-type' for more information). |
| 428 | 184 |
| 185 The selection may also be a cons of two markers pointing to the same buffer, | |
| 186 or an overlay. In these cases, the selection is considered to be the text | |
| 442 | 187 between the markers *at whatever time the selection is examined* (note |
| 188 that the window system clipboard does not necessarily duplicate this | |
| 189 behavior - it doesn't on mswindows for example). | |
| 428 | 190 Thus, editing done in the buffer after you specify the selection |
| 191 can alter the effective value of the selection. | |
| 192 | |
| 193 The data may also be a vector of valid non-vector selection values. | |
| 194 | |
| 195 Interactively, the text of the region is used as the selection value." | |
| 196 (interactive (if (not current-prefix-arg) | |
| 197 (list (read-string "Store text for pasting: ")) | |
| 198 (list (substring (region-beginning) (region-end))))) | |
| 442 | 199 ;; calling own-selection-internal will mess this up, so preserve it. |
| 200 (let ((zmacs-region-stays zmacs-region-stays)) | |
| 201 ;FSFmacs huh?? It says: | |
| 202 ;; "This is for temporary compatibility with pre-release Emacs 19." | |
| 203 ;(if (stringp type) | |
| 204 ; (setq type (intern type))) | |
| 205 (or type (setq type 'PRIMARY)) | |
| 206 (if (null data) | |
| 207 (disown-selection-internal type) | |
| 208 (own-selection-internal type data how-to-add data-type) | |
| 209 (when (and (eq type 'PRIMARY) | |
| 210 selection-sets-clipboard) | |
| 211 (own-selection-internal 'CLIPBOARD data how-to-add data-type))) | |
| 212 (cond ((eq type 'PRIMARY) | |
| 213 (setq primary-selection-extent | |
| 214 (select-make-extent-for-selection | |
| 215 data primary-selection-extent))) | |
| 216 ((eq type 'SECONDARY) | |
| 217 (setq secondary-selection-extent | |
| 218 (select-make-extent-for-selection | |
| 219 data secondary-selection-extent))))) | |
| 220 ;; zmacs-region-stays is for commands, not low-level functions. | |
| 221 ;; when behaving as the latter, we better not set it, or we will | |
| 222 ;; cause unwanted sticky-region behavior in kill-region and friends. | |
| 223 (if (interactive-p) | |
| 224 (setq zmacs-region-stays t)) | |
| 428 | 225 data) |
| 226 | |
| 227 (defun dehilight-selection (selection) | |
| 228 "for use as a value of `lost-selection-hooks'." | |
| 229 (cond ((eq selection 'PRIMARY) | |
| 230 (if primary-selection-extent | |
| 231 (let ((inhibit-quit t)) | |
| 232 (if (consp primary-selection-extent) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
233 (mapc 'delete-extent primary-selection-extent) |
| 428 | 234 (delete-extent primary-selection-extent)) |
| 235 (setq primary-selection-extent nil))) | |
| 236 (if zmacs-regions (zmacs-deactivate-region))) | |
| 237 ((eq selection 'SECONDARY) | |
| 238 (if secondary-selection-extent | |
| 239 (let ((inhibit-quit t)) | |
| 240 (if (consp secondary-selection-extent) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
241 (mapc 'delete-extent secondary-selection-extent) |
| 428 | 242 (delete-extent secondary-selection-extent)) |
| 243 (setq secondary-selection-extent nil))))) | |
| 244 nil) | |
| 245 | |
| 246 (setq lost-selection-hooks 'dehilight-selection) | |
| 247 | |
| 442 | 248 (defun own-clipboard (string &optional push) |
| 249 "Paste the given string to the window system Clipboard. | |
| 250 See `interprogram-cut-function' for more information." | |
| 428 | 251 (own-selection string 'CLIPBOARD)) |
| 252 | |
| 253 (defun disown-selection (&optional secondary-p) | |
| 487 | 254 "Assuming we own the selection, disown it. |
| 255 With an argument, discard the secondary selection instead of the | |
| 256 primary selection." | |
| 428 | 257 (disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)) |
| 258 (when (and selection-sets-clipboard | |
| 259 (or (not secondary-p) | |
| 260 (eq secondary-p 'PRIMARY) | |
| 261 (eq secondary-p 'CLIPBOARD))) | |
| 262 (disown-selection-internal 'CLIPBOARD))) | |
| 263 | |
| 264 ;; selections and active regions | |
| 265 | |
| 266 ;; If and only if zmacs-regions is true: | |
| 267 | |
| 268 ;; When a mark is pushed and the region goes into the "active" state, we | |
| 269 ;; assert it as the Primary selection. This causes it to be hilighted. | |
| 270 ;; When the region goes into the "inactive" state, we disown the Primary | |
| 271 ;; selection, causing the region to be dehilighted. | |
| 272 | |
| 273 ;; Note that it is possible for the region to be in the "active" state | |
| 274 ;; and not be hilighted, if it is in the active state and then some other | |
| 275 ;; application asserts the selection. This is probably not a big deal. | |
| 276 | |
| 277 (defun activate-region-as-selection () | |
|
5368
ed74d2ca7082
Use ', not #', when a given symbol may not have a function binding at read time
Aidan Kehoe <kehoea@parhasard.net>
parents:
5364
diff
changeset
|
278 (cond ((and-fboundp 'mouse-track-rectangle-p |
| 4222 | 279 (mouse-track-rectangle-p |
| 280 (mouse-track-activate-rectangular-selection)))) | |
| 487 | 281 ((marker-buffer (mark-marker t)) |
| 282 (own-selection (cons (point-marker t) (mark-marker t)))))) | |
| 428 | 283 |
| 284 (defvar primary-selection-extent nil | |
| 285 "The extent of the primary selection; don't use this.") | |
| 286 | |
| 287 (defvar secondary-selection-extent nil | |
| 288 "The extent of the secondary selection; don't use this.") | |
| 289 | |
| 290 (defun select-make-extent-for-selection (selection previous-extent) | |
| 291 ;; Given a selection, this makes an extent in the buffer which holds that | |
| 292 ;; selection, for highlighting purposes. If the selection isn't associated | |
| 293 ;; with a buffer, this does nothing. | |
| 2624 | 294 ;; |
| 295 ;; Something similar needs to be hooked into the rectangle functions. | |
| 428 | 296 (let ((buffer nil) |
| 297 (valid (and (extentp previous-extent) | |
| 298 (extent-object previous-extent) | |
| 299 (buffer-live-p (extent-object previous-extent)))) | |
| 300 start end) | |
| 301 (cond ((stringp selection) | |
| 302 ;; if we're selecting a string, lose the previous extent used | |
| 303 ;; to highlight the selection. | |
| 304 (setq valid nil)) | |
| 305 ((consp selection) | |
| 306 (setq start (min (car selection) (cdr selection)) | |
| 307 end (max (car selection) (cdr selection)) | |
| 308 valid (and valid | |
| 309 (eq (marker-buffer (car selection)) | |
| 310 (extent-object previous-extent))) | |
| 311 buffer (marker-buffer (car selection)))) | |
| 312 ((extentp selection) | |
| 313 (setq start (extent-start-position selection) | |
| 314 end (extent-end-position selection) | |
| 315 valid (and valid | |
| 316 (eq (extent-object selection) | |
| 317 (extent-object previous-extent))) | |
| 318 buffer (extent-object selection))) | |
| 319 (t | |
| 320 (signal 'error (list "invalid selection" selection)))) | |
| 321 | |
| 322 (if valid | |
| 323 nil | |
| 324 (condition-case () | |
| 325 (if (listp previous-extent) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
326 (mapc 'delete-extent previous-extent) |
| 428 | 327 (delete-extent previous-extent)) |
| 328 (error nil))) | |
| 329 | |
| 330 (if (not buffer) | |
| 331 ;; string case | |
| 332 nil | |
| 333 ;; normal case | |
| 334 (if valid | |
| 335 (set-extent-endpoints previous-extent start end) | |
| 336 (setq previous-extent (make-extent start end buffer)) | |
| 337 | |
| 338 ;; Make the extent be closed on the right, which means that if | |
| 339 ;; characters are inserted exactly at the end of the extent, the | |
| 340 ;; extent will grow to cover them. This is important for shell | |
| 341 ;; buffers - suppose one makes a selection, and one end is at | |
| 342 ;; point-max. If the shell produces output, that marker will remain | |
| 343 ;; at point-max (its position will increase). So it's important that | |
| 344 ;; the extent exhibit the same behavior, lest the region covered by | |
| 345 ;; the extent (the visual indication), and the region between point | |
| 346 ;; and mark (the actual selection value) become different! | |
| 347 (set-extent-property previous-extent 'end-open nil) | |
| 348 | |
| 349 (cond | |
|
5368
ed74d2ca7082
Use ', not #', when a given symbol may not have a function binding at read time
Aidan Kehoe <kehoea@parhasard.net>
parents:
5364
diff
changeset
|
350 ((and-fboundp 'mouse-track-rectangle-p |
| 4222 | 351 (mouse-track-rectangle-p |
| 352 (setq previous-extent (list previous-extent)) | |
| 353 (default-mouse-track-next-move-rect start end previous-extent) | |
| 354 )))) | |
| 428 | 355 previous-extent)))) |
| 356 | |
| 357 (defun valid-simple-selection-p (data) | |
| 442 | 358 "An obsolete function that tests whether something was a valid simple |
| 359 selection using the old XEmacs selection support. You shouldn't use this | |
| 360 any more, because just about anything could be a valid selection now." | |
| 428 | 361 (or (stringp data) |
| 362 ;FSFmacs huh?? (symbolp data) | |
| 363 (integerp data) | |
| 364 (and (consp data) | |
| 365 (integerp (car data)) | |
| 366 (or (integerp (cdr data)) | |
| 367 (and (consp (cdr data)) | |
| 368 (integerp (car (cdr data)))))) | |
| 369 (extentp data) | |
| 370 (and (consp data) | |
| 371 (markerp (car data)) | |
| 372 (markerp (cdr data)) | |
| 373 (marker-buffer (car data)) | |
| 374 (marker-buffer (cdr data)) | |
| 375 (eq (marker-buffer (car data)) | |
| 376 (marker-buffer (cdr data))) | |
| 377 (buffer-live-p (marker-buffer (car data))) | |
| 378 (buffer-live-p (marker-buffer (cdr data)))))) | |
| 379 | |
| 380 (defun cut-copy-clear-internal (mode) | |
|
5364
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
381 (or (memq mode '(cut copy clear)) (error "unknown mode %S" mode)) |
| 428 | 382 (or (selection-owner-p) |
| 383 (error "XEmacs does not own the primary selection")) | |
| 384 (setq last-command nil) | |
| 385 (or primary-selection-extent | |
| 386 (error "the primary selection is not an extent?")) | |
| 387 (save-excursion | |
| 388 (let (rect-p b s e) | |
| 389 (cond | |
| 390 ((consp primary-selection-extent) | |
| 391 (setq rect-p t | |
| 392 b (extent-object (car primary-selection-extent)) | |
| 393 s (extent-start-position (car primary-selection-extent)) | |
| 394 e (extent-end-position (car (reverse primary-selection-extent))))) | |
| 395 (t | |
| 396 (setq rect-p nil | |
| 397 b (extent-object primary-selection-extent) | |
| 398 s (extent-start-position primary-selection-extent) | |
| 399 e (extent-end-position primary-selection-extent)))) | |
| 400 (set-buffer b) | |
| 401 (cond ((memq mode '(cut copy)) | |
| 402 (if rect-p | |
| 403 (progn | |
| 851 | 404 ;; killed-rectangle is defvarred in rect.el |
| 428 | 405 (setq killed-rectangle (extract-rectangle s e)) |
| 406 (kill-new (mapconcat #'identity killed-rectangle "\n"))) | |
| 407 (copy-region-as-kill s e)) | |
| 408 ;; Maybe killing doesn't own clipboard. Make sure it happens. | |
| 409 ;; This memq is kind of grody, because they might have done it | |
| 410 ;; some other way, but owning the clipboard twice in that case | |
| 411 ;; wouldn't actually hurt anything. | |
| 412 (or (and (consp kill-hooks) (memq 'own-clipboard kill-hooks)) | |
| 851 | 413 (eq 'own-clipboard interprogram-cut-function) |
| 428 | 414 (own-clipboard (car kill-ring))))) |
| 415 (cond ((memq mode '(cut clear)) | |
| 416 (if rect-p | |
| 417 (delete-rectangle s e) | |
| 418 (delete-region s e)))) | |
| 419 (disown-selection nil) | |
| 420 ))) | |
| 421 | |
| 442 | 422 |
| 428 | 423 ;;; Functions to convert the selection into various other selection |
| 442 | 424 ;;; types. |
| 425 | |
| 426 ;; These next three functions get called by C code... | |
| 427 (defun select-convert-in (selection type value) | |
| 428 "Attempt to convert the specified external VALUE to the specified DATA-TYPE, | |
| 429 for the specified SELECTION. Return nil if this is impossible, or a | |
| 430 suitable internal representation otherwise." | |
| 431 (when value | |
| 432 (let ((handler-fn (cdr (assq type selection-converter-in-alist)))) | |
| 2624 | 433 (if handler-fn |
| 434 (apply handler-fn (list selection type value)) | |
| 435 value)))) | |
| 428 | 436 |
| 442 | 437 (defun select-convert-out (selection type value) |
| 438 "Attempt to convert the specified internal VALUE for the specified DATA-TYPE | |
| 439 and SELECTION. Return nil if this is impossible, or a suitable external | |
| 440 representation otherwise." | |
| 441 (when value | |
| 442 (let ((handler-fn (cdr (assq type selection-converter-out-alist)))) | |
| 443 (when handler-fn | |
| 444 (apply handler-fn (list selection type value)))))) | |
| 445 | |
| 446 (defun select-coerce (selection type value) | |
| 447 "Attempt to convert the specified internal VALUE to a representation | |
| 448 suitable for return from `get-selection' in the specified DATA-TYPE. Return | |
| 449 nil if this is impossible, or a suitable representation otherwise." | |
| 450 (when value | |
| 451 (let ((handler-fn (cdr (assq type selection-coercion-alist)))) | |
| 452 (when handler-fn | |
| 453 (apply handler-fn (list selection type value)))))) | |
| 454 | |
| 455 ;; The rest of the functions on this "page" are conversion handlers, | |
| 456 ;; append handlers and buffer-kill handlers. | |
| 428 | 457 (defun select-convert-to-text (selection type value) |
| 458 (cond ((stringp value) | |
|
5571
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
459 (substring-no-properties value)) |
| 428 | 460 ((extentp value) |
| 461 (save-excursion | |
| 462 (set-buffer (extent-object value)) | |
| 463 (save-restriction | |
| 464 (widen) | |
|
5571
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
465 (buffer-substring-no-properties (extent-start-position value) |
|
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
466 (extent-end-position value))))) |
| 428 | 467 ((and (consp value) |
| 468 (markerp (car value)) | |
| 469 (markerp (cdr value))) | |
| 470 (or (eq (marker-buffer (car value)) (marker-buffer (cdr value))) | |
| 471 (signal 'error | |
| 472 (list "markers must be in the same buffer" | |
| 473 (car value) (cdr value)))) | |
| 474 (save-excursion | |
| 475 (set-buffer (or (marker-buffer (car value)) | |
| 476 (error "selection is in a killed buffer"))) | |
| 477 (save-restriction | |
| 478 (widen) | |
|
5571
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
479 (buffer-substring-no-properties (car value) (cdr value))))) |
| 428 | 480 (t nil))) |
| 481 | |
| 2624 | 482 (defun select-convert-to-timestamp (selection type value) |
| 483 (let ((ts (get-xemacs-selection-timestamp selection))) | |
| 484 (if ts (cons 'TIMESTAMP ts)))) | |
| 485 | |
| 486 (defun select-convert-to-utf-8-text (selection type value) | |
| 487 (cond ((stringp value) | |
|
5571
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
488 (cons 'UTF8_STRING (encode-coding-string |
|
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
489 (substring-no-properties value) 'utf-8))) |
| 2624 | 490 ((extentp value) |
| 491 (save-excursion | |
| 492 (set-buffer (extent-object value)) | |
| 493 (save-restriction | |
| 494 (widen) | |
| 495 (cons 'UTF8_STRING | |
|
5571
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
496 (encode-coding-string (buffer-substring-no-properties |
|
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
497 (extent-start-position value) |
|
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
498 (extent-end-position value)) |
|
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
499 'utf-8))))) |
| 2624 | 500 ((and (consp value) |
| 501 (markerp (car value)) | |
| 502 (markerp (cdr value))) | |
| 503 (or (eq (marker-buffer (car value)) (marker-buffer (cdr value))) | |
| 504 (signal 'error | |
| 505 (list "markers must be in the same buffer" | |
| 506 (car value) (cdr value)))) | |
| 507 (save-excursion | |
| 508 (set-buffer (or (marker-buffer (car value)) | |
| 509 (error "selection is in a killed buffer"))) | |
| 510 (save-restriction | |
| 511 (widen) | |
| 512 (cons 'UTF8_STRING (encode-coding-string | |
|
5571
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
513 (buffer-substring-no-properties |
|
5273dd66a1ba
Strip extent information when passing text to external programs, select.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5473
diff
changeset
|
514 (car value) (cdr value)) 'utf-8))))) |
| 2624 | 515 (t nil))) |
| 516 | |
| 442 | 517 (defun select-coerce-to-text (selection type value) |
| 518 (select-convert-to-text selection type value)) | |
| 519 | |
| 428 | 520 (defun select-convert-to-string (selection type value) |
| 521 (let ((outval (select-convert-to-text selection type value))) | |
| 442 | 522 ;; force the string to be not in Compound Text format. This grubby |
| 523 ;; hack will go soon, to be replaced by a more general mechanism. | |
| 428 | 524 (if (stringp outval) |
| 525 (cons 'STRING outval) | |
| 526 outval))) | |
| 527 | |
| 528 (defun select-convert-to-compound-text (selection type value) | |
| 529 ;; converts to compound text automatically | |
| 530 (select-convert-to-text selection type value)) | |
| 531 | |
| 532 (defun select-convert-to-length (selection type value) | |
| 533 (let ((value | |
| 534 (cond ((stringp value) | |
| 535 (length value)) | |
| 536 ((extentp value) | |
| 537 (extent-length value)) | |
| 538 ((and (consp value) | |
| 539 (markerp (car value)) | |
| 540 (markerp (cdr value))) | |
| 541 (or (eq (marker-buffer (car value)) | |
| 542 (marker-buffer (cdr value))) | |
| 543 (signal 'error | |
| 544 (list "markers must be in the same buffer" | |
| 545 (car value) (cdr value)))) | |
| 546 (abs (- (car value) (cdr value))))))) | |
| 547 (if value ; force it to be in 32-bit format. | |
| 548 (cons (ash value -16) (logand value 65535)) | |
| 549 nil))) | |
| 550 | |
| 551 (defun select-convert-to-targets (selection type value) | |
| 552 ;; return a vector of atoms, but remove duplicates first. | |
| 553 (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist))) | |
| 554 (rest all)) | |
| 555 (while rest | |
| 556 (cond ((memq (car rest) (cdr rest)) | |
| 557 (setcdr rest (delq (car rest) (cdr rest)))) | |
| 558 (t | |
| 559 (setq rest (cdr rest))))) | |
| 560 (apply 'vector all))) | |
| 561 | |
| 562 (defun select-convert-to-delete (selection type value) | |
| 563 (disown-selection-internal selection) | |
| 564 ;; A return value of nil means that we do not know how to do this conversion, | |
| 565 ;; and replies with an "error". A return value of NULL means that we have | |
| 566 ;; done the conversion (and any side-effects) but have no value to return. | |
| 567 'NULL) | |
| 568 | |
| 569 (defun select-convert-to-filename (selection type value) | |
| 570 (cond ((extentp value) | |
| 571 (buffer-file-name (or (extent-object value) | |
| 572 (error "selection is in a killed buffer")))) | |
| 573 ((and (consp value) | |
| 574 (markerp (car value)) | |
| 575 (markerp (cdr value))) | |
| 576 (buffer-file-name (or (marker-buffer (car value)) | |
| 577 (error "selection is in a killed buffer")))) | |
| 578 (t nil))) | |
| 579 | |
| 580 (defun select-convert-to-charpos (selection type value) | |
| 581 (let (a b tmp) | |
| 582 (cond ((cond ((extentp value) | |
| 583 (setq a (extent-start-position value) | |
| 584 b (extent-end-position value))) | |
| 585 ((and (consp value) | |
| 586 (markerp (car value)) | |
| 587 (markerp (cdr value))) | |
| 588 (setq a (car value) | |
| 589 b (cdr value)))) | |
| 590 (setq a (1- a) b (1- b)) ; zero-based | |
| 591 (if (< b a) (setq tmp a a b b tmp)) | |
| 592 (cons 'SPAN | |
| 593 (vector (cons (ash a -16) (logand a 65535)) | |
| 594 (cons (ash b -16) (logand b 65535)))))))) | |
| 595 | |
| 596 (defun select-convert-to-lineno (selection type value) | |
| 597 (let (a b buf tmp) | |
| 598 (cond ((cond ((extentp value) | |
| 599 (setq buf (extent-object value) | |
| 600 a (extent-start-position value) | |
| 601 b (extent-end-position value))) | |
| 602 ((and (consp value) | |
| 603 (markerp (car value)) | |
| 604 (markerp (cdr value))) | |
| 605 (setq a (marker-position (car value)) | |
| 606 b (marker-position (cdr value)) | |
| 607 buf (marker-buffer (car value))))) | |
| 608 (save-excursion | |
| 609 (set-buffer buf) | |
| 610 (save-restriction | |
| 611 (widen) | |
| 612 (goto-char a) | |
| 613 (beginning-of-line) | |
| 614 (setq a (1+ (count-lines 1 (point)))) | |
| 615 (goto-char b) | |
| 616 (beginning-of-line) | |
| 617 (setq b (1+ (count-lines 1 (point)))))) | |
| 618 (if (< b a) (setq tmp a a b b tmp)) | |
| 619 (cons 'SPAN | |
| 620 (vector (cons (ash a -16) (logand a 65535)) | |
| 621 (cons (ash b -16) (logand b 65535)))))))) | |
| 622 | |
| 623 (defun select-convert-to-colno (selection type value) | |
| 624 (let (a b buf tmp) | |
| 625 (cond ((cond ((extentp value) | |
| 626 (setq buf (extent-object value) | |
| 627 a (extent-start-position value) | |
| 628 b (extent-end-position value))) | |
| 629 ((and (consp value) | |
| 630 (markerp (car value)) | |
| 631 (markerp (cdr value))) | |
| 632 (setq a (car value) | |
| 633 b (cdr value) | |
| 634 buf (marker-buffer a)))) | |
| 635 (save-excursion | |
| 636 (set-buffer buf) | |
| 637 (goto-char a) | |
| 638 (setq a (current-column)) | |
| 639 (goto-char b) | |
| 640 (setq b (current-column))) | |
| 641 (if (< b a) (setq tmp a a b b tmp)) | |
| 642 (cons 'SPAN | |
| 643 (vector (cons (ash a -16) (logand a 65535)) | |
| 644 (cons (ash b -16) (logand b 65535)))))))) | |
| 645 | |
| 646 (defun select-convert-to-sourceloc (selection type value) | |
| 647 (let (a b buf file-name tmp) | |
| 648 (cond ((cond ((extentp value) | |
| 649 (setq buf (or (extent-object value) | |
| 650 (error "selection is in a killed buffer")) | |
| 651 a (extent-start-position value) | |
| 652 b (extent-end-position value) | |
| 653 file-name (buffer-file-name buf))) | |
| 654 ((and (consp value) | |
| 655 (markerp (car value)) | |
| 656 (markerp (cdr value))) | |
| 657 (setq a (marker-position (car value)) | |
| 658 b (marker-position (cdr value)) | |
| 659 buf (or (marker-buffer (car value)) | |
| 660 (error "selection is in a killed buffer")) | |
| 661 file-name (buffer-file-name buf)))) | |
| 662 (save-excursion | |
| 663 (set-buffer buf) | |
| 664 (save-restriction | |
| 665 (widen) | |
| 666 (goto-char a) | |
| 667 (beginning-of-line) | |
| 668 (setq a (1+ (count-lines 1 (point)))) | |
| 669 (goto-char b) | |
| 670 (beginning-of-line) | |
| 671 (setq b (1+ (count-lines 1 (point)))))) | |
| 672 (if (< b a) (setq tmp a a b b tmp)) | |
| 673 (format "%s:%d" file-name a))))) | |
| 674 | |
| 675 (defun select-convert-to-os (selection type size) | |
| 676 (symbol-name system-type)) | |
| 677 | |
| 678 (defun select-convert-to-host (selection type size) | |
| 679 (system-name)) | |
| 680 | |
| 681 (defun select-convert-to-user (selection type size) | |
| 682 (user-full-name)) | |
| 683 | |
| 684 (defun select-convert-to-class (selection type size) | |
| 442 | 685 (symbol-value 'x-emacs-application-class)) |
| 428 | 686 |
| 687 ;; We do not try to determine the name Emacs was invoked with, | |
| 688 ;; because it is not clean for a program's behavior to depend on that. | |
| 689 (defun select-convert-to-name (selection type size) | |
| 690 ;invocation-name | |
| 691 "xemacs") | |
| 692 | |
| 693 (defun select-convert-to-integer (selection type value) | |
| 694 (and (integerp value) | |
| 695 (cons (ash value -16) (logand value 65535)))) | |
| 696 | |
| 442 | 697 ;; Can convert from the following integer representations |
| 698 ;; | |
| 699 ;; integer | |
| 700 ;; (integer . integer) | |
| 701 ;; (integer integer) | |
| 702 ;; (list [integer|(integer . integer)]*) | |
| 703 ;; (vector [integer|(integer . integer)]*) | |
| 704 ;; | |
| 705 ;; Cons'd integers get cleaned up a little. | |
| 706 | |
| 707 (defun select-convert-from-integer (selection type value) | |
| 708 (cond ((integerp value) ; Integer | |
| 709 value) | |
| 444 | 710 |
| 442 | 711 ((and (consp value) ; (integer . integer) |
| 712 (integerp (car value)) | |
| 713 (integerp (cdr value))) | |
| 714 (if (eq (car value) 0) | |
| 715 (cdr value) | |
| 716 (if (and (eq (car value) -1) | |
| 717 (< (cdr value) 0)) | |
| 718 (cdr value) | |
| 719 value))) | |
| 444 | 720 |
| 442 | 721 ((and (listp value) ; (integer integer) |
| 722 (eq (length value) 2) | |
| 723 (integerp (car value)) | |
| 724 (integerp (cadr value))) | |
| 725 (if (eq (car value) 0) | |
| 726 (cadr value) | |
| 727 (if (and (eq (car value) -1) | |
| 728 (< (cdr value) 0)) | |
| 729 (- (cadr value)) | |
| 730 (cons (car value) (cadr value))))) | |
| 444 | 731 |
| 442 | 732 ((listp value) ; list |
| 733 (if (cdr value) | |
| 4021 | 734 (mapcar #'(lambda (x) |
| 735 (select-convert-from-integer selection type x)) | |
| 442 | 736 value) |
| 737 (select-convert-from-integer selection type (car value)))) | |
| 444 | 738 |
| 442 | 739 ((vectorp value) ; vector |
| 740 (if (eq (length value) 1) | |
| 741 (select-convert-from-integer selection type (aref value 0)) | |
| 4021 | 742 (mapvector #'(lambda (x) |
| 743 (select-convert-from-integer selection type x)) | |
| 744 value))) | |
| 444 | 745 |
| 442 | 746 (t nil) |
| 747 )) | |
| 748 | |
| 2624 | 749 (defun select-convert-from-ip-address (selection type value) |
| 750 (if (and (stringp value) | |
| 751 (= (length value) 4)) | |
| 752 (format "%d.%d.%d.%d" | |
| 753 (aref value 0) (aref value 1) (aref value 2) (aref value 3)))) | |
| 754 | |
| 428 | 755 (defun select-convert-to-atom (selection type value) |
| 756 (and (symbolp value) value)) | |
| 757 | |
| 2624 | 758 (defun select-convert-from-utf-8-text (selection type value) |
| 759 (decode-coding-string value 'utf-8)) | |
| 760 | |
| 761 (defun select-convert-from-utf-16-le-text (selection type value) | |
| 762 (decode-coding-string value 'utf-16-le)) | |
| 763 | |
| 764 ;; Image conversion. | |
| 765 (defun select-convert-from-image-data (image-type value) | |
| 766 "Take an image type specification--one of the image types this XEmacs | |
| 767 supports--and some data in that format, return a space, with a glyph | |
| 768 corresponding to that data as an end-glyph extent property of that space. " | |
| 769 (let* ((str (make-string 1 ?\ )) | |
| 770 (extent (make-extent 0 1 str)) | |
|
5344
2a54dfbe434f
Don't quote keywords, they've been self-quoting for well over a decade.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4783
diff
changeset
|
771 (glyph (make-glyph (vector image-type :data value)))) |
| 2624 | 772 (when glyph |
| 773 (set-extent-property extent 'invisible t) | |
| 774 (set-extent-property extent 'start-open t) | |
| 775 (set-extent-property extent 'end-open t) | |
| 776 (set-extent-property extent 'duplicable t) | |
| 777 (set-extent-property extent 'atomic t) | |
| 778 (set-extent-end-glyph extent glyph) | |
| 779 str))) | |
| 780 | |
|
5364
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
781 (macrolet |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
782 ((create-image-functions (&rest formats) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
783 (cons |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
784 'progn |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
785 (mapcar |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
786 #'(lambda (format) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
787 `(if (featurep ',format) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
788 (defalias (intern (concat "select-convert-from-image/" |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
789 ,(symbol-name format))) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
790 #'(lambda (selection type value) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
791 (select-convert-from-image-data ',format |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
792 value))))) formats)))) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
793 (create-image-functions gif jpeg png tiff xpm xbm)) |
| 2624 | 794 |
| 442 | 795 ;;; CF_xxx conversions |
| 796 (defun select-convert-from-cf-text (selection type value) | |
| 2624 | 797 (if (find-coding-system 'mswindows-multibyte) |
| 798 (let ((value (decode-coding-string value 'mswindows-multibyte))) | |
| 799 (replace-in-string (if (string-match "\0" value) | |
| 800 (substring value 0 (match-beginning 0)) | |
| 801 value) | |
| 802 "\\(\r\n\\|\n\r\\)" "\n" t)))) | |
| 771 | 803 |
| 804 (defun select-convert-from-cf-unicodetext (selection type value) | |
| 2624 | 805 (if (find-coding-system 'mswindows-unicode) |
| 806 (let ((value (decode-coding-string value 'mswindows-unicode))) | |
| 807 (replace-in-string (if (string-match "\0" value) | |
| 808 (substring value 0 (match-beginning 0)) | |
| 809 value) | |
| 810 "\\(\r\n\\|\n\r\\)" "\n" t)))) | |
| 442 | 811 |
| 812 (defun select-convert-to-cf-text (selection type value) | |
| 2624 | 813 (if (find-coding-system 'mswindows-multibyte) |
| 814 (let ((text (select-convert-to-text selection type value))) | |
| 815 (encode-coding-string | |
| 816 (concat (replace-in-string text "\n" "\r\n" t) "\0") | |
| 817 'mswindows-multibyte)))) | |
| 771 | 818 |
| 819 (defun select-convert-to-cf-unicodetext (selection type value) | |
| 2624 | 820 (if (find-coding-system 'mswindows-unicode) |
| 821 (let ((text (select-convert-to-text selection type value))) | |
| 822 (encode-coding-string | |
| 823 (concat (replace-in-string text "\n" "\r\n" t) "\0") | |
| 824 'mswindows-unicode)))) | |
| 442 | 825 |
| 826 ;;; Appenders | |
| 827 (defun select-append-to-text (selection type value1 value2) | |
| 828 (let ((text1 (select-convert-to-text selection 'STRING value1)) | |
| 829 (text2 (select-convert-to-text selection 'STRING value2))) | |
| 830 (if (and text1 text2) | |
| 831 (concat text1 text2) | |
| 832 nil))) | |
| 833 | |
| 834 (defun select-append-to-string (selection type value1 value2) | |
| 835 (select-append-to-text selection type value1 value2)) | |
| 836 | |
| 837 (defun select-append-to-compound-text (selection type value1 value2) | |
| 838 (select-append-to-text selection type value1 value2)) | |
| 839 | |
| 840 (defun select-append-to-cf-text (selection type value1 value2) | |
| 841 (let ((text1 (select-convert-from-cf-text selection 'CF_TEXT value1)) | |
| 842 (text2 (select-convert-from-cf-text selection 'CF_TEXT value2))) | |
| 843 (if (and text1 text2) | |
| 844 (select-convert-to-cf-text selection type (concat text1 text2)) | |
| 845 nil))) | |
| 428 | 846 |
| 771 | 847 (defun select-append-to-cf-unicodetext (selection type value1 value2) |
| 848 (let ((text1 (select-convert-from-cf-unicodetext selection | |
| 849 'CF_UNICODETEXT value1)) | |
| 850 (text2 (select-convert-from-cf-unicodetext selection | |
| 851 'CF_UNICODETEXT value2))) | |
| 852 (if (and text1 text2) | |
| 853 (select-convert-to-cf-unicodetext selection type (concat text1 text2)) | |
| 854 nil))) | |
| 855 | |
| 442 | 856 (defun select-append-default (selection type value1 value2) |
| 857 ;; This appender gets used if the type is "nil" - i.e. default. | |
| 858 ;; It should probably have more cases implemented than it does - e.g. | |
| 859 ;; appending numbers to strings, etc... | |
| 860 (cond ((and (stringp value1) (stringp value2)) | |
| 861 (select-append-to-string selection 'STRING value1 value2)) | |
| 862 (t nil))) | |
| 863 | |
| 864 ;;; Buffer kill handlers | |
| 865 | |
| 866 (defun select-buffer-killed-default (selection type value buffer) | |
| 867 ;; This handler gets used if the type is "nil". | |
| 868 (cond ((extentp value) | |
| 869 (if (eq (extent-object value) buffer) | |
| 870 ; If this selection is on the clipboard, grab it quick | |
| 871 (when (eq selection 'CLIPBOARD) | |
| 872 (save-excursion | |
| 873 (set-buffer (extent-object value)) | |
| 874 (save-restriction | |
| 875 (widen) | |
| 876 (buffer-substring (extent-start-position value) | |
| 877 (extent-end-position value))))) | |
| 878 value)) | |
| 879 ((markerp value) | |
| 880 (unless (eq (marker-buffer value) buffer) | |
| 881 value)) | |
| 882 ((and (consp value) | |
| 883 (markerp (car value)) | |
| 884 (markerp (cdr value))) | |
| 885 (if (or (eq (marker-buffer (car value)) buffer) | |
| 886 (eq (marker-buffer (cdr value)) buffer)) | |
| 887 ; If this selection is on the clipboard, grab it quick | |
| 888 (when (eq selection 'CLIPBOARD) | |
| 889 (save-excursion | |
| 890 (set-buffer (marker-buffer (car value))) | |
| 891 (save-restriction | |
| 892 (widen) | |
| 893 (buffer-substring (car value) (cdr value))))) | |
| 894 value)) | |
| 895 (t value))) | |
| 896 | |
| 897 (defun select-buffer-killed-text (selection type value buffer) | |
| 898 (select-buffer-killed-default selection type value buffer)) | |
| 444 | 899 |
| 442 | 900 ;; Types listed in here can be selections of XEmacs |
| 901 (setq selection-converter-out-alist | |
| 2624 | 902 '((TIMESTAMP . select-convert-to-timestamp) |
| 903 (UTF8_STRING . select-convert-to-utf-8-text) | |
| 904 (TEXT . select-convert-to-text) | |
| 428 | 905 (STRING . select-convert-to-string) |
| 906 (COMPOUND_TEXT . select-convert-to-compound-text) | |
| 907 (TARGETS . select-convert-to-targets) | |
| 908 (LENGTH . select-convert-to-length) | |
| 909 (DELETE . select-convert-to-delete) | |
| 910 (FILE_NAME . select-convert-to-filename) | |
| 911 (CHARACTER_POSITION . select-convert-to-charpos) | |
| 912 (SOURCE_LOC . select-convert-to-sourceloc) | |
| 913 (LINE_NUMBER . select-convert-to-lineno) | |
| 914 (COLUMN_NUMBER . select-convert-to-colno) | |
| 915 (OWNER_OS . select-convert-to-os) | |
| 916 (HOST_NAME . select-convert-to-host) | |
| 917 (USER . select-convert-to-user) | |
| 918 (CLASS . select-convert-to-class) | |
| 919 (NAME . select-convert-to-name) | |
| 920 (ATOM . select-convert-to-atom) | |
| 921 (INTEGER . select-convert-to-integer) | |
| 442 | 922 (CF_TEXT . select-convert-to-cf-text) |
| 771 | 923 (CF_UNICODETEXT . select-convert-to-cf-unicodetext) |
| 442 | 924 )) |
| 925 | |
| 926 ;; Types listed here can be selections foreign to XEmacs | |
| 927 (setq selection-converter-in-alist | |
|
5364
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
928 `(; Specific types that get handled by generic converters |
| 442 | 929 (INTEGER . select-convert-from-integer) |
| 2624 | 930 (TIMESTAMP . select-convert-from-integer) |
| 931 (LENGTH . select-convert-from-integer) | |
| 932 (LIST_LENGTH . select-convert-from-integer) | |
| 933 (CLIENT_WINDOW . select-convert-from-integer) | |
| 934 (PROCESS . select-convert-from-integer) | |
| 935 (IP_ADDRESS . select-convert-from-ip-address) | |
| 936 ;; We go after UTF8_STRING in preference to STRING because Mozilla, | |
| 937 ;; at least, does bad things with non-Latin-1 Unicode characters in | |
| 938 ;; STRING. | |
| 939 (UTF8_STRING . select-convert-from-utf-8-text) | |
| 442 | 940 (CF_TEXT . select-convert-from-cf-text) |
| 771 | 941 (CF_UNICODETEXT . select-convert-from-cf-unicodetext) |
| 2624 | 942 (text/html . select-convert-from-utf-16-le-text) ; Mozilla |
| 943 (text/_moz_htmlcontext . select-convert-from-utf-16-le-text) | |
| 944 (text/_moz_htmlinfo . select-convert-from-utf-16-le-text) | |
|
5364
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
945 ,@(loop |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
946 for format in '(gif jpeg png tiff xpm xbm) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
947 nconc (if (featurep format) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
948 (list (cons (intern (format "image/%s" format)) |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
949 (intern (format "select-convert-from-image/%s" |
|
0f9aa4eb4bec
Make my Lisp a little more sophisticated, select.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
950 format)))))))) |
| 428 | 951 |
| 442 | 952 ;; Types listed here have special coercion functions that can munge |
| 953 ;; other types. This can also be used to add special features - e.g. | |
| 954 ;; being able to pass a region or a cons of markers to own-selection, | |
| 955 ;; but getting the *current* text in the region back when calling | |
| 956 ;; get-selection. | |
| 957 ;; | |
| 958 ;; Any function listed in here *will be called* whenever a value of | |
| 959 ;; its type is retrieved from the internal selection cache, or when | |
| 960 ;; no suitable values could be found in which case XEmacs looks for | |
| 961 ;; values with types listed in selection-coercible-types. | |
| 962 (setq selection-coercion-alist | |
| 963 '((TEXT . select-coerce-to-text) | |
| 964 (STRING . select-coerce-to-text) | |
| 965 (COMPOUND_TEXT . select-coerce-to-text) | |
| 771 | 966 (CF_TEXT . select-coerce-to-text) |
| 967 (CF_UNICODETEXT . select-coerce-to-text) | |
| 968 )) | |
| 442 | 969 |
| 970 ;; Types listed here can be appended by own-selection | |
| 971 (setq selection-appender-alist | |
| 972 '((nil . select-append-default) | |
| 973 (TEXT . select-append-to-text) | |
| 974 (STRING . select-append-to-string) | |
| 975 (COMPOUND_TEXT . select-append-to-compound-text) | |
| 976 (CF_TEXT . select-append-to-cf-text) | |
| 771 | 977 (CF_UNICODETEXT . select-append-to-cf-unicodetext) |
| 442 | 978 )) |
| 979 | |
| 980 ;; Types listed here have buffer-kill handlers | |
| 981 (setq selection-buffer-killed-alist | |
| 982 '((nil . select-buffer-killed-default) | |
| 983 (TEXT . select-buffer-killed-text) | |
| 984 (STRING . select-buffer-killed-text) | |
| 985 (COMPOUND_TEXT . select-buffer-killed-text) | |
| 771 | 986 (CF_TEXT . select-buffer-killed-text) |
| 987 (CF_UNICODETEXT . select-buffer-killed-text) | |
| 988 )) | |
| 442 | 989 |
| 990 ;; Lists of types that are coercible (can be converted to other types) | |
| 771 | 991 (setq selection-coercible-types '(TEXT STRING COMPOUND_TEXT CF_TEXT CF_UNICODETEXT)) |
| 442 | 992 |
| 428 | 993 ;;; select.el ends here |