Mercurial > hg > xemacs-beta

comparison lisp/dragdrop.el @ 290:c9fe270a4101 r21-0b43

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b43
author cvs
date Mon, 13 Aug 2007 10:36:47 +0200
parents e11d67e05968
children 8626e4521993
comparison
equal deleted inserted replaced
289:6e6992ccc4b6 290:c9fe270a4101
37 ;; I think this is a better name for the custom group 37 ;; I think this is a better name for the custom group
38 ;; 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? 39 ;; Anyway: is dragdrop- a good prefix for all this?
40 ;; What if someone trys drop<TAB> in the minibuffer? 40 ;; What if someone trys drop<TAB> in the minibuffer?
41 (defgroup drag-n-drop nil 41 (defgroup drag-n-drop nil
42 "Window system-independent drag'n'drop support." 42 "*{EXPERIMENTAL} Window system-independent drag'n'drop support."
43 :group 'editing) 43 :group 'editing)
44 44
45 (defcustom dragdrop-drop-at-point nil 45 (defcustom dragdrop-drop-at-point nil
46 "*If non-nil, the drop handler functions will drop text at the cursor location. 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 47 Otherwise, the cursor will be moved to the location of the pointer drop before
48 text is inserted." 48 text is inserted."
49 :type 'boolean 49 :type 'boolean
50 :group 'drag-n-drop) 50 :group 'drag-n-drop)
51 51
52 (defcustom dragdrop-autoload-tm-view nil 52 (defcustom dragdrop-autoload-tm-view nil
53 "*If non-nil, autoload tm-view if a MIME buffer needs to be decoded. 53 "*{EXPERIMENTAL} If non-nil, autoload tm-view to decode MIME data.
54 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."
55 :type 'boolean 55 :type 'boolean
56 :group 'drag-n-drop) 56 :group 'drag-n-drop)
57 57
58 ;; the widget for editing the drop-functions 58 ;; the widget for editing the drop-functions
59 (define-widget 'dragdrop-function-widget 'list 59 (define-widget 'dragdrop-function-widget 'list
60 "Widget for editing drop dispatch functions." 60 "*{EXPERIMENTAL} Widget for editing drop dispatch functions."
61 :args `((choice :tag "Function" 61 :args `((choice :tag "Function"
62 (function-item dragdrop-drop-url-default) 62 (function-item experimental-dragdrop-drop-url-default)
63 (function-item dragdrop-drop-mime-default) 63 (function-item experimental-dragdrop-drop-mime-default)
64 (function-item dragdrop-drop-log-function) 64 (function-item experimental-dragdrop-drop-log-function)
65 (function :tag "Other" nil)) 65 (function :tag "Other" nil))
66 (choice :tag "Button" :value t 66 (choice :tag "Button" :value t
67 (choice-item :tag "Ignore" t) 67 (choice-item :tag "Ignore" t)
68 (choice-item 0) (choice-item 1) (choice-item 2) 68 (choice-item 0) (choice-item 1) (choice-item 2)
69 (choice-item 3) (choice-item 4) (choice-item 5) 69 (choice-item 3) (choice-item 4) (choice-item 5)
81 (const super))) 81 (const super)))
82 (repeat :inline t :value nil :tag "Extra Function Arguments" 82 (repeat :inline t :value nil :tag "Extra Function Arguments"
83 (sexp :tag "Arg" :value nil))) 83 (sexp :tag "Arg" :value nil)))
84 :value '(nil t t)) 84 :value '(nil t t))
85 85
86 (defcustom dragdrop-drop-functions '((dragdrop-drop-url-default t t) 86 (defcustom experimental-dragdrop-drop-functions '((experimental-dragdrop-drop-url-default t t)
87 (dragdrop-drop-mime-default t t)) 87 (experimental-dragdrop-drop-mime-default t t))
88 "This is the standart drop function search list. 88 "*{EXPERIMENTAL} This is the standart drop function search list.
89 Each element is a list of a function, a button selector, a modifier 89 Each element is a list of a function, a button selector, a modifier
90 selector and optional argumets to the function call. 90 selector and optional argumets to the function call.
91 The function must accept at least two arguments: first is the event 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 92 of the drop, second the object data, followed by any of the optional
93 arguments provided in this list. 93 arguments provided in this list.
94 The functions are called in order, until one returns t." 94 The functions are called in order, until one returns t."
95 :group 'drag-n-drop 95 :group 'drag-n-drop
96 :type '(repeat dragdrop-function-widget)) 96 :type '(repeat dragdrop-function-widget))
97 97
98 (defgroup dnd-debug nil 98 (defgroup dnd-debug nil
99 "Drag'n'Drop debugging options." 99 "*{EXPERIMENTAL} Drag'n'Drop debugging options."
100 :group 'drag-n-drop) 100 :group 'drag-n-drop)
101 101
102 (defcustom dragdrop-drop-log nil 102 (defcustom dragdrop-drop-log nil
103 "If non-nil, every drop is logged. 103 "*{EXPERIMENTAL} If non-nil, every drop is logged.
104 The name of the buffer is set in the custom 'dragdrop-drop-log-name" 104 The name of the buffer is set in the custom 'dragdrop-drop-log-name"
105 :group 'dnd-debug 105 :group 'dnd-debug
106 :type 'boolean) 106 :type 'boolean)
107 107
108 (defcustom dragdrop-drop-log-name "*drop log buffer*" 108 (defcustom dragdrop-drop-log-name "*drop log buffer*"
109 "The name of the buffer used to log drops. 109 "*{EXPERIMENTAL} The name of the buffer used to log drops.
110 Set dragdrop-drop-log to non-nil to enable this feature." 110 Set dragdrop-drop-log to non-nil to enable this feature."
111 :group 'dnd-debug 111 :group 'dnd-debug
112 :type 'string) 112 :type 'string)
113 113
114 (defvar dragdrop-drop-log-buffer nil 114 (defvar dragdrop-drop-log-buffer nil
115 "Buffer to log drops in debug mode.") 115 "*{EXPERIMENTAL} Buffer to log drops in debug mode.")
116 116
117 ;; 117 ;;
118 ;; Drop API 118 ;; Drop API
119 ;; 119 ;;
120 (defun dragdrop-drop-dispatch (object) 120 (defun dragdrop-drop-dispatch (object)
121 "This function identifies DROP type misc-user-events. 121 "*{EXPERIMENTAL} This function identifies DROP type misc-user-events.
122 It calls functions which will handle the drag." 122 It calls functions which will handle the drag."
123 (let ((event current-mouse-event)) 123 (let ((event current-mouse-event))
124 (and dragdrop-drop-log 124 (and dragdrop-drop-log
125 (dragdrop-drop-log-function event object)) 125 (experimental-dragdrop-drop-log-function event object))
126 (dragdrop-drop-find-functions event object))) 126 (dragdrop-drop-find-functions event object)))
127 127
128 (defun dragdrop-drop-find-functions (event object) 128 (defun dragdrop-drop-find-functions (event object)
129 "Finds valid drop-handle functions and executes them to dispose the drop. 129 "Finds valid drop-handle functions and executes them to dispose the drop.
130 It does this by looking for extent-properties called 'dragdrop-drop-functions 130 It does this by looking for extent-properties called
131 and for variables named like this." 131 'experimental-dragdrop-drop-functions and for variables named like this."
132 (catch 'dragdrop-drop-is-done 132 (catch 'dragdrop-drop-is-done
133 (and (event-over-text-area-p event) 133 (and (event-over-text-area-p event)
134 ;; let's search the extents 134 ;; let's search the extents
135 (catch 'dragdrop-extents-done 135 (catch 'dragdrop-extents-done
136 (let ((window (event-window event)) 136 (let ((window (event-window event))
139 (buffer nil)) 139 (buffer nil))
140 (or window (throw 'dragdrop-extents-done nil)) 140 (or window (throw 'dragdrop-extents-done nil))
141 (or pos (setq pos cpos)) 141 (or pos (setq pos cpos))
142 (select-window window) 142 (select-window window)
143 (setq buffer (window-buffer)) 143 (setq buffer (window-buffer))
144 (let ((ext (extent-at pos buffer 'dragdrop-drop-functions))) 144 (let ((ext (extent-at pos buffer 'experimental-dragdrop-drop-functions)))
145 (while (not (eq ext nil)) 145 (while (not (eq ext nil))
146 (dragdrop-drop-do-functions 146 (dragdrop-drop-do-functions
147 (extent-property ext 'dragdrop-drop-functions) 147 (extent-property ext 'experimental-dragdrop-drop-functions)
148 event 148 event
149 object) 149 object)
150 (setq ext (extent-at pos buffer 'dragdrop-drop-functions ext))))))) 150 (setq ext (extent-at pos buffer
151 ;; now look into the variable dragdrop-drop-functions 151 'experimental-dragdrop-drop-functions
152 (dragdrop-drop-do-functions dragdrop-drop-functions event object))) 152 ext)))))))
153 ;; now look into the variable experimental-dragdrop-drop-functions
154 (dragdrop-drop-do-functions experimental-dragdrop-drop-functions event object)))
153 155
154 (defun dragdrop-compare-mods (first-mods second-mods) 156 (defun dragdrop-compare-mods (first-mods second-mods)
155 "Returns t if both first-mods and second-mods contain the same elements. 157 "Returns t if both first-mods and second-mods contain the same elements.
156 Order is not important." 158 Order is not important."
157 (let ((moda (copy-sequence first-mods)) 159 (let ((moda (copy-sequence first-mods))
179 ;; (funcall (car flist) event object) 181 ;; (funcall (car flist) event object)
180 (throw 'dragdrop-drop-is-done t)) 182 (throw 'dragdrop-drop-is-done t))
181 (setq drop-funs (cdr drop-funs)))) 183 (setq drop-funs (cdr drop-funs))))
182 nil) 184 nil)
183 185
184 (defun dragdrop-drop-log-function (event object &optional message buffer) 186 (defun experimental-dragdrop-drop-log-function (event object &optional message buffer)
185 "Logs any drops into a buffer. 187 "*{EXPERIMENTAL} Logs any drops into a buffer.
186 If buffer is nil, it inserts the data into a buffer called after 188 If buffer is nil, it inserts the data into a buffer called after
187 dragdrop-drop-log-name. 189 dragdrop-drop-log-name.
188 If dragdrop-drop-log is non-nil, this is done automatically for each drop. 190 If dragdrop-drop-log is non-nil, this is done automatically for each drop.
189 The function always returns nil." 191 The function always returns nil."
190 (save-excursion 192 (save-excursion
221 (setq i (1+ i)) 223 (setq i (1+ i))
222 (setq data (cdr data)))) 224 (setq data (cdr data))))
223 (insert "----------\n")) 225 (insert "----------\n"))
224 nil) 226 nil)
225 227
226 (defun dragdrop-drop-url-default (event object) 228 (defun experimental-dragdrop-drop-url-default (event object)
227 "Default handler for dropped URL data. 229 "*{EXPERIMENTAL} Default handler for dropped URL data.
228 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."
229 (cond ((eq (car object) 'dragdrop-URL) 231 (cond ((eq (car object) 'dragdrop-URL)
230 (let ((data (cdr object)) 232 (let ((data (cdr object))
231 (frame (event-channel event)) 233 (frame (event-channel event))
232 (x pop-up-windows) 234 (x pop-up-windows)
251 (make-frame-visible frame) 253 (make-frame-visible frame)
252 (setq pop-up-windows x) 254 (setq pop-up-windows x)
253 t)) 255 t))
254 (t nil))) 256 (t nil)))
255 257
256 (defun dragdrop-drop-mime-default (event object) 258 (defun experimental-dragdrop-drop-mime-default (event object)
257 "Default handler for dropped MIME data. 259 "*{EXPERIMENTAL} Default handler for dropped MIME data.
258 Inserts text into buffer, creates MIME buffers for other types. 260 Inserts text into buffer, creates MIME buffers for other types.
259 Returns nil if object does not contain MIME data." 261 Returns nil if object does not contain MIME data."
260 (cond ((eq (car object) 'dragdrop-MIME) 262 (cond ((eq (car object) 'dragdrop-MIME)
261 (let ((ldata (cdr object)) 263 (let ((ldata (cdr object))
262 (frame (event-channel event)) 264 (frame (event-channel event))
340 (t nil))) 342 (t nil)))
341 343
342 ;; 344 ;;
343 ;; Drag API 345 ;; Drag API
344 ;; 346 ;;
345 (defun dragdrop-drag (event object) 347 (defun experimental-dragdrop-drag (event object)
346 "The generic drag function. 348 "*{EXPERIMENTAL} The generic drag function.
347 Tries to do the best with object in the selected protocol. 349 Tries to do the best with object in the selected protocol.
348 Object must comply to the standart drag'n'drop object 350 Object must comply to the standart drag'n'drop object
349 format." 351 format."
350 (error "Not implemented")) 352 (error "Not implemented"))
351 353
352 (defun dragdrop-drag-region (event begin end) 354 (defun experimental-dragdrop-drag-region (event begin end)
353 "Drag a region. 355 "*{EXPERIMENTAL} Drag a region.
354 This function uses special data types if the low-level 356 This function uses special data types if the low-level
355 protocol requires it. It does so by calling 357 protocol requires it. It does so by calling
356 dragdrop-drag-pure-text." 358 dragdrop-drag-pure-text."
357 (dragdrop-drag-pure-text event 359 (dragdrop-drag-pure-text event
358 (buffer-substring-no-properties begin end))) 360 (buffer-substring-no-properties begin end)))
359 361
360 (defun dragdrop-drag-pure-text (event text) 362 (defun experimental-dragdrop-drag-pure-text (event text)
361 "Drag text-only data. 363 "*{EXPERIMENTAL} Drag text-only data.
362 Takes care of special low-level protocol data types. 364 Takes care of special low-level protocol data types.
363 Text must be a list of strings." 365 Text must be a list of strings."
364 (error "Not implemented")) 366 (error "Not implemented"))
365 367
366 (defun dragdrop-drag-pure-file (event file) 368 (defun experimental-dragdrop-drag-pure-file (event file)
367 "Drag filepath-only data. 369 "*{EXPERIMENTAL} Drag filepath-only data.
368 Takes care of special low-level protocol data types. 370 Takes care of special low-level protocol data types.
369 file must be a list of strings." 371 file must be a list of strings."
370 (error "Not implemented")) 372 (error "Not implemented"))
371 373
372 ;; 374 ;;