Mercurial > hg > xemacs-beta
annotate lisp/dragdrop.el @ 5549:493c487cbc3f
Add #'event-apply-modifiers, implement #'event-apply-modifiers in terms of it.
2011-08-10 Aidan Kehoe <kehoea@parhasard.net>
* keymap.el:
* keymap.el (event-apply-alt-modifier):
* keymap.el (event-apply-super-modifier):
* keymap.el (event-apply-hyper-modifier):
* keymap.el (event-apply-shift-modifier):
* keymap.el (event-apply-control-modifier):
* keymap.el (event-apply-meta-modifier):
* keymap.el (event-apply-modifiers): New.
* keymap.el (event-apply-modifier): Implement in terms of
#'event-apply-modifier.
Rework #'event-apply-modifier to take a list of modifiers, and
change its name appropriately. Keep the old name around, too.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 10 Aug 2011 16:50:37 +0100 |
| parents | ac37a5f7e5be |
| children |
| rev | line source |
|---|---|
| 428 | 1 ;;; dragdrop.el --- window system-independent Drag'n'Drop support. |
| 2 | |
| 3 ;; Copyright (C) 1998 Oliver Graf <ograf@fga.de> | |
| 4 | |
| 5 ;; Maintainer: XEmacs Development Team, Oliver Graf <ograf@fga.de> | |
| 442 | 6 ;; Keywords: mouse, gui, dumped |
| 428 | 7 |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4790
diff
changeset
|
10 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4790
diff
changeset
|
11 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4790
diff
changeset
|
12 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4790
diff
changeset
|
13 ;; option) any later version. |
| 428 | 14 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4790
diff
changeset
|
15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4790
diff
changeset
|
16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4790
diff
changeset
|
17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4790
diff
changeset
|
18 ;; for more details. |
| 428 | 19 |
| 20 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4790
diff
changeset
|
21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 22 |
| 23 ;;; Synched up with: Not in FSF. | |
| 24 | |
| 25 ;;; Commentary: | |
| 26 | |
| 27 ;; This file is dumped with XEmacs (when drag'n'drop support is compiled in). | |
| 28 | |
| 29 ;;; Code: | |
| 30 | |
| 31 ;; we need mouse-set-point | |
| 32 (require 'mouse) | |
| 33 (provide 'dragdrop) | |
| 34 | |
| 35 ;; I think this is a better name for the custom group | |
| 36 ;; looks better in the menu and the group display as dragdrop | |
| 37 ;; Anyway: is dragdrop- a good prefix for all this? | |
| 38 ;; What if someone trys drop<TAB> in the minibuffer? | |
| 39 (defgroup drag-n-drop nil | |
| 40 "*{EXPERIMENTAL} Window system-independent drag'n'drop support." | |
| 41 :group 'editing) | |
| 42 | |
| 43 (defcustom dragdrop-drop-at-point nil | |
| 44 "*{EXPERIMENTAL} If non-nil, drop text at the cursor location. | |
| 45 Otherwise, the cursor will be moved to the location of the pointer drop before | |
| 46 text is inserted." | |
| 47 :type 'boolean | |
| 48 :group 'drag-n-drop) | |
| 49 | |
| 50 (defcustom dragdrop-autoload-tm-view nil | |
| 51 "*{EXPERIMENTAL} If non-nil, autoload tm-view to decode MIME data. | |
| 52 Otherwise, the buffer is only decoded if tm-view is already available." | |
| 53 :type 'boolean | |
| 54 :group 'drag-n-drop) | |
| 55 | |
| 56 ;; the widget for editing the drop-functions | |
| 57 (define-widget 'dragdrop-function-widget 'list | |
| 58 "*{EXPERIMENTAL} Widget for editing drop dispatch functions." | |
| 59 :args `((choice :tag "Function" | |
| 60 (function-item experimental-dragdrop-drop-url-default) | |
| 61 (function-item experimental-dragdrop-drop-mime-default) | |
| 62 (function-item experimental-dragdrop-drop-log-function) | |
| 63 (function :tag "Other" nil)) | |
| 64 (choice :tag "Button" :value t | |
| 65 (choice-item :tag "Ignore" t) | |
| 66 (choice-item 0) (choice-item 1) (choice-item 2) | |
| 67 (choice-item 3) (choice-item 4) (choice-item 5) | |
| 68 (choice-item 6) (choice-item 7)) | |
| 69 (radio-button-choice :tag "Modifiers" | |
| 70 (const :tag "Ignore Modifier Keys" t) | |
| 71 (checklist :greedy t | |
| 72 :format "Modifier Keys:\n%v" | |
| 73 :extra-offset 6 | |
| 74 (const shift) | |
| 75 (const control) | |
| 76 (const meta) | |
| 77 (const alt) | |
| 78 (const hyper) | |
| 79 (const super))) | |
| 80 (repeat :inline t :value nil :tag "Extra Function Arguments" | |
| 81 (sexp :tag "Arg" :value nil))) | |
| 82 :value '(nil t t)) | |
| 83 | |
| 84 (defcustom experimental-dragdrop-drop-functions '((experimental-dragdrop-drop-url-default t t) | |
| 85 (experimental-dragdrop-drop-mime-default t t)) | |
| 86 "*{EXPERIMENTAL} This is the standart drop function search list. | |
| 87 Each element is a list of a function, a button selector, a modifier | |
| 88 selector and optional argumets to the function call. | |
| 89 The function must accept at least two arguments: first is the event | |
| 90 of the drop, second the object data, followed by any of the optional | |
| 91 arguments provided in this list. | |
| 92 The functions are called in order, until one returns t." | |
| 93 :group 'drag-n-drop | |
| 94 :type '(repeat dragdrop-function-widget)) | |
| 95 | |
| 96 (defgroup dnd-debug nil | |
| 97 "*{EXPERIMENTAL} Drag'n'Drop debugging options." | |
| 98 :group 'drag-n-drop) | |
| 99 | |
| 100 (defcustom dragdrop-drop-log nil | |
| 101 "*{EXPERIMENTAL} If non-nil, every drop is logged. | |
| 102 The name of the buffer is set in the custom 'dragdrop-drop-log-name" | |
| 103 :group 'dnd-debug | |
| 104 :type 'boolean) | |
| 105 | |
| 106 (defcustom dragdrop-drop-log-name "*drop log buffer*" | |
| 107 "*{EXPERIMENTAL} The name of the buffer used to log drops. | |
| 108 Set dragdrop-drop-log to non-nil to enable this feature." | |
| 109 :group 'dnd-debug | |
| 110 :type 'string) | |
| 111 | |
| 112 (defvar dragdrop-drop-log-buffer nil | |
| 113 "*{EXPERIMENTAL} Buffer to log drops in debug mode.") | |
| 114 | |
| 115 ;; | |
| 116 ;; Drop API | |
| 117 ;; | |
| 118 (defun dragdrop-drop-dispatch (object) | |
| 119 "*{EXPERIMENTAL} This function identifies DROP type misc-user-events. | |
| 120 It calls functions which will handle the drag." | |
| 121 (let ((event current-mouse-event)) | |
| 122 (and dragdrop-drop-log | |
| 123 (experimental-dragdrop-drop-log-function event object)) | |
| 124 (dragdrop-drop-find-functions event object))) | |
| 125 | |
| 126 (defun dragdrop-drop-find-functions (event object) | |
| 127 "Finds valid drop-handle functions and executes them to dispose the drop. | |
| 128 It does this by looking for extent-properties called | |
| 129 'experimental-dragdrop-drop-functions and for variables named like this." | |
| 130 (catch 'dragdrop-drop-is-done | |
| 131 (and (event-over-text-area-p event) | |
| 132 ;; let's search the extents | |
| 133 (catch 'dragdrop-extents-done | |
| 134 (let ((window (event-window event)) | |
| 135 (pos (event-point event)) | |
| 136 (cpos (event-closest-point event)) | |
| 137 (buffer nil)) | |
| 138 (or window (throw 'dragdrop-extents-done nil)) | |
| 139 (or pos (setq pos cpos)) | |
| 140 (select-window window) | |
| 141 (setq buffer (window-buffer)) | |
| 142 (let ((ext (extent-at pos buffer 'experimental-dragdrop-drop-functions))) | |
| 143 (while (not (eq ext nil)) | |
| 144 (dragdrop-drop-do-functions | |
| 145 (extent-property ext 'experimental-dragdrop-drop-functions) | |
| 146 event | |
| 147 object) | |
| 148 (setq ext (extent-at pos buffer | |
| 149 'experimental-dragdrop-drop-functions | |
| 150 ext))))))) | |
| 151 ;; now look into the variable experimental-dragdrop-drop-functions | |
| 152 (dragdrop-drop-do-functions experimental-dragdrop-drop-functions event object))) | |
| 153 | |
| 154 (defun dragdrop-compare-mods (first-mods second-mods) | |
| 155 "Returns t if both first-mods and second-mods contain the same elements. | |
| 156 Order is not important." | |
| 157 (let ((moda (copy-sequence first-mods)) | |
| 158 (modb (copy-sequence second-mods))) | |
| 159 (while (and (not (eq moda ())) | |
| 160 (not (eq modb ()))) | |
| 161 (setq modb (delete (car moda) modb)) | |
| 162 (setq moda (delete (car moda) moda))) | |
| 163 (and (eq moda ()) | |
| 164 (eq modb ())))) | |
| 165 | |
| 166 (defun dragdrop-drop-do-functions (drop-funs event object) | |
| 167 "Calls all functions in drop-funs with object until one returns t. | |
| 168 Returns t if one of drop-funs returns t. Otherwise returns nil." | |
| 169 (let ((flist nil) | |
| 170 (button (event-button event)) | |
| 171 (mods (event-modifiers event))) | |
| 172 (while (not (eq drop-funs ())) | |
| 173 (setq flist (car drop-funs)) | |
| 174 (and (or (eq (cadr flist) t) | |
| 175 (= (cadr flist) button)) | |
| 176 (or (eq (caddr flist) t) | |
| 177 (dragdrop-compare-mods (caddr flist) mods)) | |
| 178 (apply (car flist) `(,event ,object ,@(cdddr flist))) | |
| 179 ;; (funcall (car flist) event object) | |
| 180 (throw 'dragdrop-drop-is-done t)) | |
| 181 (setq drop-funs (cdr drop-funs)))) | |
| 182 nil) | |
| 183 | |
| 184 (defun experimental-dragdrop-drop-log-function (event object &optional message buffer) | |
| 185 "*{EXPERIMENTAL} Logs any drops into a buffer. | |
| 186 If buffer is nil, it inserts the data into a buffer called after | |
| 187 dragdrop-drop-log-name. | |
| 188 If dragdrop-drop-log is non-nil, this is done automatically for each drop. | |
| 189 The function always returns nil." | |
| 190 (save-excursion | |
| 191 (cond ((buffer-live-p buffer) | |
| 192 (set-buffer buffer)) | |
| 193 ((stringp buffer) | |
| 194 (set-buffer (get-buffer-create buffer))) | |
| 195 ((buffer-live-p dragdrop-drop-log-buffer) | |
| 196 (set-buffer dragdrop-drop-log-buffer)) | |
| 197 (t | |
| 198 (setq dragdrop-drop-log-buffer (get-buffer-create dragdrop-drop-log-name)) | |
| 199 (set-buffer dragdrop-drop-log-buffer))) | |
| 200 (insert (format "* %s: %s\n" | |
| 201 (current-time-string) | |
| 202 (if message message "received a drop"))) | |
| 203 (insert (format " at %d,%d (%d,%d) with button %d and mods %s\n" | |
| 204 (event-x event) | |
| 205 (event-y event) | |
| 206 (event-x-pixel event) | |
| 207 (event-y-pixel event) | |
| 208 (event-button event) | |
| 209 (event-modifiers event))) | |
| 210 (insert (format " data is of type %s (%d %s)\n" | |
| 211 (cond ((eq (car object) 'dragdrop-URL) "URL") | |
| 212 ((eq (car object) 'dragdrop-MIME) "MIME") | |
| 213 (t "UNKNOWN")) | |
| 214 (length (cdr object)) | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
4790
diff
changeset
|
215 (if (eql (length (cdr object)) 1) "element" "elements"))) |
| 428 | 216 (let ((i 1) |
| 217 (data (cdr object))) | |
| 218 (while (not (eq data ())) | |
| 219 (insert (format " Element %d: %S\n" | |
| 220 i (car data))) | |
| 221 (setq i (1+ i)) | |
| 222 (setq data (cdr data)))) | |
| 223 (insert "----------\n")) | |
| 224 nil) | |
| 225 | |
| 226 (defun experimental-dragdrop-drop-url-default (event object) | |
| 227 "*{EXPERIMENTAL} Default handler for dropped URL data. | |
| 228 Finds files and URLs. Returns nil if object does not contain URL data." | |
| 229 (cond ((eq (car object) 'dragdrop-URL) | |
| 536 | 230 (let* ((data (cdr object)) |
| 231 (frame (event-channel event)) | |
| 232 (x pop-up-windows) | |
| 233 (window (or (event-window event) | |
| 234 (frame-selected-window frame) | |
| 235 (frame-highest-window frame 0)))) | |
| 428 | 236 (setq pop-up-windows nil) |
| 237 (while (not (eq data ())) | |
| 238 (cond ((dragdrop-is-some-url "file" (car data)) | |
| 239 ;; if it is some file, pop it to a buffer | |
| 240 (cond (window | |
| 241 (select-window window))) | |
| 242 (switch-to-buffer (find-file-noselect | |
| 243 (substring (car data) 5)))) | |
| 244 ;; to-do: open ftp URLs with efs... | |
| 245 (t | |
| 246 ;; some other URL, try to fire up some browser for it | |
| 776 | 247 (if-fboundp 'browse-url |
| 442 | 248 (browse-url (car data)) |
| 428 | 249 (display-message 'error |
| 250 "Can't show URL, no browser selected")))) | |
| 251 (undo-boundary) | |
| 252 (setq data (cdr data))) | |
| 253 (make-frame-visible frame) | |
| 254 (setq pop-up-windows x) | |
| 255 t)) | |
| 256 (t nil))) | |
| 257 | |
| 258 (defun experimental-dragdrop-drop-mime-default (event object) | |
| 259 "*{EXPERIMENTAL} Default handler for dropped MIME data. | |
| 260 Inserts text into buffer, creates MIME buffers for other types. | |
| 261 Returns nil if object does not contain MIME data." | |
| 262 (cond ((eq (car object) 'dragdrop-MIME) | |
| 263 (let ((ldata (cdr object)) | |
| 264 (frame (event-channel event)) | |
| 265 (x pop-up-windows) | |
| 266 (data nil)) | |
| 267 ;; how should this be handled??? | |
| 268 ;; insert drops of text/* into buffer | |
| 269 ;; create new buffer if pointer is outside buffer... | |
| 270 ;; but there are many other ways... | |
| 271 ;; | |
| 272 ;; first thing: check if it's only text/plain and if the | |
| 273 ;; drop happened inside some buffer. if yes insert it into | |
| 274 ;; this buffer (hope it is not encoded in some MIME way) | |
| 275 ;; | |
| 276 ;; Remember: ("text/plain" "dosnotmatter" "somedata") | |
| 277 ;; drops are inserted at mouse-point, if inside a buffer | |
| 278 (while (not (eq ldata ())) | |
| 279 (setq data (car ldata)) | |
| 280 (if (and (listp data) | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
4790
diff
changeset
|
281 (eql (length data) 3) |
| 428 | 282 (listp (car data)) |
| 283 (stringp (caar data)) | |
| 284 (string= (caar data) "text/plain") | |
| 285 (event-over-text-area-p event)) | |
| 286 (let ((window (event-window event))) | |
| 287 (and window | |
| 288 (select-window window)) | |
| 289 (and (not dragdrop-drop-at-point) | |
| 290 (mouse-set-point event)) | |
| 291 (insert (caddr data))) | |
| 292 (let ((buf (get-buffer-create "*MIME-Drop data*"))) | |
| 293 (set-buffer buf) | |
| 294 (pop-to-buffer buf nil frame) | |
| 295 (or (featurep 'tm-view) | |
| 296 (and dragdrop-autoload-tm-view | |
| 297 (require 'tm-view))) | |
| 298 (cond ((stringp data) | |
| 299 ;; this is some raw MIME stuff | |
| 300 ;; create some buffer and let tm do the job | |
| 301 ;; | |
| 302 ;; this is always the same buffer!!! | |
| 303 ;; change? | |
| 304 (erase-buffer) | |
| 305 (insert data) | |
| 306 (and (featurep 'tm-view) | |
| 502 | 307 (declare-fboundp (mime/viewer-mode buf)))) |
| 428 | 308 ((and (listp data) |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
4790
diff
changeset
|
309 (eql (length data) 3)) |
| 428 | 310 ;; change the internal content-type representation to the |
| 311 ;; way tm does it ("content/type" (key . value)*) | |
| 312 ;; but for now list will do the job | |
| 313 ;; | |
| 314 ;; this is always the same buffer!!! | |
| 315 ;; change? | |
| 316 (erase-buffer) | |
| 317 (insert (caddr data)) | |
| 318 (and (featurep 'tm-view) | |
| 319 ;; this list of (car data) should be done before | |
| 320 ;; enqueing the event | |
| 502 | 321 (declare-fboundp |
| 322 (mime/viewer-mode buf (car data) (cadr data))))) | |
| 428 | 323 (t |
| 324 (display-message 'error "Wrong drop data"))))) | |
| 325 (undo-boundary) | |
| 326 (setq ldata (cdr ldata))) | |
| 327 (make-frame-visible frame) | |
| 328 (setq pop-up-windows x)) | |
| 329 t) | |
| 330 (t nil))) | |
| 331 | |
| 332 (defun dragdrop-is-some-url (method url) | |
| 333 "Returns true if method equals the start of url. | |
| 334 If method does not end into ':' this is appended before the | |
| 335 compare." | |
| 336 (cond ((and (stringp url) | |
| 337 (stringp method) | |
| 338 (> (length url) (length method))) | |
| 339 ;; is this ?: check efficient enough? | |
| 340 (if (not (string= (substring method -1) ":")) | |
| 341 (setq method (concat method ":"))) | |
| 342 (string= method (substring url 0 (length method)))) | |
| 343 (t nil))) | |
| 344 | |
| 345 ;; | |
| 346 ;; Drag API | |
| 347 ;; | |
| 348 (defun experimental-dragdrop-drag (event object) | |
| 349 "*{EXPERIMENTAL} The generic drag function. | |
| 350 Tries to do the best with object in the selected protocol. | |
| 351 Object must comply to the standart drag'n'drop object | |
| 352 format." | |
| 353 (error "Not implemented")) | |
| 354 | |
| 355 (defun experimental-dragdrop-drag-region (event begin end) | |
| 356 "*{EXPERIMENTAL} Drag a region. | |
| 357 This function uses special data types if the low-level | |
| 358 protocol requires it. It does so by calling | |
| 359 dragdrop-drag-pure-text." | |
| 360 (experimental-dragdrop-drag-pure-text event | |
| 361 (buffer-substring-no-properties begin end))) | |
| 362 | |
| 363 (defun experimental-dragdrop-drag-pure-text (event text) | |
| 364 "*{EXPERIMENTAL} Drag text-only data. | |
| 365 Takes care of special low-level protocol data types. | |
| 366 Text must be a list of strings." | |
| 367 (error "Not implemented")) | |
| 368 | |
| 369 (defun experimental-dragdrop-drag-pure-file (event file) | |
| 370 "*{EXPERIMENTAL} Drag filepath-only data. | |
| 371 Takes care of special low-level protocol data types. | |
| 372 file must be a list of strings." | |
| 373 (error "Not implemented")) | |
| 374 | |
| 375 ;; | |
| 376 ;; The following ones come from frame.el but the better belong here | |
| 377 ;; until changed | |
| 378 ;; | |
| 379 (defun cde-start-drag (event type data) | |
| 380 "Implement the CDE drag operation. | |
| 381 Calls the internal function cde-start-drag-internal to do the actual work." | |
| 382 (interactive "_eXX") | |
| 383 (if (featurep 'cde) | |
| 384 ;; Avoid build-time doc string warning by calling the function | |
| 385 ;; in the following roundabout way: | |
| 386 (funcall (intern "cde-start-drag-internal") | |
| 387 event type data) | |
| 388 (error "CDE functionality not compiled in."))) | |
| 389 | |
| 390 (defun cde-start-drag-region (event begin end) | |
| 391 "Implement the CDE drag operation for a region. | |
| 392 Calls the internal function CDE-start-drag-internal to do the actual work. | |
| 393 This always does buffer transfers." | |
| 394 ;; Oliver Graf <ograf@fga.de> | |
| 395 (interactive "_er") | |
| 396 (if (featurep 'cde) | |
| 397 (funcall (intern "cde-start-drag-internal") | |
| 398 event nil (list (buffer-substring-no-properties begin end))) | |
| 399 (error "CDE functionality not compiled in."))) | |
| 400 | |
| 462 | 401 (defun gtk-start-drag (event data &optional type) |
| 402 (interactive "esi") | |
| 403 (if (featurep 'gtk) | |
| 502 | 404 (declare-fboundp (gtk-start-drag-internal event data type)) |
| 462 | 405 (error "GTK functionality not compiled in."))) |
| 406 | |
| 407 (defun gtk-start-drag-region (event begin end) | |
| 408 (interactive "_er") | |
| 409 (if (featurep 'gtk) | |
| 502 | 410 (declare-fboundp (gtk-start-drag-internal event (buffer-substring-no-properties begin end) "text/plain")) |
| 462 | 411 (error "GTK functionality not compiled in."))) |
| 428 | 412 |
| 413 ;;; dragdrop.el ends here |