Mercurial > hg > xemacs-beta
annotate lisp/dragdrop.el @ 5569:d19b6e3bdf91
#'cl-defsubst-expand; avoid mutually-recursive symbol macros.
lisp/ChangeLog addition:
2011-09-10 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-defsubst-expand):
Change set 2a6a8da4dd7c of
http://mid.gmane.org/19966.17522.332164.615228@parhasard.net
wasn't sufficiently comprehensive, symbol macros can be mutually
rather than simply recursive, and they can equally hang. Thanks
for the bug report, Michael Sperber, and for the test case,
Stephen Turnbull.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 10 Sep 2011 13:17:29 +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 |