Mercurial > hg > xemacs-beta

comparison lisp/dragdrop.el @ 284:558f606b08ae r21-0b40

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b40
author cvs
date Mon, 13 Aug 2007 10:34:13 +0200
parents c42ec1d1cded
children e11d67e05968
comparison
equal deleted inserted replaced
283:fa3d41851a08 284:558f606b08ae
24 24
25 ;;; Synched up with: Not in FSF. 25 ;;; Synched up with: Not in FSF.
26 26
27 ;;; Commentary: 27 ;;; Commentary:
28 28
29 ;; This file is dumped with XEmacs (when window system support is compiled in). 29 ;; This file is dumped with XEmacs (when drag'n'drop support is compiled in).
30 30
31 ;;; Code: 31 ;;; Code:
32
33 (provide 'dragdrop)
34 32
35 ;; we need mouse-set-point 33 ;; we need mouse-set-point
36 (require 'mouse) 34 (require 'mouse)
35 (provide 'dragdrop)
37 36
38 ;; I think this is a better name for the custom group 37 ;; I think this is a better name for the custom group
39 ;; looks better in the menu and the group display as dragdrop 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 type drop<TAB> into the minibuffer?
40 (defgroup drag-n-drop nil 41 (defgroup drag-n-drop nil
41 "Window system-independent drag'n'drop support." 42 "Window system-independent drag'n'drop support."
42 :group 'editing) 43 :group 'editing)
43 44
44 (defcustom dragdrop-drop-at-point nil 45 (defcustom dragdrop-drop-at-point nil
52 "*If non-nil, autoload tm-view if a MIME buffer needs to be decoded. 53 "*If non-nil, autoload tm-view if a MIME buffer needs to be decoded.
53 Otherwise, the buffer is only decoded if tm-view is already avaiable." 54 Otherwise, the buffer is only decoded if tm-view is already avaiable."
54 :type 'boolean 55 :type 'boolean
55 :group 'drag-n-drop) 56 :group 'drag-n-drop)
56 57
57 (defcustom dragdrop-drop-functions '(dragdrop-drop-url-default 58 ;; the widget for editing the drop-functions
58 dragdrop-drop-mime-default) 59 (define-widget 'dragdrop-function-widget 'list
60 "Widget for editing drop dispatch functions."
61 :args `((choice :tag "Function"
62 (function-item dragdrop-drop-url-default)
63 (function-item dragdrop-drop-mime-default)
64 (function-item 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 ;; button and widget selectors are still "shaky":
87 ;; button may be a number or t (or nil?), t means "Ignore"
88 ;; mods may be t or nil or a list of mod-syms, t means "Ignore"
89 ;; but this seems to be a porblem for the widget, well perhaps I find
90 ;; a solution...
91 (defcustom dragdrop-drop-functions '((dragdrop-drop-url-default t t)
92 (dragdrop-drop-mime-default t t))
59 "This is the standart drop function search list. 93 "This is the standart drop function search list.
60 Each variable in this list is called with the drop data until 94 Each element is a list of a function, a button selector, a modifier
61 one of the functions return t, or the end of the list is reached." 95 selector and optional argumets to the function call.
96 The function must accept at least two arguments: first is the event
97 of the drop, second the object data, followed by any of the optional
98 arguments provided in this list.
99 The functions are called in order, until one returns t."
62 :group 'drag-n-drop 100 :group 'drag-n-drop
63 :type '(repeat (choice (function-item dragdrop-drop-url-default) 101 :type '(repeat dragdrop-function-widget))
64 (function-item dragdrop-drop-mime-default) 102
65 (function :tag "other")))) 103 (defgroup dnd-debug nil
104 "Drag'n'Drop debugging options."
105 :group 'drag-n-drop)
106
107 (defcustom dragdrop-drop-log nil
108 "If non-nil, every drop is logged.
109 The name of the buffer is set in the custom 'dragdrop-drop-log-name"
110 :group 'dnd-debug
111 :type 'boolean)
112
113 (defcustom dragdrop-drop-log-name "*drop log buffer*"
114 "The name of the buffer used to log drops.
115 Set dragdrop-drop-log to non-nil to enable this feature."
116 :group 'dnd-debug
117 :type 'string)
118
119 (defvar dragdrop-drop-log-buffer nil
120 "Buffer to log drops in debug mode.")
66 121
67 (defun dragdrop-drop-dispatch (object) 122 (defun dragdrop-drop-dispatch (object)
68 "This function identifies DROP type misc-user-events. 123 "This function identifies DROP type misc-user-events.
69 It tries to find out how to handle the dropped data by looking 124 It calls functions which will handle the drag."
70 for dragdrop-drop-functions in extents and variables." 125 (let ((event current-mouse-event))
126 (and dragdrop-drop-log
127 (dragdrop-drop-log-function event object))
128 (dragdrop-drop-find-functions event object)))
129
130 (defun dragdrop-drop-find-functions (event object)
131 "Finds valid drop-handle functions and executes them to dispose the drop.
132 It does this by looking for extent-properties called 'dragdrop-drop-functions
133 and for variables named like this."
71 (catch 'dragdrop-drop-is-done 134 (catch 'dragdrop-drop-is-done
72 (and (event-over-text-area-p current-mouse-event) 135 (and (event-over-text-area-p event)
73 ;; let's search the extents 136 ;; let's search the extents
74 (catch 'dragdrop-extents-done 137 (catch 'dragdrop-extents-done
75 (let ((window (event-window current-mouse-event)) 138 (let ((window (event-window event))
76 (pos (event-point current-mouse-event)) 139 (pos (event-point event))
77 (cpos (event-closest-point current-mouse-event)) 140 (cpos (event-closest-point event))
78 (buffer nil)) 141 (buffer nil))
79 (or window (throw 'dragdrop-extents-done nil)) 142 (or window (throw 'dragdrop-extents-done nil))
80 (or pos (setq pos cpos)) 143 (or pos (setq pos cpos))
81 (select-window window) 144 (select-window window)
82 (setq buffer (window-buffer)) 145 (setq buffer (window-buffer))
83 (let ((ext (extent-at pos buffer 'dragdrop-drop-functions))) 146 (let ((ext (extent-at pos buffer 'dragdrop-drop-functions)))
84 (while (not (eq ext nil)) 147 (while (not (eq ext nil))
85 (dragdrop-drop-do-functions 148 (dragdrop-drop-do-functions
86 (extent-property ext 'dragdrop-drop-functions) 149 (extent-property ext 'dragdrop-drop-functions)
150 event
87 object) 151 object)
88 (setq ext (extent-at pos buffer 'dragdrop-drop-functions ext))))))) 152 (setq ext (extent-at pos buffer 'dragdrop-drop-functions ext)))))))
89 ;; now look into the variable dragdrop-drop-functions 153 ;; now look into the variable dragdrop-drop-functions
90 (dragdrop-drop-do-functions dragdrop-drop-functions object))) 154 (dragdrop-drop-do-functions dragdrop-drop-functions event object)))
91 155
92 (defun dragdrop-drop-do-functions (drop-funs object) 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)
93 "Calls all functions in drop-funs with object until one returns t. 169 "Calls all functions in drop-funs with object until one returns t.
94 Returns t if one of drop-funs returns t. Otherwise returns nil." 170 Returns t if one of drop-funs returns t. Otherwise returns nil."
95 (while (not (eq drop-funs ())) 171 (let ((flist nil)
96 (and (funcall (car drop-funs) object) 172 (button (event-button event))
97 (throw 'dragdrop-drop-is-done t)) 173 (mods (event-modifiers event)))
98 (setq drop-funs (cdr drop-funs))) 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) modifiers))
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))))
99 nil) 184 nil)
100 185
101 (defun dragdrop-drop-url-default (object) 186 (defun dragdrop-drop-log-function (event object &optional message buffer)
187 "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 dragdrop-drop-url-default (event object)
102 "Default handler for dropped URL data. 229 "Default handler for dropped URL data.
103 Finds files and URLs. Returns nil if object does not contain URL data." 230 Finds files and URLs. Returns nil if object does not contain URL data."
104 (cond ((eq (car object) 'dragdrop-URL) 231 (cond ((eq (car object) 'dragdrop-URL)
105 (let ((data (cdr object)) 232 (let ((data (cdr object))
106 (frame (event-channel current-mouse-event)) 233 (frame (event-channel event))
107 (x pop-up-windows)) 234 (x pop-up-windows))
108 (setq pop-up-windows nil) 235 (setq pop-up-windows nil)
109 (while (not (eq data ())) 236 (while (not (eq data ()))
110 (cond ((dragdrop-is-some-url "file" (car data)) 237 (cond ((dragdrop-is-some-url "file" (car data))
111 ;; if it is some file, pop it to a buffer 238 ;; if it is some file, pop it to a buffer
124 (make-frame-visible frame) 251 (make-frame-visible frame)
125 (setq pop-up-windows x) 252 (setq pop-up-windows x)
126 t)) 253 t))
127 (t nil))) 254 (t nil)))
128 255
129 (defun dragdrop-drop-mime-default (object) 256 (defun dragdrop-drop-mime-default (event object)
130 "Default handler for dropped MIME data. 257 "Default handler for dropped MIME data.
131 Inserts text into buffer, creates MIME buffers for other types. 258 Inserts text into buffer, creates MIME buffers for other types.
132 Returns nil if object does not contain MIME data." 259 Returns nil if object does not contain MIME data."
133 (cond ((eq (car object) 'dragdrop-MIME) 260 (cond ((eq (car object) 'dragdrop-MIME)
134 (let ((ldata (cdr object)) 261 (let ((ldata (cdr object))
135 (frame (event-channel current-mouse-event)) 262 (frame (event-channel event))
136 (x pop-up-windows) 263 (x pop-up-windows)
137 (data nil)) 264 (data nil))
138 ;; how should this be handled??? 265 ;; how should this be handled???
139 ;; insert drops of text/* into buffer 266 ;; insert drops of text/* into buffer
140 ;; create new buffer if pointer is outside buffer... 267 ;; create new buffer if pointer is outside buffer...
148 ;; drops are inserted at mouse-point, if inside a buffer 275 ;; drops are inserted at mouse-point, if inside a buffer
149 (while (not (eq ldata ())) 276 (while (not (eq ldata ()))
150 (setq data (car ldata)) 277 (setq data (car ldata))
151 (if (and (listp data) 278 (if (and (listp data)
152 (= (length data) 3) 279 (= (length data) 3)
153 (string= (car data) "text/plain") 280 (listp (car data))
154 (event-over-text-area-p current-mouse-event)) 281 (stringp (caar data))
155 (let ((window (event-window current-mouse-event))) 282 (string= (caar data) "text/plain")
283 (event-over-text-area-p event))
284 (let ((window (event-window event)))
156 (and window 285 (and window
157 (select-window window)) 286 (select-window window))
158 (and (not dragdrop-drop-at-point) 287 (and (not dragdrop-drop-at-point)
159 (mouse-set-point current-mouse-event)) 288 (mouse-set-point event))
160 (insert (caddr data))) 289 (insert (caddr data)))
161 (let ((buf (get-buffer-create "*MIME-Drop data*"))) 290 (let ((buf (get-buffer-create "*MIME-Drop data*")))
162 (set-buffer buf) 291 (set-buffer buf)
163 (pop-to-buffer buf nil frame) 292 (pop-to-buffer buf nil frame)
164 (or (featurep 'tm-view) 293 (or (featurep 'tm-view)
185 (erase-buffer) 314 (erase-buffer)
186 (insert (caddr data)) 315 (insert (caddr data))
187 (and (featurep 'tm-view) 316 (and (featurep 'tm-view)
188 ;; this list of (car data) should be done before 317 ;; this list of (car data) should be done before
189 ;; enqueing the event 318 ;; enqueing the event
190 (mime/viewer-mode buf (list (car data)) (cadr data)))) 319 (mime/viewer-mode buf (car data) (cadr data))))
191 (t 320 (t
192 (display-message 'error "Wrong drop data"))))) 321 (display-message 'error "Wrong drop data")))))
193 (undo-boundary) 322 (undo-boundary)
194 (setq ldata (cdr ldata))) 323 (setq ldata (cdr ldata)))
195 (make-frame-visible frame) 324 (make-frame-visible frame)