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))
+ − 217 (if (= (length (cdr object)) 1) "element" "elements")))
+ − 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)
+ − 283 (= (length data) 3)
+ − 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)
+ − 311 (= (length data) 3))
+ − 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
+ − 403 ;; the OffiX drag stuff will soon move also (perhaps mouse.el)
+ − 404 ;; if the drag event is done
+ − 405 (defun offix-start-drag (event data &optional type)
+ − 406 "Implement the OffiX drag operation.
+ − 407 Calls the internal function offix-start-drag-internal to do the actual work.
+ − 408 If type is not given, DndText is assumed."
+ − 409 ;; Oliver Graf <ograf@fga.de>
+ − 410 (interactive "esi")
+ − 411 (if (featurep 'offix)
+ − 412 (funcall (intern "offix-start-drag-internal") event data type)
+ − 413 (error "OffiX functionality not compiled in.")))
+ − 414
+ − 415 (defun offix-start-drag-region (event begin end)
+ − 416 "Implement the OffiX drag operation for a region.
+ − 417 Calls the internal function offix-start-drag-internal to do the actual work.
+ − 418 This always assumes DndText as type."
+ − 419 ;; Oliver Graf <ograf@fga.de>
+ − 420 (interactive "_er")
+ − 421 (if (featurep 'offix)
+ − 422 (funcall (intern "offix-start-drag-internal")
+ − 423 event (buffer-substring-no-properties begin end))
+ − 424 (error "OffiX functionality not compiled in.")))
+ − 425
462
+ − 426 (defun gtk-start-drag (event data &optional type)
+ − 427 (interactive "esi")
+ − 428 (if (featurep 'gtk)
502
+ − 429 (declare-fboundp (gtk-start-drag-internal event data type))
462
+ − 430 (error "GTK functionality not compiled in.")))
+ − 431
+ − 432 (defun gtk-start-drag-region (event begin end)
+ − 433 (interactive "_er")
+ − 434 (if (featurep 'gtk)
502
+ − 435 (declare-fboundp (gtk-start-drag-internal event (buffer-substring-no-properties begin end) "text/plain"))
462
+ − 436 (error "GTK functionality not compiled in.")))
428
+ − 437
+ − 438 ;;; dragdrop.el ends here
