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