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