Source

XEmacs / lisp / dragdrop.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
;;; dragdrop.el --- window system-independent Drag'n'Drop support.

;; Copyright (C) 1998 Oliver Graf <ograf@fga.de>

;; Maintainer: XEmacs Development Team, Oliver Graf <ograf@fga.de>
;; Keywords: drag, drop, dumped

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: Not in FSF.

;;; Commentary:

;; This file is dumped with XEmacs (when drag'n'drop support is compiled in).

;;; Code:

;; we need mouse-set-point
(require 'mouse)
(provide 'dragdrop)

;; I think this is a better name for the custom group
;; looks better in the menu and the group display as dragdrop
;; Anyway: is dragdrop- a good prefix for all this?
;; What if someone trys drop<TAB> in the minibuffer?
(defgroup drag-n-drop nil
  "Window system-independent drag'n'drop support."
  :group 'editing)

(defcustom dragdrop-drop-at-point nil
  "*If non-nil, the drop handler functions will drop text at the cursor location.
Otherwise, the cursor will be moved to the location of the pointer drop before
text is inserted."
  :type 'boolean
  :group 'drag-n-drop)

(defcustom dragdrop-autoload-tm-view nil
  "*If non-nil, autoload tm-view if a MIME buffer needs to be decoded.
Otherwise, the buffer is only decoded if tm-view is already avaiable."
  :type 'boolean
  :group 'drag-n-drop)

;; the widget for editing the drop-functions
(define-widget 'dragdrop-function-widget 'list
  "Widget for editing drop dispatch functions."
  :args `((choice :tag "Function"
		  (function-item dragdrop-drop-url-default)
		  (function-item dragdrop-drop-mime-default)
		  (function-item dragdrop-drop-log-function)
		  (function :tag "Other" nil))
	  (choice :tag "Button" :value t
		  (choice-item :tag "Ignore" t)
		  (choice-item 0) (choice-item 1) (choice-item 2)
		  (choice-item 3) (choice-item 4) (choice-item 5)
		  (choice-item 6) (choice-item 7))
	  (radio-button-choice :tag "Modifiers"
			       (const :tag "Ignore Modifier Keys" t)
			       (checklist :greedy t
					  :format "Modifier Keys:\n%v"
					  :extra-offset 6
					  (const shift)
					  (const control)
					  (const meta)
					  (const alt)
					  (const hyper)
					  (const super)))
	  (repeat :inline t :value nil :tag "Extra Function Arguments"
		  (sexp :tag "Arg" :value nil)))
  :value '(nil t t))

(defcustom dragdrop-drop-functions '((dragdrop-drop-url-default t t)
				     (dragdrop-drop-mime-default t t))
  "This is the standart drop function search list.
Each element is a list of a function, a button selector, a modifier
selector and optional argumets to the function call.
The function must accept at least two arguments: first is the event
of the drop, second the object data, followed by any of the optional
arguments provided in this list.
The functions are called in order, until one returns t."
  :group 'drag-n-drop
  :type '(repeat dragdrop-function-widget))

(defgroup dnd-debug nil
  "Drag'n'Drop debugging options."
  :group 'drag-n-drop)

(defcustom dragdrop-drop-log nil
  "If non-nil, every drop is logged.
The name of the buffer is set in the custom 'dragdrop-drop-log-name"
  :group 'dnd-debug
  :type 'boolean)

(defcustom dragdrop-drop-log-name "*drop log buffer*"
  "The name of the buffer used to log drops.
Set dragdrop-drop-log to non-nil to enable this feature."
  :group 'dnd-debug
  :type 'string)

(defvar dragdrop-drop-log-buffer nil
  "Buffer to log drops in debug mode.")

;;
;; Drop API
;;
(defun dragdrop-drop-dispatch (object)
  "This function identifies DROP type misc-user-events.
It calls functions which will handle the drag."
  (let ((event current-mouse-event))
    (and dragdrop-drop-log
	 (dragdrop-drop-log-function event object))
    (dragdrop-drop-find-functions event object)))

(defun dragdrop-drop-find-functions (event object)
  "Finds valid drop-handle functions and executes them to dispose the drop.
It does this by looking for extent-properties called 'dragdrop-drop-functions
and for variables named like this."
  (catch 'dragdrop-drop-is-done
    (and (event-over-text-area-p event)
	 ;; let's search the extents
	 (catch 'dragdrop-extents-done
	   (let ((window (event-window event))
		 (pos (event-point event))
		 (cpos (event-closest-point event))
		 (buffer nil))
	     (or window (throw 'dragdrop-extents-done nil))
	     (or pos (setq pos cpos))
	     (select-window window)
	     (setq buffer (window-buffer))
	     (let ((ext (extent-at pos buffer 'dragdrop-drop-functions)))
	       (while (not (eq ext nil))
		 (dragdrop-drop-do-functions
		  (extent-property ext 'dragdrop-drop-functions)
		  event
		  object)
		 (setq ext (extent-at pos buffer 'dragdrop-drop-functions ext)))))))
    ;; now look into the variable dragdrop-drop-functions
    (dragdrop-drop-do-functions dragdrop-drop-functions event object)))

(defun dragdrop-compare-mods (first-mods second-mods)
  "Returns t if both first-mods and second-mods contain the same elements.
Order is not important."
  (let ((moda (copy-sequence first-mods))
	(modb (copy-sequence second-mods)))
    (while (and (not (eq moda ()))
		(not (eq modb ())))
      (setq modb (delete (car moda) modb))
      (setq moda (delete (car moda) moda)))
    (and (eq moda ())
	 (eq modb ()))))

(defun dragdrop-drop-do-functions (drop-funs event object)
  "Calls all functions in drop-funs with object until one returns t.
Returns t if one of drop-funs returns t. Otherwise returns nil."
  (let ((flist nil)
	(button (event-button event))
	(mods (event-modifiers event)))
    (while (not (eq drop-funs ()))
      (setq flist (car drop-funs))
      (and (or (eq (cadr flist) t)
	       (= (cadr flist) button))
	   (or (eq (caddr flist) t)
	       (dragdrop-compare-mods (caddr flist) modifiers))
	   (apply (car flist) `(,event ,object ,@(cdddr flist)))
	   ;; (funcall (car flist) event object)
	   (throw 'dragdrop-drop-is-done t))
      (setq drop-funs (cdr drop-funs))))
  nil)

(defun dragdrop-drop-log-function (event object &optional message buffer)
  "Logs any drops into a buffer.
If buffer is nil, it inserts the data into a buffer called after
dragdrop-drop-log-name.
If dragdrop-drop-log is non-nil, this is done automatically for each drop.
The function always returns nil."
  (save-excursion
    (cond ((buffer-live-p buffer)
	   (set-buffer buffer))
	  ((stringp buffer)
	   (set-buffer (get-buffer-create buffer)))
	  ((buffer-live-p dragdrop-drop-log-buffer)
	   (set-buffer dragdrop-drop-log-buffer))
	  (t
	   (setq dragdrop-drop-log-buffer (get-buffer-create dragdrop-drop-log-name))
	   (set-buffer dragdrop-drop-log-buffer)))
    (insert (format "* %s: %s\n"
		    (current-time-string)
		    (if message message "received a drop")))
    (insert (format "  at %d,%d (%d,%d) with button %d and mods %s\n"
		    (event-x event)
		    (event-y event)
		    (event-x-pixel event)
		    (event-y-pixel event)
		    (event-button event)
		    (event-modifiers event)))
    (insert (format "  data is of type %s (%d %s)\n"
	     (cond ((eq (car object) 'dragdrop-URL) "URL")
		   ((eq (car object) 'dragdrop-MIME) "MIME")
		   (t "UNKNOWN"))
	     (length (cdr object))
	     (if (= (length (cdr object)) 1) "element" "elements")))
    (let ((i 1)
	  (data (cdr object)))
      (while (not (eq data ()))
	(insert (format "    Element %d: %S\n"
			i (car data)))
	(setq i (1+ i))
	(setq data (cdr data))))
    (insert "----------\n"))
  nil)

(defun dragdrop-drop-url-default (event object)
  "Default handler for dropped URL data.
Finds files and URLs. Returns nil if object does not contain URL data."
  (cond ((eq (car object) 'dragdrop-URL)
	 (let ((data (cdr object))
	       (frame (event-channel event))
	       (x pop-up-windows)
	       (window (event-window event)))
	   (setq pop-up-windows nil)
	   (while (not (eq data ()))
	     (cond ((dragdrop-is-some-url "file" (car data))
		    ;; if it is some file, pop it to a buffer
		    (cond (window
			   (select-window window)))
		    (switch-to-buffer (find-file-noselect
				       (substring (car data) 5))))
		   ;; to-do: open ftp URLs with efs...
		   (t 
		    ;; some other URL, try to fire up some browser for it
		    (if (boundp 'browse-url-browser-function)
			(funcall browse-url-browser-function (car data))
		      (display-message 'error 
			"Can't show URL, no browser selected"))))
	     (undo-boundary)
	     (setq data (cdr data)))
	   (make-frame-visible frame)
	   (setq pop-up-windows x)
	   t))
	(t nil)))

(defun dragdrop-drop-mime-default (event object)
  "Default handler for dropped MIME data.
Inserts text into buffer, creates MIME buffers for other types.
Returns nil if object does not contain MIME data."
  (cond ((eq (car object) 'dragdrop-MIME)
	 (let ((ldata (cdr object))
	       (frame (event-channel event))
	       (x pop-up-windows)
	       (data nil))
	   ;; how should this be handled???
	   ;; insert drops of text/* into buffer
	   ;; create new buffer if pointer is outside buffer...
	   ;; but there are many other ways...
	   ;;	
	   ;; first thing: check if it's only text/plain and if the
	   ;; drop happened inside some buffer. if yes insert it into
	   ;; this buffer (hope it is not encoded in some MIME way)
	   ;;
	   ;; Remember: ("text/plain" "dosnotmatter" "somedata")
	   ;; drops are inserted at mouse-point, if inside a buffer
	   (while (not (eq ldata ()))
	     (setq data (car ldata))
	     (if (and (listp data)
		      (= (length data) 3)
		      (listp (car data))
		      (stringp (caar data))
		      (string= (caar data) "text/plain")
		      (event-over-text-area-p event))
		 (let ((window (event-window event)))
		   (and window
			(select-window window))
		   (and (not dragdrop-drop-at-point)
			(mouse-set-point event))
		   (insert (caddr data)))
	       (let ((buf (get-buffer-create "*MIME-Drop data*")))
		 (set-buffer buf)
		 (pop-to-buffer buf nil frame)
		 (or (featurep 'tm-view)
		     (and dragdrop-autoload-tm-view
			  (require 'tm-view)))
		 (cond ((stringp data)
			;; this is some raw MIME stuff
			;; create some buffer and let tm do the job
			;;
			;; this is always the same buffer!!!
			;; change?
			(erase-buffer)
			(insert data)
			(and (featurep 'tm-view)
			     (mime/viewer-mode buf)))
		       ((and (listp data)
			     (= (length data) 3))
			;; change the internal content-type representation to the
			;; way tm does it ("content/type" (key . value)*)
			;; but for now list will do the job
			;;
			;; this is always the same buffer!!!
			;; change?
			(erase-buffer)
			(insert (caddr data))
			(and (featurep 'tm-view)
			     ;; this list of (car data) should be done before
			     ;; enqueing the event
			     (mime/viewer-mode buf (car data) (cadr data))))
		       (t
			(display-message 'error "Wrong drop data")))))
	     (undo-boundary)
	     (setq ldata (cdr ldata)))
	   (make-frame-visible frame)
	   (setq pop-up-windows x))
	 t)
	(t nil)))

(defun dragdrop-is-some-url (method url)
  "Returns true if method equals the start of url.
If method does not end into ':' this is appended before the
compare."
  (cond ((and (stringp url)
	      (stringp method)
	      (> (length url) (length method)))
	 ;; is this ?: check efficient enough?
	 (if (not (string= (substring method -1) ":"))
	     (setq method (concat method ":")))
	 (string= method (substring url 0 (length method))))
	(t nil)))

;;
;; Drag API
;;
(defun dragdrop-drag (event object)
  "The generic drag function.
Tries to do the best with object in the selected protocol.
Object must comply to the standart drag'n'drop object 
format."
  (error "Not implemented"))

(defun dragdrop-drag-region (event begin end)
  "Drag a region.
This function uses special data types if the low-level
protocol requires it. It does so by calling
dragdrop-drag-pure-text."
  (dragdrop-drag-pure-text event
			   (buffer-substring-no-properties begin end)))

(defun dragdrop-drag-pure-text (event text)
  "Drag text-only data.
Takes care of special low-level protocol data types.
Text must be a list of strings."
  (error "Not implemented"))

(defun dragdrop-drag-pure-file (event file)
  "Drag filepath-only data.
Takes care of special low-level protocol data types.
file must be a list of strings."
  (error "Not implemented"))

;;
;; The following ones come from frame.el but the better belong here
;; until changed
;;
(defun cde-start-drag (event type data)
  "Implement the CDE drag operation.
Calls the internal function cde-start-drag-internal to do the actual work."
  (interactive "_eXX")
  (if (featurep 'cde)
      ;; Avoid build-time doc string warning by calling the function
      ;; in the following roundabout way:
      (funcall (intern "cde-start-drag-internal")
	       event type data)
    (error "CDE functionality not compiled in.")))

(defun cde-start-drag-region (event begin end)
  "Implement the CDE drag operation for a region.
Calls the internal function CDE-start-drag-internal to do the actual work.
This always does buffer transfers."
  ;; Oliver Graf <ograf@fga.de>
  (interactive "_er")
  (if (featurep 'cde)
      (funcall (intern "cde-start-drag-internal")
	       event nil (list (buffer-substring-no-properties begin end)))
    (error "CDE functionality not compiled in.")))

;; the OffiX drag stuff will soon move also (perhaps mouse.el)
;; if the drag event is done
(defun offix-start-drag (event data &optional type)
  "Implement the OffiX drag operation.
Calls the internal function offix-start-drag-internal to do the actual work.
If type is not given, DndText is assumed."
  ;; Oliver Graf <ograf@fga.de>
  (interactive "esi")
  (if (featurep 'offix)
      (funcall (intern "offix-start-drag-internal") event data type)
    (error "OffiX functionality not compiled in.")))

(defun offix-start-drag-region (event begin end)
  "Implement the OffiX drag operation for a region.
Calls the internal function offix-start-drag-internal to do the actual work.
This always assumes DndText as type."
  ;; Oliver Graf <ograf@fga.de>
  (interactive "_er")
  (if (featurep 'offix)
      (funcall (intern "offix-start-drag-internal")
	       event (buffer-substring-no-properties begin end))
    (error "OffiX functionality not compiled in.")))


;;; dragdrop.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.