git.chise.org Git - chise/xemacs-chise.git.1/blob - 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     text))
 109
 110 ;; FSFmacs calls this `x-set-selection', and reverses the
 111 ;; first two arguments (duh ...).  This order is more logical.
 112 (defun own-selection (data &optional type how-to-add data-type)
 113   "Make a window-system selection of type TYPE and value DATA.
 114 The argument TYPE (default `PRIMARY') says which selection,
 115 and DATA specifies the contents.  DATA may be any lisp data type
 116 that can be converted using the function corresponding to DATA-TYPE
 117 in `select-converter-alist'---strings are the usual choice, but
 118 other types may be permissible depending on the DATA-TYPE parameter
 119 (if DATA-TYPE is not supplied, the default behaviour is window
 120 system specific, but strings are always accepted).
 121 HOW-TO-ADD may be any of the following:
 122
 123   'replace-all or nil -- replace all data in the selection.
 124   'replace-existing   -- replace data for specified DATA-TYPE only.
 125   'append or t        -- append data to existing DATA-TYPE data.
 126
 127 DATA-TYPE is the window-system specific data type identifier
 128 (see `register-selection-data-type' for more information).
 129
 130 The selection may also be a cons of two markers pointing to the same buffer,
 131 or an overlay.  In these cases, the selection is considered to be the text
 132 between the markers *at whatever time the selection is examined* (note
 133 that the window system clipboard does not necessarily duplicate this
 134 behaviour - it doesn't on mswindows for example).
 135 Thus, editing done in the buffer after you specify the selection
 136 can alter the effective value of the selection.
 137
 138 The data may also be a vector of valid non-vector selection values.
 139
 140 Interactively, the text of the region is used as the selection value."
 141   (interactive (if (not current-prefix-arg)
 142                    (list (read-string "Store text for pasting: "))
 143                  (list (substring (region-beginning) (region-end)))))
 144   ;; calling own-selection-internal will mess this up, so preserve it.
 145   (let ((zmacs-region-stays zmacs-region-stays))
 146                                         ;FSFmacs huh??  It says:
 147     ;; "This is for temporary compatibility with pre-release Emacs 19."
 148                                         ;(if (stringp type)
 149                                         ;    (setq type (intern type)))
 150     (or type (setq type 'PRIMARY))
 151     (if (null data)
 152         (disown-selection-internal type)
 153       (own-selection-internal type data how-to-add data-type)
 154       (when (and (eq type 'PRIMARY)
 155                  selection-sets-clipboard)
 156          (own-selection-internal 'CLIPBOARD data how-to-add data-type)))
 157     (cond ((eq type 'PRIMARY)
 158            (setq primary-selection-extent
 159                  (select-make-extent-for-selection
 160                   data primary-selection-extent)))
 161           ((eq type 'SECONDARY)
 162            (setq secondary-selection-extent
 163                  (select-make-extent-for-selection
 164                   data secondary-selection-extent)))))
 165   ;; zmacs-region-stays is for commands, not low-level functions.
 166   ;; when behaving as the latter, we better not set it, or we will
 167   ;; cause unwanted sticky-region behavior in kill-region and friends.
 168   (if (interactive-p)
 169   (setq zmacs-region-stays t))
 170   data)
 171
 172 (defun dehilight-selection (selection)
 173   "for use as a value of `lost-selection-hooks'."
 174   (cond ((eq selection 'PRIMARY)
 175          (if primary-selection-extent
 176              (let ((inhibit-quit t))
 177                (if (consp primary-selection-extent)
 178                    (mapcar 'delete-extent primary-selection-extent)
 179                  (delete-extent primary-selection-extent))
 180                (setq primary-selection-extent nil)))
 181          (if zmacs-regions (zmacs-deactivate-region)))
 182         ((eq selection 'SECONDARY)
 183          (if secondary-selection-extent
 184              (let ((inhibit-quit t))
 185                (if (consp secondary-selection-extent)
 186                    (mapcar 'delete-extent secondary-selection-extent)
 187                  (delete-extent secondary-selection-extent))
 188                (setq secondary-selection-extent nil)))))
 189   nil)
 190
 191 (setq lost-selection-hooks 'dehilight-selection)
 192
 193 (defun own-clipboard (string &optional push)
 194   "Paste the given string to the window system Clipboard.
 195 See `interprogram-cut-function' for more information."
 196   (own-selection string 'CLIPBOARD))
 197
 198 (defun disown-selection (&optional secondary-p)
 199   "Assuming we own the selection, disown it.  With an argument, discard the
 200 secondary selection instead of the primary selection."
 201   (disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY))
 202   (when (and selection-sets-clipboard
 203              (or (not secondary-p)
 204                  (eq secondary-p 'PRIMARY)
 205                  (eq secondary-p 'CLIPBOARD)))
 206     (disown-selection-internal 'CLIPBOARD)))
 207
 208 ;; from x-init.el
 209 ;; selections and active regions
 210
 211 ;; If and only if zmacs-regions is true:
 212
 213 ;; When a mark is pushed and the region goes into the "active" state, we
 214 ;; assert it as the Primary selection.  This causes it to be hilighted.
 215 ;; When the region goes into the "inactive" state, we disown the Primary
 216 ;; selection, causing the region to be dehilighted.
 217
 218 ;; Note that it is possible for the region to be in the "active" state
 219 ;; and not be hilighted, if it is in the active state and then some other
 220 ;; application asserts the selection.  This is probably not a big deal.
 221
 222 (defun activate-region-as-selection ()
 223   (if (marker-buffer (mark-marker t))
 224       (own-selection (cons (point-marker t) (mark-marker t)))))
 225
 226 ; moved from x-select.el
 227 (defvar primary-selection-extent nil
 228   "The extent of the primary selection; don't use this.")
 229
 230 (defvar secondary-selection-extent nil
 231   "The extent of the secondary selection; don't use this.")
 232
 233 (defun select-make-extent-for-selection (selection previous-extent)
 234   ;; Given a selection, this makes an extent in the buffer which holds that
 235   ;; selection, for highlighting purposes.  If the selection isn't associated
 236   ;; with a buffer, this does nothing.
 237   (let ((buffer nil)
 238         (valid (and (extentp previous-extent)
 239                     (extent-object previous-extent)
 240                     (buffer-live-p (extent-object previous-extent))))
 241         start end)
 242     (cond ((stringp selection)
 243            ;; if we're selecting a string, lose the previous extent used
 244            ;; to highlight the selection.
 245            (setq valid nil))
 246           ((consp selection)
 247            (setq start (min (car selection) (cdr selection))
 248                  end (max (car selection) (cdr selection))
 249                  valid (and valid
 250                             (eq (marker-buffer (car selection))
 251                                 (extent-object previous-extent)))
 252                  buffer (marker-buffer (car selection))))
 253           ((extentp selection)
 254            (setq start (extent-start-position selection)
 255                  end (extent-end-position selection)
 256                  valid (and valid
 257                             (eq (extent-object selection)
 258                                 (extent-object previous-extent)))
 259                  buffer (extent-object selection)))
 260           (t
 261            (signal 'error (list "invalid selection" selection))))
 262
 263     (if valid
 264         nil
 265       (condition-case ()
 266           (if (listp previous-extent)
 267               (mapcar 'delete-extent previous-extent)
 268             (delete-extent previous-extent))
 269         (error nil)))
 270
 271     (if (not buffer)
 272         ;; string case
 273         nil
 274       ;; normal case
 275       (if valid
 276           (set-extent-endpoints previous-extent start end)
 277         (setq previous-extent (make-extent start end buffer))
 278
 279         ;; Make the extent be closed on the right, which means that if
 280         ;; characters are inserted exactly at the end of the extent, the
 281         ;; extent will grow to cover them.  This is important for shell
 282         ;; buffers - suppose one makes a selection, and one end is at
 283         ;; point-max.  If the shell produces output, that marker will remain
 284         ;; at point-max (its position will increase).  So it's important that
 285         ;; the extent exhibit the same behavior, lest the region covered by
 286         ;; the extent (the visual indication), and the region between point
 287         ;; and mark (the actual selection value) become different!
 288         (set-extent-property previous-extent 'end-open nil)
 289
 290         (cond
 291          (mouse-track-rectangle-p
 292           (setq previous-extent (list previous-extent))
 293           (default-mouse-track-next-move-rect start end previous-extent)
 294           ))
 295         previous-extent))))
 296
 297 ;; moved from x-select.el
 298 (defun valid-simple-selection-p (data)
 299   "An obsolete function that tests whether something was a valid simple
 300 selection using the old XEmacs selection support. You shouldn't use this
 301 any more, because just about anything could be a valid selection now."
 302   (or (stringp data)
 303       ;FSFmacs huh?? (symbolp data)
 304       (integerp data)
 305       (and (consp data)
 306            (integerp (car data))
 307            (or (integerp (cdr data))
 308                (and (consp (cdr data))
 309                     (integerp (car (cdr data))))))
 310       (extentp data)
 311       (and (consp data)
 312            (markerp (car data))
 313            (markerp (cdr data))
 314            (marker-buffer (car data))
 315            (marker-buffer (cdr data))
 316            (eq (marker-buffer (car data))
 317                (marker-buffer (cdr data)))
 318            (buffer-live-p (marker-buffer (car data)))
 319            (buffer-live-p (marker-buffer (cdr data))))))
 320
 321 (defun cut-copy-clear-internal (mode)
 322   (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode))
 323   (or (selection-owner-p)
 324       (error "XEmacs does not own the primary selection"))
 325   (setq last-command nil)
 326   (or primary-selection-extent
 327       (error "the primary selection is not an extent?"))
 328   (save-excursion
 329     (let (rect-p b s e)
 330       (cond
 331        ((consp primary-selection-extent)
 332         (setq rect-p t
 333               b (extent-object (car primary-selection-extent))
 334               s (extent-start-position (car primary-selection-extent))
 335               e (extent-end-position (car (reverse primary-selection-extent)))))
 336        (t
 337         (setq rect-p nil
 338               b (extent-object primary-selection-extent)
 339               s (extent-start-position primary-selection-extent)
 340               e (extent-end-position primary-selection-extent))))
 341       (set-buffer b)
 342       (cond ((memq mode '(cut copy))
 343              (if rect-p
 344                  (progn
 345                    ;; why is killed-rectangle free?  Is it used somewhere?
 346                    ;; should it be defvarred?
 347                    (setq killed-rectangle (extract-rectangle s e))
 348                    (kill-new (mapconcat #'identity killed-rectangle "\n")))
 349                (copy-region-as-kill s e))
 350              ;; Maybe killing doesn't own clipboard.  Make sure it happens.
 351              ;; This memq is kind of grody, because they might have done it
 352              ;; some other way, but owning the clipboard twice in that case
 353              ;; wouldn't actually hurt anything.
 354              (or (and (consp kill-hooks) (memq 'own-clipboard kill-hooks))
 355                  (own-clipboard (car kill-ring)))))
 356       (cond ((memq mode '(cut clear))
 357              (if rect-p
 358                  (delete-rectangle s e)
 359                (delete-region s e))))
 360       (disown-selection nil)
 361       )))
 362
 363 \f
 364 ;;; Functions to convert the selection into various other selection
 365 ;;; types.
 366
 367 ;; These two functions get called by C code...
 368 (defun select-convert-in (selection type value)
 369   "Attempt to convert the specified external VALUE to the specified DATA-TYPE,
 370 for the specified SELECTION. Return nil if this is impossible, or a
 371 suitable internal representation otherwise."
 372   (when value
 373     (let ((handler-fn (cdr (assq type selection-converter-in-alist))))
 374       (when handler-fn
 375         (apply handler-fn (list selection type value))))))
 376
 377 (defun select-convert-out (selection type value)
 378   "Attempt to convert the specified internal VALUE for the specified DATA-TYPE
 379 and SELECTION. Return nil if this is impossible, or a suitable external
 380 representation otherwise."
 381   (when value
 382     (let ((handler-fn (cdr (assq type selection-converter-out-alist))))
 383       (when handler-fn
 384         (apply handler-fn (list selection type value))))))
 385
 386 ;; The rest of the functions on this "page" are conversion handlers,
 387 ;; append handlers and buffer-kill handlers.
 388 (defun select-convert-to-text (selection type value)
 389   (cond ((stringp value)
 390          value)
 391         ((extentp value)
 392          (save-excursion
 393            (set-buffer (extent-object value))
 394            (save-restriction
 395              (widen)
 396              (buffer-substring (extent-start-position value)
 397                                (extent-end-position value)))))
 398         ((and (consp value)
 399               (markerp (car value))
 400               (markerp (cdr value)))
 401          (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
 402              (signal 'error
 403                      (list "markers must be in the same buffer"
 404                            (car value) (cdr value))))
 405          (save-excursion
 406            (set-buffer (or (marker-buffer (car value))
 407                            (error "selection is in a killed buffer")))
 408            (save-restriction
 409              (widen)
 410              (buffer-substring (car value) (cdr value)))))
 411         (t nil)))
 412
 413 (defun select-convert-from-text (selection type value)
 414   (when (stringp value)
 415     value))
 416
 417 (defun select-convert-to-string (selection type value)
 418   (let ((outval (select-convert-to-text selection type value)))
 419     ;; force the string to be not in Compound Text format.
 420     (if (stringp outval)
 421         (cons 'STRING outval)
 422       outval)))
 423
 424 (defun select-convert-to-compound-text (selection type value)
 425   ;; converts to compound text automatically
 426   (select-convert-to-text selection type value))
 427
 428 (defun select-convert-to-length (selection type value)
 429   (let ((value
 430          (cond ((stringp value)
 431                 (length value))
 432                ((extentp value)
 433                 (extent-length value))
 434                ((and (consp value)
 435                      (markerp (car value))
 436                      (markerp (cdr value)))
 437                 (or (eq (marker-buffer (car value))
 438                         (marker-buffer (cdr value)))
 439                     (signal 'error
 440                             (list "markers must be in the same buffer"
 441                                   (car value) (cdr value))))
 442                 (abs (- (car value) (cdr value)))))))
 443     (if value ; force it to be in 32-bit format.
 444         (cons (ash value -16) (logand value 65535))
 445       nil)))
 446
 447 (defun select-convert-from-length (selection type value)
 448   (select-convert-to-length selection type value))
 449
 450 (defun select-convert-to-targets (selection type value)
 451   ;; return a vector of atoms, but remove duplicates first.
 452   (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
 453          (rest all))
 454     (while rest
 455       (cond ((memq (car rest) (cdr rest))
 456              (setcdr rest (delq (car rest) (cdr rest))))
 457             (t
 458              (setq rest (cdr rest)))))
 459     (apply 'vector all)))
 460
 461 (defun select-convert-to-delete (selection type value)
 462   (disown-selection-internal selection)
 463   ;; A return value of nil means that we do not know how to do this conversion,
 464   ;; and replies with an "error".  A return value of NULL means that we have
 465   ;; done the conversion (and any side-effects) but have no value to return.
 466   'NULL)
 467
 468 (defun select-convert-to-filename (selection type value)
 469   (cond ((extentp value)
 470          (buffer-file-name (or (extent-object value)
 471                                (error "selection is in a killed buffer"))))
 472         ((and (consp value)
 473               (markerp (car value))
 474               (markerp (cdr value)))
 475          (buffer-file-name (or (marker-buffer (car value))
 476                                (error "selection is in a killed buffer"))))
 477         (t nil)))
 478
 479 (defun select-convert-from-filename (selection type value)
 480   (when (stringp value)
 481     value))
 482
 483 (defun select-convert-to-charpos (selection type value)
 484   (let (a b tmp)
 485     (cond ((cond ((extentp value)
 486                   (setq a (extent-start-position value)
 487                         b (extent-end-position value)))
 488                  ((and (consp value)
 489                        (markerp (car value))
 490                        (markerp (cdr value)))
 491                   (setq a (car value)
 492                         b (cdr value))))
 493            (setq a (1- a) b (1- b)) ; zero-based
 494            (if (< b a) (setq tmp a a b b tmp))
 495            (cons 'SPAN
 496                  (vector (cons (ash a -16) (logand a 65535))
 497                          (cons (ash b -16) (logand b 65535))))))))
 498
 499 (defun select-convert-to-lineno (selection type value)
 500   (let (a b buf tmp)
 501     (cond ((cond ((extentp value)
 502                   (setq buf (extent-object value)
 503                         a (extent-start-position value)
 504                         b (extent-end-position value)))
 505                  ((and (consp value)
 506                        (markerp (car value))
 507                        (markerp (cdr value)))
 508                   (setq a (marker-position (car value))
 509                         b (marker-position (cdr value))
 510                         buf (marker-buffer (car value)))))
 511            (save-excursion
 512              (set-buffer buf)
 513              (save-restriction
 514                (widen)
 515                (goto-char a)
 516                (beginning-of-line)
 517                (setq a (1+ (count-lines 1 (point))))
 518                (goto-char b)
 519                (beginning-of-line)
 520                (setq b (1+ (count-lines 1 (point))))))
 521            (if (< b a) (setq tmp a a b b tmp))
 522            (cons 'SPAN
 523                  (vector (cons (ash a -16) (logand a 65535))
 524                          (cons (ash b -16) (logand b 65535))))))))
 525
 526 (defun select-convert-to-colno (selection type value)
 527   (let (a b buf tmp)
 528     (cond ((cond ((extentp value)
 529                   (setq buf (extent-object value)
 530                         a (extent-start-position value)
 531                         b (extent-end-position value)))
 532                  ((and (consp value)
 533                        (markerp (car value))
 534                        (markerp (cdr value)))
 535                   (setq a (car value)
 536                         b (cdr value)
 537                         buf (marker-buffer a))))
 538            (save-excursion
 539              (set-buffer buf)
 540              (goto-char a)
 541              (setq a (current-column))
 542              (goto-char b)
 543              (setq b (current-column)))
 544            (if (< b a) (setq tmp a a b b tmp))
 545            (cons 'SPAN
 546                  (vector (cons (ash a -16) (logand a 65535))
 547                          (cons (ash b -16) (logand b 65535))))))))
 548
 549 (defun select-convert-to-sourceloc (selection type value)
 550   (let (a b buf file-name tmp)
 551     (cond ((cond ((extentp value)
 552                   (setq buf (or (extent-object value)
 553                                 (error "selection is in a killed buffer"))
 554                         a (extent-start-position value)
 555                         b (extent-end-position value)
 556                         file-name (buffer-file-name buf)))
 557                  ((and (consp value)
 558                        (markerp (car value))
 559                        (markerp (cdr value)))
 560                   (setq a (marker-position (car value))
 561                         b (marker-position (cdr value))
 562                         buf (or (marker-buffer (car value))
 563                                 (error "selection is in a killed buffer"))
 564                         file-name (buffer-file-name buf))))
 565            (save-excursion
 566              (set-buffer buf)
 567              (save-restriction
 568                (widen)
 569                (goto-char a)
 570                (beginning-of-line)
 571                (setq a (1+ (count-lines 1 (point))))
 572                (goto-char b)
 573                (beginning-of-line)
 574                (setq b (1+ (count-lines 1 (point))))))
 575            (if (< b a) (setq tmp a a b b tmp))
 576            (format "%s:%d" file-name a)))))
 577
 578 (defun select-convert-to-os (selection type size)
 579   (symbol-name system-type))
 580
 581 (defun select-convert-to-host (selection type size)
 582   (system-name))
 583
 584 (defun select-convert-to-user (selection type size)
 585   (user-full-name))
 586
 587 (defun select-convert-to-class (selection type size)
 588   x-emacs-application-class)
 589
 590 ;; We do not try to determine the name Emacs was invoked with,
 591 ;; because it is not clean for a program's behavior to depend on that.
 592 (defun select-convert-to-name (selection type size)
 593   ;invocation-name
 594   "xemacs")
 595
 596 (defun select-convert-to-integer (selection type value)
 597   (and (integerp value)
 598        (cons (ash value -16) (logand value 65535))))
 599
 600 ;; Can convert from the following integer representations
 601 ;;
 602 ;;    integer
 603 ;;    (integer . integer)
 604 ;;    (integer integer)
 605 ;;    (list [integer|(integer . integer)]*)
 606 ;;    (vector [integer|(integer . integer)]*)
 607 ;;
 608 ;; Cons'd integers get cleaned up a little.
 609
 610 (defun select-convert-from-integer (selection type value)
 611   (cond ((integerp value)               ; Integer
 612          value)
 613
 614         ((and (consp value)             ; (integer . integer)
 615               (integerp (car value))
 616               (integerp (cdr value)))
 617          (if (eq (car value) 0)
 618              (cdr value)
 619            (if (and (eq (car value) -1)
 620                     (< (cdr value) 0))
 621                (cdr value)
 622              value)))
 623
 624         ((and (listp value)             ; (integer integer)
 625               (eq (length value) 2)
 626               (integerp (car value))
 627               (integerp (cadr value)))
 628          (if (eq (car value) 0)
 629              (cadr value)
 630            (if (and (eq (car value) -1)
 631                     (< (cdr value) 0))
 632                (- (cadr value))
 633              (cons (car value) (cadr value)))))
 634
 635         ((listp value)                  ; list
 636          (if (cdr value)
 637              (mapcar '(lambda (x)
 638                         (select-convert-from-integer selection type x))
 639                      value)
 640            (select-convert-from-integer selection type (car value))))
 641
 642         ((vectorp value)                ; vector
 643          (if (eq (length value) 1)
 644              (select-convert-from-integer selection type (aref value 0))
 645            (mapvector '(lambda (x)
 646                         (select-convert-from-integer selection type x))
 647                      value)))
 648
 649         (t nil)
 650         ))
 651
 652 (defun select-convert-to-atom (selection type value)
 653   (and (symbolp value) value))
 654
 655 ;;; CF_xxx conversions
 656 (defun select-convert-from-cf-text (selection type value)
 657   (replace-in-string (if (string-match "\0" value)
 658                          (substring value 0 (match-beginning 0))
 659                        value)
 660                      "\\(\r\n\\|\n\r\\)" "\n" t))
 661
 662 (defun select-convert-to-cf-text (selection type value)
 663   (let ((text (select-convert-to-text selection type value)))
 664     (concat (replace-in-string text "\n" "\r\n" t) "\0")))
 665
 666 ;;; Appenders
 667 (defun select-append-to-text (selection type value1 value2)
 668   (let ((text1 (select-convert-to-text selection 'STRING value1))
 669         (text2 (select-convert-to-text selection 'STRING value2)))
 670     (if (and text1 text2)
 671         (concat text1 text2)
 672       nil)))
 673
 674 (defun select-append-to-string (selection type value1 value2)
 675   (select-append-to-text selection type value1 value2))
 676
 677 (defun select-append-to-compound-text (selection type value1 value2)
 678   (select-append-to-text selection type value1 value2))
 679
 680 (defun select-append-to-cf-text (selection type value1 value2)
 681   (let ((text1 (select-convert-from-cf-text selection 'CF_TEXT value1))
 682         (text2 (select-convert-from-cf-text selection 'CF_TEXT value2)))
 683     (if (and text1 text2)
 684         (select-convert-to-cf-text selection type (concat text1 text2))
 685       nil)))
 686
 687 (defun select-append-default (selection type value1 value2)
 688 ;; This appender gets used if the type is "nil" - i.e. default.
 689 ;; It should probably have more cases implemented than it does - e.g.
 690 ;; appending numbers to strings, etc...
 691   (cond ((and (stringp value1) (stringp value2))
 692          (select-append-to-string selection 'STRING value1 value2))
 693         (t nil)))
 694
 695 ;;; Buffer kill handlers
 696
 697 ;; #### Should this function take the text *out* of the buffer that's
 698 ;; being killed? Or should it do what the original code did and just
 699 ;; destroy the selection?
 700 (defun select-buffer-killed-default (selection type value buffer)
 701 ;; This handler gets used if the type is "nil".
 702   (cond ((extentp value)
 703          (unless (eq (extent-object value) buffer)
 704            value))
 705         ((markerp value)
 706          (unless (eq (marker-buffer value) buffer)
 707            value))
 708         ((and (consp value)
 709               (markerp (car value))
 710               (markerp (cdr value)))
 711          (unless (or (eq (marker-buffer (car value)) buffer)
 712                      (eq (marker-buffer (cdr value)) buffer))
 713            value))
 714         (t value)))
 715
 716 (defun select-buffer-killed-text (selection type value buffer)
 717   (select-buffer-killed-default selection type value buffer))
 718
 719 ;; Types listed in here can be selections of XEmacs
 720 (setq selection-converter-out-alist
 721       '((TEXT . select-convert-to-text)
 722         (STRING . select-convert-to-string)
 723         (COMPOUND_TEXT . select-convert-to-compound-text)
 724         (TARGETS . select-convert-to-targets)
 725         (LENGTH . select-convert-to-length)
 726         (DELETE . select-convert-to-delete)
 727         (FILE_NAME . select-convert-to-filename)
 728         (CHARACTER_POSITION . select-convert-to-charpos)
 729         (SOURCE_LOC . select-convert-to-sourceloc)
 730         (LINE_NUMBER . select-convert-to-lineno)
 731         (COLUMN_NUMBER . select-convert-to-colno)
 732         (OWNER_OS . select-convert-to-os)
 733         (HOST_NAME . select-convert-to-host)
 734         (USER . select-convert-to-user)
 735         (CLASS . select-convert-to-class)
 736         (NAME . select-convert-to-name)
 737         (ATOM . select-convert-to-atom)
 738         (INTEGER . select-convert-to-integer)
 739         (CF_TEXT . select-convert-to-cf-text)
 740         ))
 741
 742 ;; Types listed here can be selections foreign to XEmacs
 743 (setq selection-converter-in-alist
 744       '(; Specific types that get handled by generic converters
 745         (COMPOUND_TEXT . select-convert-from-text)
 746         (SOURCE_LOC . select-convert-from-text)
 747         (OWNER_OS . select-convert-from-text)
 748         (HOST_NAME . select-convert-from-text)
 749         (USER . select-convert-from-text)
 750         (CLASS . select-convert-from-text)
 751         (NAME . select-convert-from-text)
 752         ; Generic types
 753         (INTEGER . select-convert-from-integer)
 754         (TEXT . select-convert-from-text)
 755         (STRING . select-convert-from-text)
 756         (LENGTH . select-convert-from-length)
 757         (FILE_NAME . select-convert-from-filename)
 758         (CF_TEXT . select-convert-from-cf-text)
 759         ))
 760
 761 ;; Types listed here can be appended by own-selection
 762 (setq selection-appender-alist
 763       '((nil . select-append-default)
 764         (TEXT . select-append-to-text)
 765         (STRING . select-append-to-string)
 766         (COMPOUND_TEXT . select-append-to-compound-text)
 767         (CF_TEXT . select-append-to-cf-text)
 768         ))
 769
 770 ;; Types listed here have buffer-kill handlers
 771 (setq selection-buffer-killed-alist
 772       '((nil . select-buffer-killed-default)
 773         (TEXT . select-buffer-killed-text)
 774         (STRING . select-buffer-killed-text)
 775         (COMPOUND_TEXT . select-buffer-killed-text)
 776         (CF_TEXT . select-buffer-killed-text)))
 777
 778 ;; Lists of types that are coercible (can be converted to other types)
 779 (setq selection-coercible-types '(TEXT STRING COMPOUND_TEXT))
 780
 781 ;;; select.el ends here