git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/x-select.el

   1 ;;; x-select.el --- Lisp interface to X Selections.
   2
   3 ;; Copyright (C) 1990, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995 Sun Microsystems.
   5
   6 ;; Maintainer: XEmacs Development Team
   7 ;; Keywords: extensions, dumped
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Synched up with: FSF 19.30 (select.el).
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with XEmacs (when X support is compiled in).
  31
  32 ;; The selection code requires us to use certain symbols whose names are
  33 ;; all upper-case; this may seem tasteless, but it makes there be a 1:1
  34 ;; correspondence between these symbols and X Atoms (which are upcased).
  35
  36 ;;; Code:
  37
  38 (defvar x-selected-text-type
  39   (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING)
  40   "The type atom used to obtain selections from the X server.
  41 Can be either a valid X selection data type, or a list of such types.
  42 COMPOUND_TEXT and STRING are the most commonly used data types.
  43 If a list is provided, the types are tried in sequence until
  44 there is a successful conversion.")
  45
  46 (defun x-get-selection (&optional type data-type)
  47   "Return the value of an X Windows selection.
  48 The argument TYPE (default `PRIMARY') says which selection,
  49 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
  50 says how to convert the data."
  51   (or type (setq type 'PRIMARY))
  52   (or data-type (setq data-type x-selected-text-type))
  53   (let ((text
  54          (if (consp data-type)
  55              (condition-case err
  56                  (x-get-selection-internal type (car data-type))
  57                (selection-conversion-error
  58                 (if (cdr data-type)
  59                     (x-get-selection type (cdr data-type))
  60                   (signal (car err) (cdr err)))))
  61            (x-get-selection-internal type data-type))))
  62     (when (and (consp text) (symbolp (car text)))
  63       (setq text (cdr text)))
  64     (when (not (stringp text))
  65       (error "Selection is not a string: %S" text))
  66     text))
  67
  68 (defun x-get-secondary-selection ()
  69   "Return text selected from some X window."
  70   (x-get-selection 'SECONDARY))
  71
  72 (defun x-get-clipboard ()
  73   "Return text pasted to the clipboard."
  74   (x-get-selection 'CLIPBOARD))
  75
  76 ;; FSFmacs calls this `x-set-selection', and reverses the
  77 ;; arguments (duh ...).  This order is more logical.
  78 (defun x-own-selection (data &optional type)
  79   "Make an X Windows selection of type TYPE and value DATA.
  80 The argument TYPE (default `PRIMARY') says which selection,
  81 and DATA specifies the contents.  DATA may be a string,
  82 a symbol, an integer (or a cons of two integers or list of two integers).
  83
  84 The selection may also be a cons of two markers pointing to the same buffer,
  85 or an overlay.  In these cases, the selection is considered to be the text
  86 between the markers *at whatever time the selection is examined*.
  87 Thus, editing done in the buffer after you specify the selection
  88 can alter the effective value of the selection.
  89
  90 The data may also be a vector of valid non-vector selection values.
  91
  92 Interactively, the text of the region is used as the selection value."
  93   (interactive (if (not current-prefix-arg)
  94                    (list (read-string "Store text for pasting: "))
  95                  (list (substring (region-beginning) (region-end)))))
  96   ;FSFmacs huh??  It says:
  97   ;; "This is for temporary compatibility with pre-release Emacs 19."
  98   ;(if (stringp type)
  99   ;    (setq type (intern type)))
 100   (or (x-valid-simple-selection-p data)
 101       (and (vectorp data)
 102            (let ((valid t)
 103                  (i (1- (length data))))
 104              (while (>= i 0)
 105                (or (x-valid-simple-selection-p (aref data i))
 106                    (setq valid nil))
 107                (setq i (1- i)))
 108              valid))
 109       (signal 'error (list "invalid selection" data)))
 110   (or type (setq type 'PRIMARY))
 111   (if data
 112       (x-own-selection-internal type data)
 113     (x-disown-selection-internal type))
 114   (cond ((eq type 'PRIMARY)
 115          (setq primary-selection-extent
 116                (select-make-extent-for-selection
 117                 data primary-selection-extent)))
 118         ((eq type 'SECONDARY)
 119          (setq secondary-selection-extent
 120                (select-make-extent-for-selection
 121                 data secondary-selection-extent))))
 122   (setq zmacs-region-stays t)
 123   data)
 124
 125 (defun x-valid-simple-selection-p (data)
 126   (valid-simple-selection-p data))
 127
 128 (defun x-own-secondary-selection (selection &optional type)
 129   "Make a secondary X Selection of the given argument.  The argument may be a
 130 string or a cons of two markers (in which case the selection is considered to
 131 be the text between those markers)."
 132   (interactive (if (not current-prefix-arg)
 133                    (list (read-string "Store text for pasting: "))
 134                  (list (cons ;; these need not be ordered.
 135                         (copy-marker (point-marker))
 136                         (copy-marker (mark-marker))))))
 137   (x-own-selection selection 'SECONDARY))
 138
 139
 140 (defun x-own-clipboard (string)
 141   "Paste the given string to the X Clipboard."
 142   (x-own-selection string 'CLIPBOARD))
 143
 144
 145 (defun x-disown-selection (&optional secondary-p)
 146   "Assuming we own the selection, disown it.  With an argument, discard the
 147 secondary selection instead of the primary selection."
 148   (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
 149
 150 (defun x-dehilight-selection (selection)
 151   "for use as a value of `x-lost-selection-hooks'."
 152   (cond ((eq selection 'PRIMARY)
 153          (if primary-selection-extent
 154              (let ((inhibit-quit t))
 155                (if (consp primary-selection-extent)
 156                    (mapcar 'delete-extent primary-selection-extent)
 157                  (delete-extent primary-selection-extent))
 158                (setq primary-selection-extent nil)))
 159          (if zmacs-regions (zmacs-deactivate-region)))
 160         ((eq selection 'SECONDARY)
 161          (if secondary-selection-extent
 162              (let ((inhibit-quit t))
 163                (if (consp secondary-selection-extent)
 164                    (mapcar 'delete-extent secondary-selection-extent)
 165                  (delete-extent secondary-selection-extent))
 166                (setq secondary-selection-extent nil)))))
 167   nil)
 168
 169 (setq x-lost-selection-hooks 'x-dehilight-selection)
 170
 171 (defun x-notice-selection-requests (selection type successful)
 172   "for possible use as the value of x-sent-selection-hooks."
 173   (if (not successful)
 174       (message "Selection request failed to convert %s to %s"
 175                selection type)
 176     (message "Sent selection %s as %s" selection type)))
 177
 178 (defun x-notice-selection-failures (selection type successful)
 179   "for possible use as the value of x-sent-selection-hooks."
 180   (or successful
 181       (message "Selection request failed to convert %s to %s"
 182                selection type)))
 183
 184 ;(setq x-sent-selection-hooks 'x-notice-selection-requests)
 185 ;(setq x-sent-selection-hooks 'x-notice-selection-failures)
 186
 187 \f
 188 ;;; Selections in killed buffers
 189 ;;; this function is called by kill-buffer as if it were on the
 190 ;;; kill-buffer-hook (though it isn't really).
 191
 192 (defun xselect-kill-buffer-hook ()
 193   ;; Probably the right thing is to write a C function to return a list
 194   ;; of the selections which emacs owns, since it could conceivably own
 195   ;; a user-defined selection type that we've never heard of.
 196   (xselect-kill-buffer-hook-1 'PRIMARY)
 197   (xselect-kill-buffer-hook-1 'SECONDARY)
 198   (xselect-kill-buffer-hook-1 'CLIPBOARD))
 199
 200 (defun xselect-kill-buffer-hook-1 (selection)
 201   (let (value)
 202     (if (and (x-selection-owner-p selection)
 203              (setq value (x-get-selection-internal selection '_EMACS_INTERNAL))
 204              ;; The _EMACS_INTERNAL selection type has a converter registered
 205              ;; for it that does no translation.  This only works if emacs is
 206              ;; requesting the selection from itself.  We could have done this
 207              ;; by writing a C function to return the raw selection data, and
 208              ;; that might be the right way to do this, but this was easy.
 209              (or (and (consp value)
 210                       (markerp (car value))
 211                       (eq (current-buffer) (marker-buffer (car value))))
 212                  (and (extent-live-p value)
 213                       (eq (current-buffer) (extent-object value)))
 214                  (and (extentp value) (not (extent-live-p value)))))
 215         (x-disown-selection-internal selection))))
 216
 217 \f
 218 ;;; Cut Buffer support
 219
 220 ;;; FSF name x-get-cut-buffer
 221 (defun x-get-cutbuffer (&optional which-one)
 222   "Return the value of one of the 8 X server cut buffers.
 223 Optional arg WHICH-ONE should be a number from 0 to 7, defaulting to 0.
 224 Cut buffers are considered obsolete; you should use selections instead.
 225 This function does nothing if support for cut buffers was not compiled
 226 into Emacs."
 227   (and (fboundp 'x-get-cutbuffer-internal)
 228        (x-get-cutbuffer-internal
 229         (if which-one
 230             (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3
 231                                CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7]
 232                   which-one)
 233           'CUT_BUFFER0))))
 234
 235 ;;; FSF name x-set-cut-buffer
 236 (defun x-store-cutbuffer (string &optional push)
 237   "Store STRING into the X server's primary cut buffer.
 238 If PUSH is non-nil, also rotate the cut buffers:
 239 this means the previous value of the primary cut buffer moves the second
 240 cut buffer, and the second to the third, and so on (there are 8 buffers.)
 241 Cut buffers are considered obsolete; you should use selections instead.
 242 This function does nothing if support for cut buffers was not compiled
 243 into Emacs."
 244   (and (fboundp 'x-store-cutbuffer-internal)
 245        (progn
 246          ;; Check the data type of STRING.
 247          (substring string 0 0)
 248          (if push
 249              (x-rotate-cutbuffers-internal 1))
 250          (x-store-cutbuffer-internal 'CUT_BUFFER0 string))))
 251
 252 \f
 253 ;;; Random utility functions
 254
 255 (defun x-yank-clipboard-selection ()
 256   "Insert the current Clipboard selection at point."
 257   (interactive "*")
 258   (setq last-command nil)
 259   (setq this-command 'yank) ; so that yank-pop works.
 260   (let ((clip (x-get-clipboard)))
 261     (or clip (error "there is no clipboard selection"))
 262     (push-mark)
 263     (insert clip)))
 264 \f
 265 ;;; Functions to convert the selection into various other selection types.
 266 ;;; Every selection type that emacs handles is implemented this way, except
 267 ;;; for TIMESTAMP, which is a special case.
 268
 269 (defun xselect-convert-to-text (selection type value)
 270   (cond ((stringp value)
 271          value)
 272         ((extentp value)
 273          (save-excursion
 274            (set-buffer (extent-object value))
 275            (save-restriction
 276              (widen)
 277              (buffer-substring (extent-start-position value)
 278                                (extent-end-position value)))))
 279         ((and (consp value)
 280               (markerp (car value))
 281               (markerp (cdr value)))
 282          (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
 283              (signal 'error
 284                      (list "markers must be in the same buffer"
 285                            (car value) (cdr value))))
 286          (save-excursion
 287            (set-buffer (or (marker-buffer (car value))
 288                            (error "selection is in a killed buffer")))
 289            (save-restriction
 290              (widen)
 291              (buffer-substring (car value) (cdr value)))))
 292         (t nil)))
 293
 294 (defun xselect-convert-to-string (selection type value)
 295   (let ((outval (xselect-convert-to-text selection type value)))
 296     ;; force the string to be not in Compound Text format.
 297     (if (stringp outval)
 298         (cons 'STRING outval)
 299       outval)))
 300
 301 (defun xselect-convert-to-compound-text (selection type value)
 302   ;; converts to compound text automatically
 303   (xselect-convert-to-text selection type value))
 304
 305 (defun xselect-convert-to-length (selection type value)
 306   (let ((value
 307          (cond ((stringp value)
 308                 (length value))
 309                ((extentp value)
 310                 (extent-length value))
 311                ((and (consp value)
 312                      (markerp (car value))
 313                      (markerp (cdr value)))
 314                 (or (eq (marker-buffer (car value))
 315                         (marker-buffer (cdr value)))
 316                     (signal 'error
 317                             (list "markers must be in the same buffer"
 318                                   (car value) (cdr value))))
 319                 (abs (- (car value) (cdr value)))))))
 320     (if value ; force it to be in 32-bit format.
 321         (cons (ash value -16) (logand value 65535))
 322       nil)))
 323
 324 (defun xselect-convert-to-targets (selection type value)
 325   ;; return a vector of atoms, but remove duplicates first.
 326   (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
 327          (rest all))
 328     (while rest
 329       (cond ((memq (car rest) (cdr rest))
 330              (setcdr rest (delq (car rest) (cdr rest))))
 331             ((eq (car (cdr rest)) '_EMACS_INTERNAL)  ; shh, it's a secret
 332              (setcdr rest (cdr (cdr rest))))
 333             (t
 334              (setq rest (cdr rest)))))
 335     (apply 'vector all)))
 336
 337 (defun xselect-convert-to-delete (selection type value)
 338   (x-disown-selection-internal selection)
 339   ;; A return value of nil means that we do not know how to do this conversion,
 340   ;; and replies with an "error".  A return value of NULL means that we have
 341   ;; done the conversion (and any side-effects) but have no value to return.
 342   'NULL)
 343
 344 (defun xselect-convert-to-filename (selection type value)
 345   (cond ((extentp value)
 346          (buffer-file-name (or (extent-object value)
 347                                (error "selection is in a killed buffer"))))
 348         ((and (consp value)
 349               (markerp (car value))
 350               (markerp (cdr value)))
 351          (buffer-file-name (or (marker-buffer (car value))
 352                                (error "selection is in a killed buffer"))))
 353         (t nil)))
 354
 355 (defun xselect-convert-to-charpos (selection type value)
 356   (let (a b tmp)
 357     (cond ((cond ((extentp value)
 358                   (setq a (extent-start-position value)
 359                         b (extent-end-position value)))
 360                  ((and (consp value)
 361                        (markerp (car value))
 362                        (markerp (cdr value)))
 363                   (setq a (car value)
 364                         b (cdr value))))
 365            (setq a (1- a) b (1- b)) ; zero-based
 366            (if (< b a) (setq tmp a a b b tmp))
 367            (cons 'SPAN
 368                  (vector (cons (ash a -16) (logand a 65535))
 369                          (cons (ash b -16) (logand b 65535))))))))
 370
 371 (defun xselect-convert-to-lineno (selection type value)
 372   (let (a b buf tmp)
 373     (cond ((cond ((extentp value)
 374                   (setq buf (extent-object value)
 375                         a (extent-start-position value)
 376                         b (extent-end-position value)))
 377                  ((and (consp value)
 378                        (markerp (car value))
 379                        (markerp (cdr value)))
 380                   (setq a (marker-position (car value))
 381                         b (marker-position (cdr value))
 382                         buf (marker-buffer (car value)))))
 383            (save-excursion
 384              (set-buffer buf)
 385              (save-restriction
 386                (widen)
 387                (goto-char a)
 388                (beginning-of-line)
 389                (setq a (1+ (count-lines 1 (point))))
 390                (goto-char b)
 391                (beginning-of-line)
 392                (setq b (1+ (count-lines 1 (point))))))
 393            (if (< b a) (setq tmp a a b b tmp))
 394            (cons 'SPAN
 395                  (vector (cons (ash a -16) (logand a 65535))
 396                          (cons (ash b -16) (logand b 65535))))))))
 397
 398 (defun xselect-convert-to-colno (selection type value)
 399   (let (a b buf tmp)
 400     (cond ((cond ((extentp value)
 401                   (setq buf (extent-object value)
 402                         a (extent-start-position value)
 403                         b (extent-end-position value)))
 404                  ((and (consp value)
 405                        (markerp (car value))
 406                        (markerp (cdr value)))
 407                   (setq a (car value)
 408                         b (cdr value)
 409                         buf (marker-buffer a))))
 410            (save-excursion
 411              (set-buffer buf)
 412              (goto-char a)
 413              (setq a (current-column))
 414              (goto-char b)
 415              (setq b (current-column)))
 416            (if (< b a) (setq tmp a a b b tmp))
 417            (cons 'SPAN
 418                  (vector (cons (ash a -16) (logand a 65535))
 419                          (cons (ash b -16) (logand b 65535))))))))
 420
 421 (defun xselect-convert-to-sourceloc (selection type value)
 422   (let (a b buf file-name tmp)
 423     (cond ((cond ((extentp value)
 424                   (setq buf (or (extent-object value)
 425                                 (error "selection is in a killed buffer"))
 426                         a (extent-start-position value)
 427                         b (extent-end-position value)
 428                         file-name (buffer-file-name buf)))
 429                  ((and (consp value)
 430                        (markerp (car value))
 431                        (markerp (cdr value)))
 432                   (setq a (marker-position (car value))
 433                         b (marker-position (cdr value))
 434                         buf (or (marker-buffer (car value))
 435                                 (error "selection is in a killed buffer"))
 436                         file-name (buffer-file-name buf))))
 437            (save-excursion
 438              (set-buffer buf)
 439              (save-restriction
 440                (widen)
 441                (goto-char a)
 442                (beginning-of-line)
 443                (setq a (1+ (count-lines 1 (point))))
 444                (goto-char b)
 445                (beginning-of-line)
 446                (setq b (1+ (count-lines 1 (point))))))
 447            (if (< b a) (setq tmp a a b b tmp))
 448            (format "%s:%d" file-name a)))))
 449
 450 (defun xselect-convert-to-os (selection type size)
 451   (symbol-name system-type))
 452
 453 (defun xselect-convert-to-host (selection type size)
 454   (system-name))
 455
 456 (defun xselect-convert-to-user (selection type size)
 457   (user-full-name))
 458
 459 (defun xselect-convert-to-class (selection type size)
 460   x-emacs-application-class)
 461
 462 ;; We do not try to determine the name Emacs was invoked with,
 463 ;; because it is not clean for a program's behavior to depend on that.
 464 (defun xselect-convert-to-name (selection type size)
 465   ;invocation-name
 466   "xemacs")
 467
 468 (defun xselect-convert-to-integer (selection type value)
 469   (and (integerp value)
 470        (cons (ash value -16) (logand value 65535))))
 471
 472 (defun xselect-convert-to-atom (selection type value)
 473   (and (symbolp value) value))
 474
 475 (defun xselect-convert-to-identity (selection type value) ; used internally
 476   (vector value))
 477
 478 (setq selection-converter-alist
 479       '((TEXT . xselect-convert-to-text)
 480         (STRING . xselect-convert-to-string)
 481         (COMPOUND_TEXT . xselect-convert-to-compound-text)
 482         (TARGETS . xselect-convert-to-targets)
 483         (LENGTH . xselect-convert-to-length)
 484         (DELETE . xselect-convert-to-delete)
 485         (FILE_NAME . xselect-convert-to-filename)
 486         (CHARACTER_POSITION . xselect-convert-to-charpos)
 487         (SOURCE_LOC . xselect-convert-to-sourceloc)
 488         (LINE_NUMBER . xselect-convert-to-lineno)
 489         (COLUMN_NUMBER . xselect-convert-to-colno)
 490         (OWNER_OS . xselect-convert-to-os)
 491         (HOST_NAME . xselect-convert-to-host)
 492         (USER . xselect-convert-to-user)
 493         (CLASS . xselect-convert-to-class)
 494         (NAME . xselect-convert-to-name)
 495         (ATOM . xselect-convert-to-atom)
 496         (INTEGER . xselect-convert-to-integer)
 497         (_EMACS_INTERNAL . xselect-convert-to-identity)
 498         ))
 499
 500 ;FSFmacs (provide 'select)
 501
 502 ;;; x-select.el ends here.