Mercurial > hg > xemacs-beta

comparison lisp/dragdrop.el @ 282:c42ec1d1cded r21-0b39

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b39
author cvs
date Mon, 13 Aug 2007 10:33:18 +0200
parents
children 558f606b08ae
comparison
equal deleted inserted replaced
281:090b52736db2 282:c42ec1d1cded
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>
6 ;; Keywords: drag, drop, dumped
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 window system support is compiled in).
30
31 ;;; Code:
32
33 (provide 'dragdrop)
34
35 ;; we need mouse-set-point
36 (require 'mouse)
37
38 ;; I think this is a better name for the custom group
39 ;; looks better in the menu and the group display as dragdrop
40 (defgroup drag-n-drop nil
41 "Window system-independent drag'n'drop support."
42 :group 'editing)
43
44 (defcustom dragdrop-drop-at-point nil
45 "*If non-nil, the drop handler functions will drop text at the cursor location.
46 Otherwise, the cursor will be moved to the location of the pointer drop before
47 text is inserted."
48 :type 'boolean
49 :group 'drag-n-drop)
50
51 (defcustom dragdrop-autoload-tm-view nil
52 "*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 :type 'boolean
55 :group 'drag-n-drop)
56
57 (defcustom dragdrop-drop-functions '(dragdrop-drop-url-default
58 dragdrop-drop-mime-default)
59 "This is the standart drop function search list.
60 Each variable in this list is called with the drop data until
61 one of the functions return t, or the end of the list is reached."
62 :group 'drag-n-drop
63 :type '(repeat (choice (function-item dragdrop-drop-url-default)
64 (function-item dragdrop-drop-mime-default)
65 (function :tag "other"))))
66
67 (defun dragdrop-drop-dispatch (object)
68 "This function identifies DROP type misc-user-events.
69 It tries to find out how to handle the dropped data by looking
70 for dragdrop-drop-functions in extents and variables."
71 (catch 'dragdrop-drop-is-done
72 (and (event-over-text-area-p current-mouse-event)
73 ;; let's search the extents
74 (catch 'dragdrop-extents-done
75 (let ((window (event-window current-mouse-event))
76 (pos (event-point current-mouse-event))
77 (cpos (event-closest-point current-mouse-event))
78 (buffer nil))
79 (or window (throw 'dragdrop-extents-done nil))
80 (or pos (setq pos cpos))
81 (select-window window)
82 (setq buffer (window-buffer))
83 (let ((ext (extent-at pos buffer 'dragdrop-drop-functions)))
84 (while (not (eq ext nil))
85 (dragdrop-drop-do-functions
86 (extent-property ext 'dragdrop-drop-functions)
87 object)
88 (setq ext (extent-at pos buffer 'dragdrop-drop-functions ext)))))))
89 ;; now look into the variable dragdrop-drop-functions
90 (dragdrop-drop-do-functions dragdrop-drop-functions object)))
91
92 (defun dragdrop-drop-do-functions (drop-funs object)
93 "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."
95 (while (not (eq drop-funs ()))
96 (and (funcall (car drop-funs) object)
97 (throw 'dragdrop-drop-is-done t))
98 (setq drop-funs (cdr drop-funs)))
99 nil)
100
101 (defun dragdrop-drop-url-default (object)
102 "Default handler for dropped URL data.
103 Finds files and URLs. Returns nil if object does not contain URL data."
104 (cond ((eq (car object) 'dragdrop-URL)
105 (let ((data (cdr object))
106 (frame (event-channel current-mouse-event))
107 (x pop-up-windows))
108 (setq pop-up-windows nil)
109 (while (not (eq data ()))
110 (cond ((dragdrop-is-some-url "file" (car data))
111 ;; if it is some file, pop it to a buffer
112 (pop-to-buffer (find-file-noselect
113 (substring (car data) 5))
114 nil frame))
115 ;; to-do: open ftp URLs with efs...
116 (t
117 ;; some other URL, try to fire up some browser for it
118 (if (boundp 'browse-url-browser-function)
119 (funcall browse-url-browser-function (car data))
120 (display-message 'error
121 "Can't show URL, no browser selected"))))
122 (undo-boundary)
123 (setq data (cdr data)))
124 (make-frame-visible frame)
125 (setq pop-up-windows x)
126 t))
127 (t nil)))
128
129 (defun dragdrop-drop-mime-default (object)
130 "Default handler for dropped MIME data.
131 Inserts text into buffer, creates MIME buffers for other types.
132 Returns nil if object does not contain MIME data."
133 (cond ((eq (car object) 'dragdrop-MIME)
134 (let ((ldata (cdr object))
135 (frame (event-channel current-mouse-event))
136 (x pop-up-windows)
137 (data nil))
138 ;; how should this be handled???
139 ;; insert drops of text/* into buffer
140 ;; create new buffer if pointer is outside buffer...
141 ;; but there are many other ways...
142 ;;
143 ;; first thing: check if it's only text/plain and if the
144 ;; drop happened inside some buffer. if yes insert it into
145 ;; this buffer (hope it is not encoded in some MIME way)
146 ;;
147 ;; Remember: ("text/plain" "dosnotmatter" "somedata")
148 ;; drops are inserted at mouse-point, if inside a buffer
149 (while (not (eq ldata ()))
150 (setq data (car ldata))
151 (if (and (listp data)
152 (= (length data) 3)
153 (string= (car data) "text/plain")
154 (event-over-text-area-p current-mouse-event))
155 (let ((window (event-window current-mouse-event)))
156 (and window
157 (select-window window))
158 (and (not dragdrop-drop-at-point)
159 (mouse-set-point current-mouse-event))
160 (insert (caddr data)))
161 (let ((buf (get-buffer-create "*MIME-Drop data*")))
162 (set-buffer buf)
163 (pop-to-buffer buf nil frame)
164 (or (featurep 'tm-view)
165 (and dragdrop-autoload-tm-view
166 (require 'tm-view)))
167 (cond ((stringp data)
168 ;; this is some raw MIME stuff
169 ;; create some buffer and let tm do the job
170 ;;
171 ;; this is always the same buffer!!!
172 ;; change?
173 (erase-buffer)
174 (insert data)
175 (and (featurep 'tm-view)
176 (mime/viewer-mode buf)))
177 ((and (listp data)
178 (= (length data) 3))
179 ;; change the internal content-type representation to the
180 ;; way tm does it ("content/type" (key . value)*)
181 ;; but for now list will do the job
182 ;;
183 ;; this is always the same buffer!!!
184 ;; change?
185 (erase-buffer)
186 (insert (caddr data))
187 (and (featurep 'tm-view)
188 ;; this list of (car data) should be done before
189 ;; enqueing the event
190 (mime/viewer-mode buf (list (car data)) (cadr data))))
191 (t
192 (display-message 'error "Wrong drop data")))))
193 (undo-boundary)
194 (setq ldata (cdr ldata)))
195 (make-frame-visible frame)
196 (setq pop-up-windows x))
197 t)
198 (t nil)))
199
200 (defun dragdrop-is-some-url (method url)
201 "Returns true if method equals the start of url.
202 If method does not end into ':' this is appended before the
203 compare."
204 (cond ((and (stringp url)
205 (stringp method)
206 (> (length url) (length method)))
207 ;; is this ?: check efficient enough?
208 (if (not (string= (substring method -1) ":"))
209 (setq method (concat method ":")))
210 (string= method (substring url 0 (length method))))
211 (t nil)))
212
213 ;;; dragdrop.el ends here