cgit.sxemacs.org Git - sxemacs/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: SXEmacs Development Team
   8 ;; Keywords: extensions, dumped
   9
  10 ;; This file is part of SXEmacs.
  11
  12 ;; SXEmacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; SXEmacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Synched up with: Not in FSF
  26
  27 ;;; Commentary:
  28
  29 ;; This file is dumped with SXEmacs
  30
  31 ;;; Code:
  32
  33 (defvar selected-text-type
  34   (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING)
  35   "The type atom used to obtain selections from the X server.
  36 Can be either a valid X selection data type, or a list of such types.
  37 COMPOUND_TEXT and STRING are the most commonly used data types.
  38 If a list is provided, the types are tried in sequence until
  39 there is a successful conversion.")
  40
  41 (defvar selection-sets-clipboard nil
  42   "Controls the selection's relationship to the clipboard.
  43 When non-nil, any operation that sets the primary selection will also
  44 set the clipboard.")
  45
  46 (defun copy-primary-selection ()
  47   "Copy the selection to the Clipboard and the kill ring."
  48   (interactive)
  49   (and (console-on-window-system-p)
  50        (cut-copy-clear-internal 'copy)))
  51
  52 (defun kill-primary-selection ()
  53   "Copy the selection to the Clipboard and the kill ring, then delete it."
  54   (interactive "*")
  55   (and (console-on-window-system-p)
  56        (cut-copy-clear-internal 'cut)))
  57
  58 (defun delete-primary-selection ()
  59   "Delete the selection without copying it to the Clipboard or the kill ring."
  60   (interactive "*")
  61   (and (console-on-window-system-p)
  62        (cut-copy-clear-internal 'clear)))
  63
  64 (defun yank-clipboard-selection ()
  65   "Insert the current Clipboard selection at point."
  66   (interactive "*")
  67   (when (console-on-window-system-p)
  68     (setq last-command nil)
  69     (setq this-command 'yank) ; so that yank-pop works.
  70     (let ((clip (get-clipboard)))
  71       (or clip (error "there is no clipboard selection"))
  72       (push-mark)
  73       (insert clip))))
  74
  75 (defun get-clipboard ()
  76   "Return text pasted to the clipboard.
  77 Not suitable for `interprogram-paste-function', use `get-clipboard-foreign'."
  78   (get-selection 'CLIPBOARD))
  79
  80 (defun get-clipboard-foreign ()
  81   "Return text pasted to the clipboard by another program.
  82 See `interprogram-paste-function' for more information."
  83   (get-selection-foreign 'CLIPBOARD))
  84
  85 (define-device-method get-cutbuffer
  86   "Return the value of one of the cut buffers.
  87 This will do nothing under anything other than X.")
  88
  89 (defun get-selection-no-error (&optional type data-type)
  90   "Return the value of a window-system selection.
  91 The argument TYPE (default `PRIMARY') says which selection,
  92 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
  93 says how to convert the data. Returns NIL if there is no selection."
  94   (condition-case nil (get-selection type data-type) (t nil)))
  95
  96 (defun get-selection (&optional type data-type)
  97   "Return the value of a window-system selection.
  98 The argument TYPE (default `PRIMARY') says which selection,
  99 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
 100 says how to convert the data. If there is no selection an error is signalled.
 101 Not suitable in a `interprogram-paste-function', q.v."
 102   (or type (setq type 'PRIMARY))
 103   (or data-type (setq data-type selected-text-type))
 104   (if (consp data-type)
 105       (condition-case err
 106           (get-selection-internal type (car data-type))
 107         (selection-conversion-error
 108          (if (cdr data-type)
 109              (get-selection type (cdr data-type))
 110            (signal (car err) (cdr err)))))
 111     (get-selection-internal type data-type)))
 112
 113 (defun get-selection-foreign (&optional type data-type)
 114   "Return the value of a window-system selection, or nil if SXEmacs owns it.
 115 The argument TYPE (default `PRIMARY') says which selection,
 116 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
 117 says how to convert the data. If there is no selection an error is signalled.
 118 See `interprogram-paste-function' for more information."
 119   (unless (selection-owner-p type)
 120     (get-selection type data-type)))
 121
 122 ;; FSFmacs calls this `x-set-selection', and reverses the
 123 ;; first two arguments (duh ...).  This order is more logical.
 124 (defun own-selection (data &optional type how-to-add data-type)
 125   "Make a window-system selection of type TYPE and value DATA.
 126 The argument TYPE (default `PRIMARY') says which selection,
 127 and DATA specifies the contents.  DATA may be any lisp data type
 128 that can be converted using the function corresponding to DATA-TYPE
 129 in `select-converter-alist'---strings are the usual choice, but
 130 other types may be permissible depending on the DATA-TYPE parameter
 131 (if DATA-TYPE is not supplied, the default behavior is window
 132 system specific, but strings are always accepted).
 133 HOW-TO-ADD may be any of the following:
 134
 135   'replace-all or nil -- replace all data in the selection.
 136   'replace-existing   -- replace data for specified DATA-TYPE only.
 137   'append or t        -- append data to existing DATA-TYPE data.
 138
 139 DATA-TYPE is the window-system specific data type identifier
 140 (see `register-selection-data-type' for more information).
 141
 142 The selection may also be a cons of two markers pointing to the same buffer,
 143 or an overlay.  In these cases, the selection is considered to be the text
 144 between the markers *at whatever time the selection is examined* (note
 145 that the window system clipboard does not necessarily duplicate this
 146 behavior).
 147 Thus, editing done in the buffer after you specify the selection
 148 can alter the effective value of the selection.
 149
 150 The data may also be a vector of valid non-vector selection values.
 151
 152 Interactively, the text of the region is used as the selection value."
 153   (interactive (if (not current-prefix-arg)
 154                    (list (read-string "Store text for pasting: "))
 155                  (list (substring (region-beginning) (region-end)))))
 156   ;; calling own-selection-internal will mess this up, so preserve it.
 157   (let ((zmacs-region-stays zmacs-region-stays))
 158                                         ;FSFmacs huh??  It says:
 159     ;; "This is for temporary compatibility with pre-release Emacs 19."
 160                                         ;(if (stringp type)
 161                                         ;    (setq type (intern type)))
 162     (or type (setq type 'PRIMARY))
 163     (if (null data)
 164         (disown-selection-internal type)
 165       (own-selection-internal type data how-to-add data-type)
 166       (when (and (eq type 'PRIMARY)
 167                  selection-sets-clipboard)
 168          (own-selection-internal 'CLIPBOARD data how-to-add data-type)))
 169     (cond ((eq type 'PRIMARY)
 170            (setq primary-selection-extent
 171                  (select-make-extent-for-selection
 172                   data primary-selection-extent)))
 173           ((eq type 'SECONDARY)
 174            (setq secondary-selection-extent
 175                  (select-make-extent-for-selection
 176                   data secondary-selection-extent)))))
 177   ;; zmacs-region-stays is for commands, not low-level functions.
 178   ;; when behaving as the latter, we better not set it, or we will
 179   ;; cause unwanted sticky-region behavior in kill-region and friends.
 180   (if (interactive-p)
 181   (setq zmacs-region-stays t))
 182   data)
 183
 184 (defun dehilight-selection (selection)
 185   "for use as a value of `lost-selection-hooks'."
 186   (cond ((eq selection 'PRIMARY)
 187          (if primary-selection-extent
 188              (let ((inhibit-quit t))
 189                (if (consp primary-selection-extent)
 190                    (mapcar 'delete-extent primary-selection-extent)
 191                  (delete-extent primary-selection-extent))
 192                (setq primary-selection-extent nil)))
 193          (if zmacs-regions (zmacs-deactivate-region)))
 194         ((eq selection 'SECONDARY)
 195          (if secondary-selection-extent
 196              (let ((inhibit-quit t))
 197                (if (consp secondary-selection-extent)
 198                    (mapcar 'delete-extent secondary-selection-extent)
 199                  (delete-extent secondary-selection-extent))
 200                (setq secondary-selection-extent nil)))))
 201   nil)
 202
 203 (setq lost-selection-hooks 'dehilight-selection)
 204
 205 (defun own-clipboard (string &optional push)
 206   "Paste the given string to the window system Clipboard.
 207 See `interprogram-cut-function' for more information."
 208   (own-selection string 'CLIPBOARD))
 209
 210 (defun disown-selection (&optional secondary-p)
 211   "Assuming we own the selection, disown it.
 212 With an argument, discard the secondary selection instead of the
 213 primary selection."
 214   (disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY))
 215   (when (and selection-sets-clipboard
 216              (or (not secondary-p)
 217                  (eq secondary-p 'PRIMARY)
 218                  (eq secondary-p 'CLIPBOARD)))
 219     (disown-selection-internal 'CLIPBOARD)))
 220
 221 ;; from x-init.el
 222 ;; selections and active regions
 223
 224 ;; If and only if zmacs-regions is true:
 225
 226 ;; When a mark is pushed and the region goes into the "active" state, we
 227 ;; assert it as the Primary selection.  This causes it to be hilighted.
 228 ;; When the region goes into the "inactive" state, we disown the Primary
 229 ;; selection, causing the region to be dehilighted.
 230
 231 ;; Note that it is possible for the region to be in the "active" state
 232 ;; and not be hilighted, if it is in the active state and then some other
 233 ;; application asserts the selection.  This is probably not a big deal.
 234
 235 (defun activate-region-as-selection ()
 236   (if (marker-buffer (mark-marker t))
 237       (own-selection (cons (point-marker t) (mark-marker t)))))
 238
 239 ; moved from x-select.el
 240 (defvar primary-selection-extent nil
 241   "The extent of the primary selection; don't use this.")
 242
 243 (defvar secondary-selection-extent nil
 244   "The extent of the secondary selection; don't use this.")
 245
 246 (defun select-make-extent-for-selection (selection previous-extent)
 247   ;; Given a selection, this makes an extent in the buffer which holds that
 248   ;; selection, for highlighting purposes.  If the selection isn't associated
 249   ;; with a buffer, this does nothing.
 250   (let ((buffer nil)
 251         (valid (and (extentp previous-extent)
 252                     (extent-object previous-extent)
 253                     (buffer-live-p (extent-object previous-extent))))
 254         start end)
 255     (cond ((stringp selection)
 256            ;; if we're selecting a string, lose the previous extent used
 257            ;; to highlight the selection.
 258            (setq valid nil))
 259           ((consp selection)
 260            (setq start (min (car selection) (cdr selection))
 261                  end (max (car selection) (cdr selection))
 262                  valid (and valid
 263                             (eq (marker-buffer (car selection))
 264                                 (extent-object previous-extent)))
 265                  buffer (marker-buffer (car selection))))
 266           ((extentp selection)
 267            (setq start (extent-start-position selection)
 268                  end (extent-end-position selection)
 269                  valid (and valid
 270                             (eq (extent-object selection)
 271                                 (extent-object previous-extent)))
 272                  buffer (extent-object selection)))
 273           (t
 274            (signal 'error (list "invalid selection" selection))))
 275
 276     (if valid
 277         nil
 278       (condition-case ()
 279           (if (listp previous-extent)
 280               (mapcar 'delete-extent previous-extent)
 281             (delete-extent previous-extent))
 282         (error nil)))
 283
 284     (if (not buffer)
 285         ;; string case
 286         nil
 287       ;; normal case
 288       (if valid
 289           (set-extent-endpoints previous-extent start end)
 290         (setq previous-extent (make-extent start end buffer))
 291
 292         ;; Make the extent be closed on the right, which means that if
 293         ;; characters are inserted exactly at the end of the extent, the
 294         ;; extent will grow to cover them.  This is important for shell
 295         ;; buffers - suppose one makes a selection, and one end is at
 296         ;; point-max.  If the shell produces output, that marker will remain
 297         ;; at point-max (its position will increase).  So it's important that
 298         ;; the extent exhibit the same behavior, lest the region covered by
 299         ;; the extent (the visual indication), and the region between point
 300         ;; and mark (the actual selection value) become different!
 301         (set-extent-property previous-extent 'end-open nil)
 302
 303         (cond
 304          (mouse-track-rectangle-p
 305           (setq previous-extent (list previous-extent))
 306           (default-mouse-track-next-move-rect start end previous-extent)
 307           ))
 308         previous-extent))))
 309
 310 ;; moved from x-select.el
 311 (defun valid-simple-selection-p (data)
 312   "An obsolete function that tests whether something was a valid simple
 313 selection using the old XEmacs selection support. You shouldn't use this
 314 any more, because just about anything could be a valid selection now."
 315   (or (stringp data)
 316       ;FSFmacs huh?? (symbolp data)
 317       (integerp data)
 318       (and (consp data)
 319            (integerp (car data))
 320            (or (integerp (cdr data))
 321                (and (consp (cdr data))
 322                     (integerp (car (cdr data))))))
 323       (extentp data)
 324       (and (consp data)
 325            (markerp (car data))
 326            (markerp (cdr data))
 327            (marker-buffer (car data))
 328            (marker-buffer (cdr data))
 329            (eq (marker-buffer (car data))
 330                (marker-buffer (cdr data)))
 331            (buffer-live-p (marker-buffer (car data)))
 332            (buffer-live-p (marker-buffer (cdr data))))))
 333
 334 (globally-declare-boundp 'killed-rectangle)
 335
 336 (defun cut-copy-clear-internal (mode)
 337   (or (memq mode '(cut copy clear)) (error "unknown mode %S" mode))
 338   (or (selection-owner-p)
 339       (error "SXEmacs does not own the primary selection"))
 340   (setq last-command nil)
 341   (or primary-selection-extent
 342       (error "the primary selection is not an extent?"))
 343   (save-excursion
 344     (let (rect-p b s e)
 345       (cond
 346        ((consp primary-selection-extent)
 347         (setq rect-p t
 348               b (extent-object (car primary-selection-extent))
 349               s (extent-start-position (car primary-selection-extent))
 350               e (extent-end-position (car (reverse primary-selection-extent)))))
 351        (t
 352         (setq rect-p nil
 353               b (extent-object primary-selection-extent)
 354               s (extent-start-position primary-selection-extent)
 355               e (extent-end-position primary-selection-extent))))
 356       (set-buffer b)
 357       (cond ((memq mode '(cut copy))
 358              (if rect-p
 359                  (progn
 360                    ;; why is killed-rectangle free?  Is it used somewhere?
 361                    ;; should it be defvarred?
 362                    (setq killed-rectangle (declare-fboundp (extract-rectangle s e)))
 363                    (kill-new (mapconcat #'identity killed-rectangle "\n")))
 364                (copy-region-as-kill s e))
 365              ;; Maybe killing doesn't own clipboard.  Make sure it happens.
 366              ;; This memq is kind of grody, because they might have done it
 367              ;; some other way, but owning the clipboard twice in that case
 368              ;; wouldn't actually hurt anything.
 369              (or (and (consp kill-hooks) (memq 'own-clipboard kill-hooks))
 370                  (own-clipboard (car kill-ring)))))
 371       (cond ((memq mode '(cut clear))
 372              (if rect-p
 373                  (declare-fboundp (delete-rectangle s e))
 374                (delete-region s e))))
 375       (disown-selection nil)
 376       )))
 377
 378 \f
 379 ;;; Functions to convert the selection into various other selection
 380 ;;; types.
 381
 382 ;; These next three functions get called by C code...
 383 (defun select-convert-in (selection type value)
 384   "Attempt to convert the specified external VALUE to the specified DATA-TYPE,
 385 for the specified SELECTION. Return nil if this is impossible, or a
 386 suitable internal representation otherwise."
 387   (when value
 388     (let ((handler-fn (cdr (assq type selection-converter-in-alist))))
 389       (if handler-fn
 390           (apply handler-fn (list selection type value))
 391         value))))
 392
 393 (defun select-convert-out (selection type value)
 394   "Attempt to convert the specified internal VALUE for the specified DATA-TYPE
 395 and SELECTION. Return nil if this is impossible, or a suitable external
 396 representation otherwise."
 397   (when value
 398     (let ((handler-fn (cdr (assq type selection-converter-out-alist))))
 399       (when handler-fn
 400         (apply handler-fn (list selection type value))))))
 401
 402 (defun select-coerce (selection type value)
 403   "Attempt to convert the specified internal VALUE to a representation
 404 suitable for return from `get-selection' in the specified DATA-TYPE. Return
 405 nil if this is impossible, or a suitable representation otherwise."
 406   (when value
 407     (let ((handler-fn (cdr (assq type selection-coercion-alist))))
 408       (when handler-fn
 409         (apply handler-fn (list selection type value))))))
 410
 411 ;; The rest of the functions on this "page" are conversion handlers,
 412 ;; append handlers and buffer-kill handlers.
 413 (defun select-convert-to-text (selection type value)
 414   (cond ((stringp value)
 415          value)
 416         ((extentp value)
 417          (save-excursion
 418            (set-buffer (extent-object value))
 419            (save-restriction
 420              (widen)
 421              (buffer-substring (extent-start-position value)
 422                                (extent-end-position value)))))
 423         ((and (consp value)
 424               (markerp (car value))
 425               (markerp (cdr value)))
 426          (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
 427              (signal 'error
 428                      (list "markers must be in the same buffer"
 429                            (car value) (cdr value))))
 430          (save-excursion
 431            (set-buffer (or (marker-buffer (car value))
 432                            (error "selection is in a killed buffer")))
 433            (save-restriction
 434              (widen)
 435              (buffer-substring (car value) (cdr value)))))
 436         (t nil)))
 437
 438 (defun select-coerce-to-text (selection type value)
 439   (select-convert-to-text selection type value))
 440
 441 (defun select-convert-to-string (selection type value)
 442   (let ((outval (select-convert-to-text selection type value)))
 443     ;; force the string to be not in Compound Text format. This grubby
 444     ;; hack will go soon, to be replaced by a more general mechanism.
 445     (if (stringp outval)
 446         (cons 'STRING outval)
 447       outval)))
 448
 449 (defun select-convert-to-compound-text (selection type value)
 450   ;; converts to compound text automatically
 451   (select-convert-to-text selection type value))
 452
 453 (defun select-convert-to-length (selection type value)
 454   (let ((value
 455          (cond ((stringp value)
 456                 (length value))
 457                ((extentp value)
 458                 (extent-length value))
 459                ((and (consp value)
 460                      (markerp (car value))
 461                      (markerp (cdr value)))
 462                 (or (eq (marker-buffer (car value))
 463                         (marker-buffer (cdr value)))
 464                     (signal 'error
 465                             (list "markers must be in the same buffer"
 466                                   (car value) (cdr value))))
 467                 (abs (- (car value) (cdr value)))))))
 468     (if value ; force it to be in 32-bit format.
 469         (cons (ash value -16) (logand value 65535))
 470       nil)))
 471
 472 (defun select-convert-to-targets (selection type value)
 473   ;; return a vector of atoms, but remove duplicates first.
 474   (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
 475          (rest all))
 476     (while rest
 477       (cond ((memq (car rest) (cdr rest))
 478              (setcdr rest (delq (car rest) (cdr rest))))
 479             (t
 480              (setq rest (cdr rest)))))
 481     (apply 'vector all)))
 482
 483 (defun select-convert-to-delete (selection type value)
 484   (disown-selection-internal selection)
 485   ;; A return value of nil means that we do not know how to do this conversion,
 486   ;; and replies with an "error".  A return value of NULL means that we have
 487   ;; done the conversion (and any side-effects) but have no value to return.
 488   'NULL)
 489
 490 (defun select-convert-to-filename (selection type value)
 491   (cond ((extentp value)
 492          (buffer-file-name (or (extent-object value)
 493                                (error "selection is in a killed buffer"))))
 494         ((and (consp value)
 495               (markerp (car value))
 496               (markerp (cdr value)))
 497          (buffer-file-name (or (marker-buffer (car value))
 498                                (error "selection is in a killed buffer"))))
 499         (t nil)))
 500
 501 (defun select-convert-to-charpos (selection type value)
 502   (let (a b tmp)
 503     (cond ((cond ((extentp value)
 504                   (setq a (extent-start-position value)
 505                         b (extent-end-position value)))
 506                  ((and (consp value)
 507                        (markerp (car value))
 508                        (markerp (cdr value)))
 509                   (setq a (car value)
 510                         b (cdr value))))
 511            (setq a (1- a) b (1- b)) ; zero-based
 512            (if (< b a) (setq tmp a a b b tmp))
 513            (cons 'SPAN
 514                  (vector (cons (ash a -16) (logand a 65535))
 515                          (cons (ash b -16) (logand b 65535))))))))
 516
 517 (defun select-convert-to-lineno (selection type value)
 518   (let (a b buf tmp)
 519     (cond ((cond ((extentp value)
 520                   (setq buf (extent-object value)
 521                         a (extent-start-position value)
 522                         b (extent-end-position value)))
 523                  ((and (consp value)
 524                        (markerp (car value))
 525                        (markerp (cdr value)))
 526                   (setq a (marker-position (car value))
 527                         b (marker-position (cdr value))
 528                         buf (marker-buffer (car value)))))
 529            (save-excursion
 530              (set-buffer buf)
 531              (save-restriction
 532                (widen)
 533                (goto-char a)
 534                (beginning-of-line)
 535                (setq a (1+ (count-lines 1 (point))))
 536                (goto-char b)
 537                (beginning-of-line)
 538                (setq b (1+ (count-lines 1 (point))))))
 539            (if (< b a) (setq tmp a a b b tmp))
 540            (cons 'SPAN
 541                  (vector (cons (ash a -16) (logand a 65535))
 542                          (cons (ash b -16) (logand b 65535))))))))
 543
 544 (defun select-convert-to-colno (selection type value)
 545   (let (a b buf tmp)
 546     (cond ((cond ((extentp value)
 547                   (setq buf (extent-object value)
 548                         a (extent-start-position value)
 549                         b (extent-end-position value)))
 550                  ((and (consp value)
 551                        (markerp (car value))
 552                        (markerp (cdr value)))
 553                   (setq a (car value)
 554                         b (cdr value)
 555                         buf (marker-buffer a))))
 556            (save-excursion
 557              (set-buffer buf)
 558              (goto-char a)
 559              (setq a (current-column))
 560              (goto-char b)
 561              (setq b (current-column)))
 562            (if (< b a) (setq tmp a a b b tmp))
 563            (cons 'SPAN
 564                  (vector (cons (ash a -16) (logand a 65535))
 565                          (cons (ash b -16) (logand b 65535))))))))
 566
 567 (defun select-convert-to-sourceloc (selection type value)
 568   (let (a b buf file-name tmp)
 569     (cond ((cond ((extentp value)
 570                   (setq buf (or (extent-object value)
 571                                 (error "selection is in a killed buffer"))
 572                         a (extent-start-position value)
 573                         b (extent-end-position value)
 574                         file-name (buffer-file-name buf)))
 575                  ((and (consp value)
 576                        (markerp (car value))
 577                        (markerp (cdr value)))
 578                   (setq a (marker-position (car value))
 579                         b (marker-position (cdr value))
 580                         buf (or (marker-buffer (car value))
 581                                 (error "selection is in a killed buffer"))
 582                         file-name (buffer-file-name buf))))
 583            (save-excursion
 584              (set-buffer buf)
 585              (save-restriction
 586                (widen)
 587                (goto-char a)
 588                (beginning-of-line)
 589                (setq a (1+ (count-lines 1 (point))))
 590                (goto-char b)
 591                (beginning-of-line)
 592                (setq b (1+ (count-lines 1 (point))))))
 593            (if (< b a) (setq tmp a a b b tmp))
 594            (format "%s:%d" file-name a)))))
 595
 596 (defun select-convert-to-os (selection type size)
 597   (symbol-name system-type))
 598
 599 (defun select-convert-to-host (selection type size)
 600   (system-name))
 601
 602 (defun select-convert-to-user (selection type size)
 603   (user-full-name))
 604
 605 (defun select-convert-to-class (selection type size)
 606   (symbol-value 'x-emacs-application-class))
 607
 608 ;; We do not try to determine the name Emacs was invoked with,
 609 ;; because it is not clean for a program's behavior to depend on that.
 610 (defun select-convert-to-name (selection type size)
 611   ;invocation-name
 612   "sxemacs")
 613
 614 (defun select-convert-to-integer (selection type value)
 615   (and (integerp value)
 616        (cons (ash value -16) (logand value 65535))))
 617
 618 ;; Can convert from the following integer representations
 619 ;;
 620 ;;    integer
 621 ;;    (integer . integer)
 622 ;;    (integer integer)
 623 ;;    (list [integer|(integer . integer)]*)
 624 ;;    (vector [integer|(integer . integer)]*)
 625 ;;
 626 ;; Cons'd integers get cleaned up a little.
 627
 628 (defun select-convert-from-integer (selection type value)
 629   (cond ((integerp value)               ; Integer
 630          value)
 631
 632         ((and (consp value)             ; (integer . integer)
 633               (integerp (car value))
 634               (integerp (cdr value)))
 635          (if (eq (car value) 0)
 636              (cdr value)
 637            (if (and (eq (car value) -1)
 638                     (< (cdr value) 0))
 639                (cdr value)
 640              value)))
 641
 642         ((and (listp value)             ; (integer integer)
 643               (eq (length value) 2)
 644               (integerp (car value))
 645               (integerp (cadr value)))
 646          (if (eq (car value) 0)
 647              (cadr value)
 648            (if (and (eq (car value) -1)
 649                     (< (cdr value) 0))
 650                (- (cadr value))
 651              (cons (car value) (cadr value)))))
 652
 653         ((listp value)                  ; list
 654          (if (cdr value)
 655              (mapcar '(lambda (x)
 656                         (select-convert-from-integer selection type x))
 657                      value)
 658            (select-convert-from-integer selection type (car value))))
 659
 660         ((vectorp value)                ; vector
 661          (if (eq (length value) 1)
 662              (select-convert-from-integer selection type (aref value 0))
 663            (mapvector '(lambda (x)
 664                         (select-convert-from-integer selection type x))
 665                      value)))
 666
 667         (t nil)
 668         ))
 669
 670 (defun select-convert-from-ip-address (selection type value)
 671   (if (and (stringp value)
 672            (= (length value) 4))
 673       (format "%d.%d.%d.%d"
 674               (aref value 0) (aref value 1) (aref value 2) (aref value 3))))
 675
 676 (defun select-convert-to-atom (selection type value)
 677   (and (symbolp value) value))
 678
 679 (defun select-convert-from-utf8-text (selection type value)
 680   (require 'un-define)
 681   (decode-coding-string value 'utf-8))
 682
 683 (defun select-convert-from-utf16-le-text (selection type value)
 684   (require 'un-define)
 685   (decode-coding-string value 'utf-16-le))
 686
 687 ;;; CF_xxx conversions
 688 (defun select-convert-from-cf-text (selection type value)
 689   (replace-in-string (if (string-match "\0" value)
 690                          (substring value 0 (match-beginning 0))
 691                        value)
 692                      "\\(\r\n\\|\n\r\\)" "\n" t))
 693
 694 (defun select-convert-to-cf-text (selection type value)
 695   (let ((text (select-convert-to-text selection type value)))
 696     (concat (replace-in-string text "\n" "\r\n" t) "\0")))
 697
 698 ;;; Appenders
 699 (defun select-append-to-text (selection type value1 value2)
 700   (let ((text1 (select-convert-to-text selection 'STRING value1))
 701         (text2 (select-convert-to-text selection 'STRING value2)))
 702     (if (and text1 text2)
 703         (concat text1 text2)
 704       nil)))
 705
 706 (defun select-append-to-string (selection type value1 value2)
 707   (select-append-to-text selection type value1 value2))
 708
 709 (defun select-append-to-compound-text (selection type value1 value2)
 710   (select-append-to-text selection type value1 value2))
 711
 712 (defun select-append-to-cf-text (selection type value1 value2)
 713   (let ((text1 (select-convert-from-cf-text selection 'CF_TEXT value1))
 714         (text2 (select-convert-from-cf-text selection 'CF_TEXT value2)))
 715     (if (and text1 text2)
 716         (select-convert-to-cf-text selection type (concat text1 text2))
 717       nil)))
 718
 719 (defun select-append-default (selection type value1 value2)
 720 ;; This appender gets used if the type is "nil" - i.e. default.
 721 ;; It should probably have more cases implemented than it does - e.g.
 722 ;; appending numbers to strings, etc...
 723   (cond ((and (stringp value1) (stringp value2))
 724          (select-append-to-string selection 'STRING value1 value2))
 725         (t nil)))
 726
 727 ;;; Buffer kill handlers
 728
 729 (defun select-buffer-killed-default (selection type value buffer)
 730 ;; This handler gets used if the type is "nil".
 731   (cond ((extentp value)
 732          (if (eq (extent-object value) buffer)
 733              ; If this selection is on the clipboard, grab it quick
 734              (when (eq selection 'CLIPBOARD)
 735                (save-excursion
 736                  (set-buffer (extent-object value))
 737                  (save-restriction
 738                   (widen)
 739                   (buffer-substring (extent-start-position value)
 740                                     (extent-end-position value)))))
 741            value))
 742         ((markerp value)
 743          (unless (eq (marker-buffer value) buffer)
 744            value))
 745         ((and (consp value)
 746               (markerp (car value))
 747               (markerp (cdr value)))
 748          (if (or (eq (marker-buffer (car value)) buffer)
 749                  (eq (marker-buffer (cdr value)) buffer))
 750              ; If this selection is on the clipboard, grab it quick
 751              (when (eq selection 'CLIPBOARD)
 752                (save-excursion
 753                  (set-buffer (marker-buffer (car value)))
 754                  (save-restriction
 755                    (widen)
 756                    (buffer-substring (car value) (cdr value)))))
 757              value))
 758         (t value)))
 759
 760 (defun select-buffer-killed-text (selection type value buffer)
 761   (select-buffer-killed-default selection type value buffer))
 762
 763 ;; Types listed in here can be selections of SXEmacs
 764 (setq selection-converter-out-alist
 765       '((TEXT . select-convert-to-text)
 766         (STRING . select-convert-to-string)
 767         (COMPOUND_TEXT . select-convert-to-compound-text)
 768         (TARGETS . select-convert-to-targets)
 769         (LENGTH . select-convert-to-length)
 770         (DELETE . select-convert-to-delete)
 771         (FILE_NAME . select-convert-to-filename)
 772         (CHARACTER_POSITION . select-convert-to-charpos)
 773         (SOURCE_LOC . select-convert-to-sourceloc)
 774         (LINE_NUMBER . select-convert-to-lineno)
 775         (COLUMN_NUMBER . select-convert-to-colno)
 776         (OWNER_OS . select-convert-to-os)
 777         (HOST_NAME . select-convert-to-host)
 778         (USER . select-convert-to-user)
 779         (CLASS . select-convert-to-class)
 780         (NAME . select-convert-to-name)
 781         (ATOM . select-convert-to-atom)
 782         (INTEGER . select-convert-to-integer)
 783         (CF_TEXT . select-convert-to-cf-text)
 784         ))
 785
 786 ;; Types listed here can be selections foreign to SXEmacs
 787 ;; the default is to return the raw data (works for strings and atoms)
 788 (setq selection-converter-in-alist
 789       '((INTEGER . select-convert-from-integer)
 790         (TIMESTAMP . select-convert-from-integer)
 791         (LENGTH . select-convert-from-integer)
 792         (LIST_LENGTH . select-convert-from-integer)
 793         (CLIENT_WINDOW . select-convert-from-integer)
 794         (PROCESS . select-convert-from-integer)
 795         (IP_ADDRESS . select-convert-from-ip-address)
 796         (CF_TEXT . select-convert-from-cf-text)
 797         (UTF8_STRING . select-convert-from-utf8-text)
 798         (text/html . select-convert-from-utf16-le-text)  ; Mozilla
 799         (text/_moz_htmlcontext . select-convert-from-utf16-le-text)
 800         (text/_moz_htmlinfo . select-convert-from-utf16-le-text)
 801         ))
 802
 803 ;; Types listed here have special coercion functions that can munge
 804 ;; other types. This can also be used to add special features - e.g.
 805 ;; being able to pass a region or a cons of markers to own-selection,
 806 ;; but getting the *current* text in the region back when calling
 807 ;; get-selection.
 808 ;;
 809 ;; Any function listed in here *will be called* whenever a value of
 810 ;; its type is retrieved from the internal selection cache, or when
 811 ;; no suitable values could be found in which case SXEmacs looks for
 812 ;; values with types listed in selection-coercible-types.
 813 (setq selection-coercion-alist
 814       '((TEXT . select-coerce-to-text)
 815         (STRING . select-coerce-to-text)
 816         (COMPOUND_TEXT . select-coerce-to-text)
 817         (CF_TEXT . select-coerce-to-text)))
 818
 819 ;; Types listed here can be appended by own-selection
 820 (setq selection-appender-alist
 821       '((nil . select-append-default)
 822         (TEXT . select-append-to-text)
 823         (STRING . select-append-to-string)
 824         (COMPOUND_TEXT . select-append-to-compound-text)
 825         (CF_TEXT . select-append-to-cf-text)
 826         ))
 827
 828 ;; Types listed here have buffer-kill handlers
 829 (setq selection-buffer-killed-alist
 830       '((nil . select-buffer-killed-default)
 831         (TEXT . select-buffer-killed-text)
 832         (STRING . select-buffer-killed-text)
 833         (COMPOUND_TEXT . select-buffer-killed-text)
 834         (CF_TEXT . select-buffer-killed-text)))
 835
 836 ;; Lists of types that are coercible (can be converted to other types)
 837 (setq selection-coercible-types '(TEXT STRING COMPOUND_TEXT))
 838
 839 ;;; select.el ends here