Mercurial > hg > xemacs-beta

comparison lisp/hm--html-menus/internal-drag-and-drop.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 6a22abad6937
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; $Id: internal-drag-and-drop.el,v 1.4 1997/03/26 22:42:40 steve Exp $ 1 ;;; $Id: internal-drag-and-drop.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $
2 ;;; 2 ;;;
3 ;;; Copyright (C) 1996, 1997 Heiko Muenkel 3 ;;; Copyright (C) 1996 Heiko Muenkel
4 ;;; email: muenkel@tnt.uni-hannover.de 4 ;;; email: muenkel@tnt.uni-hannover.de
5 ;;; 5 ;;;
6 ;;; This program is free software; you can redistribute it and/or modify 6 ;;; This program is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU General Public License as published by 7 ;;; it under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 1, or (at your option) 8 ;;; the Free Software Foundation; either version 1, or (at your option)
22 ;;; 22 ;;;
23 ;;; This package provides functions to define and call internal 23 ;;; This package provides functions to define and call internal
24 ;;; drag and drop actions in the emacs. One could start such an 24 ;;; drag and drop actions in the emacs. One could start such an
25 ;;; action by clicking with the mouse in the source buffer and 25 ;;; action by clicking with the mouse in the source buffer and
26 ;;; then in the destination buffer. The action could depend on 26 ;;; then in the destination buffer. The action could depend on
27 ;;; the points where you've clicked with the mouse, on the state 27 ;;; the points where youve clicked with the mouse, on the state
28 ;;; of the region, the point, the mark and any other properties 28 ;;; of the region, the point, the mark and any other properties
29 ;;; of the source and the destination buffers. The actions are 29 ;;; of the source and the destination buffers. The actions are
30 ;;; defined by the variable `idd-actions', which is a buffer local 30 ;;; defined by the variable `idd-actions', which is a buffer local
31 ;;; variable. The following is an example for the hm--html-mode: 31 ;;; variable. The following is an example for the html-mode:
32 ;;; (defvar hm--html-idd-actions 32 ;;; (defvar html-idd-actions
33 ;;; '((nil (((idd-if-major-mode-p . dired-mode) 33 ;;; '((nil (((idd-major-mode-p . dired-mode)
34 ;;; (idd-if-dired-file-on-line-p 34 ;;; (idd-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpq\\)"))
35 ;;; . ".*\\.\\(gif\\)\\|\\(jpq\\)"))
36 ;;; hm--html-idd-add-include-image-from-dired-line) 35 ;;; hm--html-idd-add-include-image-from-dired-line)
37 ;;; (((idd-if-major-mode-p . dired-mode) 36 ;;; (((idd-major-mode-p . dired-mode)
38 ;;; (idd-if-dired-no-file-on-line-p . nil)) 37 ;;; (idd-dired-no-file-on-line-p . nil))
39 ;;; hm--html-idd-add-file-link-to-file-on-dired-line) 38 ;;; hm--html-idd-add-file-link-to-file-on-dired-line)
40 ;;; (((idd-if-major-mode-p . dired-mode) 39 ;;; (((idd-major-mode-p . dired-mode)
41 ;;; (idd-if-dired-no-file-on-line-p . t)) 40 ;;; (idd-dired-no-file-on-line-p . t))
42 ;;; hm--html-idd-add-file-link-to-directory-of-buffer) 41 ;;; hm--html-idd-add-file-link-to-directory-of-buffer)
43 ;;; (((idd-if-major-mode-p . w3-mode) 42 ;;; (((idd-major-mode-p . w3-mode)
44 ;;; (idd-if-url-at-point-p . t)) 43 ;;; (idd-url-at-point-p . t))
45 ;;; hm--html-idd-add-html-link-from-w3-buffer-point) 44 ;;; hm--html-idd-add-html-link-from-w3-buffer-point)
46 ;;; (((idd-if-major-mode-p . w3-mode)) 45 ;;; (((idd-major-mode-p . w3-mode))
47 ;;; hm--html-idd-add-html-link-to-w3-buffer) 46 ;;; hm--html-idd-add-html-link-to-w3-buffer)
48 ;;; (((idd-if-local-file-p . t)) 47 ;;; (((idd-local-file-p . t))
49 ;;; hm--html-idd-add-file-link-to-buffer))) 48 ;;; hm--html-idd-add-file-link-to-buffer)))
50 ;;; Look at the variable `idd-actions' for further descriptions. 49 ;;; Look at the variable `idd-actions' for further descriptions.
51 ;;; 50 ;;;
52 ;;; 51 ;;;
53 ;;; 52 ;;;
59 ;;; (autoload 'idd-mouse-drag-and-drop "internal-drag-and-drop" 58 ;;; (autoload 'idd-mouse-drag-and-drop "internal-drag-and-drop"
60 ;;; "Performs a drag and drop action. 59 ;;; "Performs a drag and drop action.
61 ;;; At first you must click on the source and 60 ;;; At first you must click on the source and
62 ;;; after that on the destination." 61 ;;; after that on the destination."
63 ;;; t) 62 ;;; t)
63 ;;; (define-key global-map [(meta button1)] 'idd-mouse-drag-and-drop)
64 ;;; 64 ;;;
65 ;;; Define actions in the variable `idd-actions'. 65 ;;; Define actions in the variable `idd-actions'.
66 ;;; 66 ;;;
67 ;;; The variable `idd-global-mouse-keys' defines the mouse keys, 67
68 ;;; which are bound to the drag and drop command. 68 (defvar idd-actions nil
69 ;;;
70 ;;; The variable `idd-drag-and-drop-mouse-binding-type' determines
71 ;;; if you've to hold a mouse button down during moving the mouse
72 ;;; from the source to the destination or not.
73 ;;;
74
75 (require 'adapt)
76 (require 'cl)
77
78 (defvar idd-global-mouse-keys (if (adapt-emacs19p)
79 [(meta control mouse-1)]
80 [(meta control button1)])
81 "The mouse keys for the command `idd-mouse-drag-and-drop'.
82 The command `idd-mouse-drag-and-drop' is bound during the loading
83 of the package internal-drag-and-drop to this keys in the global
84 key map.
85
86 Set it to nil, if you don't want to bind this function during loading.
87
88 If the command is already bound in the global keymap during loading,
89 then this key sequence will not be bind.")
90
91 (defvar idd-global-help-mouse-keys (if (adapt-emacs19p)
92 [(meta control mouse-3)]
93 [(meta control button3)])
94 "The mouse keys for the command `idd-help-mouse-drag-and-drop'.
95 The command `idd-help-mouse-drag-and-drop' is bound during the loading
96 of the package internal-drag-and-drop to this keys in the global
97 key map.
98
99 Set it to nil, if you don't want to bind this function during loading.
100
101 If the command is already bound in the global keymap during loading,
102 then this key sequence will not be bind.")
103
104 (defvar idd-drag-and-drop-mouse-binding-type 'click
105 "*The type of the drag and drop mouse binding.
106 The value maybe `click or 'press-button-during-move.
107 A value of `click means, that you've to click over the source, leave
108 the button and click it again over the destination.
109 A value of 'press-button-during-move means, that you've to press
110 the button down over the source and hold it until the mouse pointer
111 is over the destination.
112
113 The disadvantage of the `press-button-during-move' type compared with
114 the `click' type is, that you can't select a destination region and
115 therefore a drag and drop action depending on a selected region can't
116 be started with that type of mouse binding.")
117
118 (defvar idd-actions '((((idd-if-region-active-p . nil))
119 (((idd-if-region-active-p . t))
120 idd-action-copy-region))
121
122 (((idd-if-region-active-p . t))
123 (((idd-if-region-active-p . t))
124 idd-action-copy-replace-region))
125
126 (((idd-if-region-active-p . nil)
127 (idd-if-modifiers-p . nil))
128 (((idd-if-region-active-p . t))
129 idd-action-move-region))
130
131 (((idd-if-region-active-p . t)
132 (idd-if-modifiers-p . nil))
133 (((idd-if-region-active-p . t))
134 idd-action-move-replace-region))
135 )
136 "The list with actions, depending on the source and the destination. 69 "The list with actions, depending on the source and the destination.
137 The list looks like: 70 The list looks like:
138 '((<destination-specification-1> (<source-specification-1> <action-1-1>) 71 '((<source-specification-1> (<destination-specification-1> <action-1-1>)
139 (<source-specification-2> <action-1-2>) 72 (<destination-specification-2> <action-1-2>)
140 : 73 :
141 ) 74 )
142 (<destination-specification-2> (<source-specification-1> <action-2-1>) 75 (<source-specification-2> (<destination-specification-1> <action-2-1>)
143 (<source-specification-2> <action-2-2>) 76 (<destination-specification-2> <action-2-2>)
144 : 77 :
145 ) 78 )
146 : 79 :
147 ) 80 )
148 The <source-specification> looks like the following: 81 The <source-specification> looks like the following:
149 '([(<specification-type> <value>)]) 82 '([(<specification-type> <value>)])
150 with <specification-type> :== idd-if-minor-mode-p | idd-if-buffer-name-p 83 with <specification-type> :== idd-minor-mode-p | idd-buffer-name-p
151 | idd-if-region-active-p | idd-if-url-at-point-p 84 | idd-region-active-p ...
152 | idd-if-major-mode-p | idd-if-variable-non-nil-p 85
153 | idd-if-dired-file-on-line-p 86 The <destination-specification> looks like <source-specification>, except
154 | idd-if-dired-no-file-on-line-p 87 that a valid <specification-type> is also idd-major-mode-p.
155 | idd-if-local-file-p | idd-if-buffer-name-p 88
156 | idd-if-modifiers-p | ... 89 If <source-specification-1> or <destination-specification-1> is set to
157 90 nil, then every source or destination matches. `idd-actions' is a
158 The <specification-type> - functions must have two arguments, the first one
159 is the source or destination and the second is the <value>. It must return
160 nil, if the test wasn't successfull and a number (in general 1), which
161 specifies the weight of the test function. The weights of all single tests
162 are added to a summary weight and assigned to the action. The action
163 with the highest weight is called from the action handler. Look at
164 the definition of `idd-if-major-mode-p', `idd-if-minor-mode-p' and so on for
165 examples. Look at the function `idd-get-source-or-destination-alist', if
166 you wan't to know the structure of the 'source-or-destination' argument
167 of these functions.
168
169 The <destination-specification> looks like <source-specification>,
170 but in general it could be set to nil in mode specific idd-action
171 lists.
172
173 If <destination-specification-1> or <source-specification-1> is set to
174 nil, then every source or source matches. `idd-actions' is a
175 buffer local variable, which should be at least mode depended. So if 91 buffer local variable, which should be at least mode depended. So if
176 the <destination-specification-1> is set to nil it says, that the destination 92 the <source-specification-1> is set to nil it says, that the source
177 buffer must only have a specific mode. But however, it's also possible 93 buffer must only have a specific mode. But however, it's also possible
178 to define a general `idd-actions' list, where the destination mode is 94 to define a general `idd-actions' list, where the source mode is
179 specified by `idd-if-major-mode-p'. 95 specified by idd-major-mode-p.
180 96
181 <action> ist a function, which has two arguments, the first specifies the 97 <action> ist a function, which has two arguments, the specifies the
182 source and the second the destination. Look at the function definition 98 source and the second the destination.")
183 of `idd-action-copy-region' and `idd-action-copy-replace-region'. They are
184 examples for such actions.")
185 99
186 (make-variable-buffer-local 'idd-actions) 100 (make-variable-buffer-local 'idd-actions)
187
188 (defvar idd-help-instead-of-action nil
189 "*If this variable is t, then a help buffer is displayed.
190 No action will be performed if this variable is t.")
191
192 (defvar idd-help-start-action-keymap nil
193 "Keymap used in an extent in the help buffer to start the action.")
194
195 (defvar idd-help-source nil
196 "Contains the source of an action. Used only in the help buffer.")
197
198 (defvar idd-help-destination nil
199 "Contains the destination of an action. Used only in the help buffer.")
200
201 (defvar idd-help-start-extent nil
202 "The start extent in the help buffer.")
203 101
204 (defun idd-compare-a-specification (source-or-destination 102 (defun idd-compare-a-specification (source-or-destination
205 specification) 103 specification)
206 "Tests if SOURCE-OR-DESTINATION matches the SPECIFICATION. 104 "Tests if SOURCE-OR-DESTINATION matches the SPECIFICATION.
207 It returns a value (1 in general) if both are matching or nil." 105 It returns a value (1 in general) if both are matching or nil."
208 (eval (list (car specification) 106 (eval (list (car specification)
209 'source-or-destination 107 'source-or-destination
210 '(cdr specification)))) 108 '(cdr specification))))
211 109
212 (defun idd-compare-specifications-1 (source-or-destination 110 (defun idd-compare-specifications-1 (source-or-destination
213 specifications 111 specifications
214 value) 112 value)
215 "Internal function of `idd-compare-specifications'. 113 "Internal function of `idd-compare-specifications'.
216 VALUE is the value of the last matches." 114 VALUE is the value of the last matches."
217 (cond ((not specifications) value) 115 (cond ((not specifications) value)
218 (t (let ((match (idd-compare-a-specification source-or-destination 116 (t (let ((match (idd-compare-a-specification source-or-destination
219 (car specifications)))) 117 (car specifications))))
221 (t (idd-compare-specifications-1 source-or-destination 119 (t (idd-compare-specifications-1 source-or-destination
222 (cdr specifications) 120 (cdr specifications)
223 (+ value match)))))))) 121 (+ value match))))))))
224 122
225 (defun idd-compare-specifications (source-or-destination 123 (defun idd-compare-specifications (source-or-destination
226 specifications) 124 specifications)
227 "Determines how good SOURCE-OR-DESTINATION and SPECIFICATIONS are matching. 125 "Determines how good SOURCE-OR-DESTINATION and SPECIFICATIONS are matching.
228 A return value of zero means, that they don't match. The higher the 126 A return value of zero means, that they don't match. The higher the
229 return value the better is the matching." 127 return value the better is the matching."
230 (cond ((not specifications) 1) 128 (cond ((not specifications) 1)
231 (t (idd-compare-specifications-1 source-or-destination 129 (t (idd-compare-specifications-1 source-or-destination
232 specifications 130 specifications
233 0)))) 131 0))))
234 132
235 (defun idd-get-action-depending-on-source (source 133 (defun idd-get-action-depending-on-destination (destination
236 actions-depending-on-source 134 actions-depending-on-dest
237 destination-value 135 source-value
238 value-action-pair) 136 value-action-pair)
239 "Internal function of `idd-get-action-depending-on-source-and-destination'." 137 "Internal function of `idd-get-action-depending-on-source-and-destination'."
240 (let ((source-value (idd-compare-specifications 138 (let ((destination-value (idd-compare-specifications
241 source 139 destination
242 (car (car actions-depending-on-source))))) 140 (car (car actions-depending-on-dest)))))
243 (cond ((not actions-depending-on-source) value-action-pair) 141 (cond ((not actions-depending-on-dest) value-action-pair)
244 ((or (= source-value 0) 142 ((or (= destination-value 0)
245 (<= (+ destination-value source-value) (car value-action-pair))) 143 (<= (+ source-value destination-value) (car value-action-pair)))
246 (idd-get-action-depending-on-source 144 (idd-get-action-depending-on-destination
247 source 145 destination
248 (cdr actions-depending-on-source) 146 (cdr actions-depending-on-dest)
249 destination-value 147 source-value
250 value-action-pair)) 148 value-action-pair))
251 (t (idd-get-action-depending-on-source 149 (t (idd-get-action-depending-on-destination
252 source 150 destination
253 (cdr actions-depending-on-source) 151 (cdr actions-depending-on-dest)
254 destination-value 152 source-value
255 (cons (+ destination-value source-value) 153 (cons (+ source-value destination-value)
256 (second (car actions-depending-on-source)))))))) 154 (second (car actions-depending-on-dest))))))))
257 155
258 (defun idd-get-action-depending-on-source-and-destination (source 156 (defun idd-get-action-depending-on-source-and-destination (source
259 destination 157 destination
260 actions 158 actions
261 value-action-pair) 159 value-action-pair)
262 "Internal function of `idd-get-action'. 160 "Internal function of `idd-get-action'.
263 VALUE-ACTION-PAIR is a list like (<value> <action>). 161 VALUE-ACTION-PAIR is a list like (<value> <action>).
264 It returns VALUE-ACTION-PAIR, if no other action is found, which has a 162 It returns VALUE-ACTION-PAIR, if no other action is found, which has a
265 value higher than (car VALUE-ACTION-PAIR)." 163 value higher than (car VALUE-ACTION-PAIR)."
266 (let ((destination-value 164 (let ((source-value (idd-compare-specifications source (car (car actions)))))
267 (idd-compare-specifications destination (car (car actions)))))
268 (cond ((not actions) value-action-pair) 165 (cond ((not actions) value-action-pair)
269 ((= destination-value 0) 166 ((= source-value 0)
270 (idd-get-action-depending-on-source-and-destination 167 (idd-get-action-depending-on-source-and-destination
271 source 168 source
272 destination 169 destination
273 (cdr actions) 170 (cdr actions)
274 value-action-pair)) 171 value-action-pair))
275 (t (idd-get-action-depending-on-source-and-destination 172 (t (idd-get-action-depending-on-source-and-destination
276 source 173 source
277 destination 174 destination
278 (cdr actions) 175 (cdr actions)
279 (idd-get-action-depending-on-source 176 (idd-get-action-depending-on-destination
280 source 177 destination
281 (cdr (car actions)) 178 (cdr (car actions))
282 destination-value 179 source-value
283 value-action-pair)))))) 180 value-action-pair))))))
284 181
285 (defun idd-get-action (source destination actions) 182 (defun idd-get-action (source destination actions)
286 "Returns the action, which depends on the SOURCE and the DESTINATION. 183 "Returns the action, which depends on the SOURCE and the DESTINATION.
287 The list ACTIONS contains all possible actions. Look at the variable 184 The list ACTIONS contains all possible actions. Look at the variable
289 (idd-get-action-depending-on-source-and-destination source 186 (idd-get-action-depending-on-source-and-destination source
290 destination 187 destination
291 actions 188 actions
292 '(0 . nil))) 189 '(0 . nil)))
293 190
294 ;(autoload 'ange-ftp-ftp-path "ange-ftp"
295 ; "Parse PATH according to ange-ftp-path-format (which see).
296 ;Returns a list (HOST USER PATH), or nil if PATH does not match the format.")
297
298 (defun idd-set-point (source-or-destination)
299 "Sets the point and buffer to SOURCE-OR-DESTINATION."
300 (set-buffer (cdr (assoc ':buffer source-or-destination)))
301 (goto-char (cdr (assoc ':drag-or-drop-point source-or-destination))))
302
303 (defun idd-set-region (source-or-destination)
304 "Sets the point, mark and buffer to SOURCE-OR-DESTINATION.
305 The region is active after this function is called."
306 (set-buffer (cdr (assoc ':buffer source-or-destination)))
307 (goto-char (car (cdr (assoc ':region-active source-or-destination))))
308 (set-mark (cdr (cdr (assoc ':region-active source-or-destination))))
309 (activate-region))
310
311
312 ;;; Specification type functions for the list `idd-actions'
313
314 (defun idd-if-region-active-p (source-or-destination value)
315 "Checks if the region in the SOURCE-OR-DESTINATION was active.
316 It returns 1, if the region was active and VALUE is t, or if
317 the region was not active and VALUE is nil. Otherwise it returns
318 nil."
319 (if (cdr (assoc ':region-active source-or-destination))
320 (if value 1 nil)
321 (if value nil 1)))
322
323 (defun idd-get-buffer-url (source-or-destination) 191 (defun idd-get-buffer-url (source-or-destination)
324 "Returns the URL of the buffer specified by SOURCE-OR-DESTINATION." 192 "Returns the URL of the buffer specified by SOURCE-OR-DESTINATION."
325 (save-excursion 193 (save-excursion
326 (idd-set-point source-or-destination) 194 (idd-set-point source-or-destination)
327 (url-view-url t))) 195 (url-view-url t)))
331 It returns nil, if there is no URL." 199 It returns nil, if there is no URL."
332 (save-excursion 200 (save-excursion
333 (idd-set-point source-or-destination) 201 (idd-set-point source-or-destination)
334 (w3-view-this-url t))) 202 (w3-view-this-url t)))
335 203
336 (defun idd-if-url-at-point-p (source-or-destination value) 204 (defun idd-url-at-point-p (source-or-destination value)
337 "Checks if there is an URL at the point of SOURCE-OR-DESTINATION. 205 "Checks if there is an URL at the point of SOURCE-OR-DESTINATION.
338 If that is t and VALUE is t, or that is nil and VALUE is nil, then 1 206 If that is t and VALUE is t, or that is nil and VALUE is nil, then 1
339 is returned. Otherwise nil is returned." 207 is returned. Otherwise nil is returned."
340 (if value 208 (if value
341 (if (idd-get-url-at-point source-or-destination) 209 (if (idd-get-url-at-point source-or-destination)
343 nil) 211 nil)
344 (if (idd-get-url-at-point source-or-destination) 212 (if (idd-get-url-at-point source-or-destination)
345 nil 213 nil
346 1))) 214 1)))
347 215
348 (defun idd-if-major-mode-p (source-or-destination mode) 216 (defun idd-major-mode-p (source-or-destination mode)
349 "Checks, if the major mode of SOURCE-OR-DESTINATION is MODE. 217 "Checks, if the major mode of SOURCE-OR-DESTINATION is MODE.
350 It returns 1, if that is t and nil otherwise." 218 It returns 1, if that is t and nil otherwise."
351 (save-excursion 219 (save-excursion
352 (set-buffer (cdr (assoc ':buffer source-or-destination))) 220 (set-buffer (cdr (assoc ':buffer source-or-destination)))
353 (if (eq major-mode mode) 221 (if (eq major-mode mode)
354 1 222 1
355 nil))) 223 nil)))
356 224
357 (defun idd-if-variable-non-nil-p (source-or-destination variable) 225 (defun idd-set-point (source-or-destination)
358 "Checks, if the variable named VARIABLE isn't t in SOURCE-OR-DESTINATION. 226 "Sets the point and buffer to SOURCE-OR-DESTINATION."
359 It returns 1, if this is t." 227 (set-buffer (cdr (assoc ':buffer source-or-destination)))
360 (save-excursion 228 (goto-char (cdr (assoc ':drag-or-drop-point source-or-destination))))
361 (set-buffer (cdr (assoc ':buffer source-or-destination))) 229
362 (if (eval variable) 230 (defun idd-set-region (source-or-destination)
363 1 231 "Sets the point, mark and buffer to SOURCE-OR-DESTINATION.
364 nil))) 232 The region is active after this function is called."
365 233 (set-buffer (cdr (assoc ':buffer source-or-destination)))
366 (defun idd-if-minor-mode-p (source-or-destination minor-mode-variable) 234 (goto-char (car (cdr (assoc ':region-active source-or-destination))))
367 "Checks, if the variable MINOR-MODE-VARIABLE is t in SOURCE-OR-DESTINATION. 235 (set-mark (cdr (cdr (assoc ':region-active source-or-destination))))
368 MINOR-MODE-VARIABLE is the name of the variable!." 236 (activate-region))
369 (idd-if-variable-non-nil-p source-or-destination minor-mode-variable))
370 237
371 (defun idd-get-dired-filename-from-line (source-or-destination) 238 (defun idd-get-dired-filename-from-line (source-or-destination)
372 "Returns the filename form the line in a dired buffer. 239 "Returns the filename form the line in a dired buffer.
373 The position and the buffer is specified by SOURCE-OR-DESTINATION." 240 The position and the buffer is specified by SOURCE-OR-DESTINATION."
374 (save-excursion 241 (save-excursion
375 (idd-set-point source-or-destination) 242 (idd-set-point source-or-destination)
376 (dired-get-filename nil t))) 243 (dired-get-filename nil t)))
377 244
378 (defun idd-if-dired-file-on-line-p (source-or-destination filename-regexp) 245 (defun idd-dired-file-on-line-p (source-or-destination filename-regexp)
379 "Checks, if the filename on the line match FILENAME-REGEXP. 246 "Checks, if the filename on the line match FILENAME-REGEXP.
380 The function `dired-get-filename' is used, to get the filename from 247 The function `dired-get-filename' is used, to get the filename from
381 the SOURCE-OR-DESTINATION. It returns 1, if it matchs or nil." 248 the SOURCE-OR-DESTINATION. It returns 1, if it matchs or nil."
382 (let ((case-fold-search t)) 249 (let ((case-fold-search t))
383 (if (and (idd-get-dired-filename-from-line source-or-destination) 250 (if (and (idd-get-dired-filename-from-line source-or-destination)
385 (idd-get-dired-filename-from-line 252 (idd-get-dired-filename-from-line
386 source-or-destination))) 253 source-or-destination)))
387 1 254 1
388 nil))) 255 nil)))
389 256
390 (defun idd-if-dired-no-file-on-line-p (source-or-destination value) 257 (defun idd-dired-no-file-on-line-p (source-or-destination value)
391 "Checks, if a filename is in the dired buffer of SOURCE-OR-DESTINATION. 258 "Checks, if a filename is in the dired buffer of SOURCE-OR-DESTINATION.
392 It returns 1, if a filename is on the line and if VALUE is t, or if 259 It returns 1, if a filename is on the line and if VALUE is t, or if
393 no filename is on the line and VALUE is nil, otherwise it returns 260 no filename is on the line and VALUE is nil, otherwise it returns
394 nil. For the test the function `dired-get-filename' is used." 261 nil. For the test the function `dired-get-filename' is used."
395 (if (idd-get-dired-filename-from-line source-or-destination) 262 (if (idd-get-dired-filename-from-line source-or-destination)
396 (if value nil 1) 263 (if value nil 1)
397 (if value 1 nil))) 264 (if value 1 nil)))
398 265
266 (autoload 'ange-ftp-ftp-path "ange-ftp"
267 "Parse PATH according to ange-ftp-path-format (which see).
268 Returns a list (HOST USER PATH), or nil if PATH does not match the format.")
269
399 (defun idd-get-local-filename (source-or-destination) 270 (defun idd-get-local-filename (source-or-destination)
400 "Returns the filename of a local file specified by SOURCE-OR-DESTINATION." 271 "Returns the filename of a local file specified by SOURCE-OR-DESTINATION."
401 (buffer-file-name (cdr (assoc ':buffer source-or-destination)))) 272 (buffer-file-name (cdr (assoc ':buffer source-or-destination))))
402 273
403 (defun idd-get-directory-of-buffer (source-or-destination) 274 (defun idd-get-directory-of-buffer (source-or-destination)
404 "Returns the directory name assigned to the SOURCE-OR-DESTINATION buffer." 275 "Returns the directory name assigned to the SOURCE-OR-DESTINATION buffer."
405 (save-excursion 276 (save-excursion
406 (idd-set-point source-or-destination) 277 (idd-set-point source-or-destination)
407 default-directory)) 278 default-directory))
408 279
409 (defun idd-if-local-file-p (source-or-destination value) 280 (defun idd-local-file-p (source-or-destination value)
410 "Checks, if SOURCE-OR-DESTINATION has a file on the local filesystem. 281 "Checks, if SOURCE-OR-DESTINATION has a file on the local filesystem.
411 If that is t and VALUE is t, or that is nil and VALUE is nil, then 1 282 If that is t and VALUE is t, or that is nil and VALUE is nil, then 1
412 is returned. Otherwise nil is returned." 283 is returned. Otherwise nil is returned."
413 (let ((filename (idd-get-local-filename source-or-destination))) 284 (let ((filename (idd-get-local-filename source-or-destination)))
414 (if (and filename 285 (if (and filename
415 ; (not (ange-ftp-ftp-path filename))) 286 (not (ange-ftp-ftp-path filename)))
416 (not (file-remote-p filename)))
417 (if value 1 nil) 287 (if value 1 nil)
418 (if value nil 1)))) 288 (if value nil 1))))
419
420 (defun idd-if-buffer-name-p (source-or-destination buffer-name)
421 "Checks, if SOURCE-OR-DESTINATION has a buffer called BUFFER-NAME.
422 It returns 1 if this is the case or nil otherwise."
423 (if (string= buffer-name
424 (buffer-name (cdr (assoc ':buffer source-or-destination))))
425 1
426 nil))
427
428 (defun idd-list-1-subset-of-list-2 (list-1 list-2)
429 "Returns t, if LIST-1 is a subset of LIST-2."
430 (cond ((not list-1))
431 ((member (car list-1) list-2)
432 (idd-list-1-subset-of-list-2 (cdr list-1) list-2))
433 (t nil)))
434
435 (defun idd-same-elements-p (list-1 list-2)
436 "Returns t, if both list have the same modifiers."
437 (and (= (length list-1) (length list-2))
438 (idd-list-1-subset-of-list-2 list-1 list-2)))
439
440 (defun idd-if-modifiers-p (source-or-destination modifiers)
441 "Checks, if the MODIFIERS hold during selecting the SOURCE-OR-DESTINATION.
442 Returns 1, if the list MODIFIERS contains the same modifiers,
443 or if any modyfiers are hold and MODIFIERS is t,
444 or if no modyfiers are hold and MODIFIERS is nil.
445 Otherwise nil is returned."
446 (let ((event-modifiers (event-modifiers
447 (cdr (assoc ':event source-or-destination)))))
448 (cond ((not modifiers)
449 (if event-modifiers nil 1))
450 ((listp modifiers)
451 (if (idd-same-elements-p modifiers event-modifiers)
452 1
453 nil))
454 (t (if event-modifiers 1 nil)))))
455
456 ;;; action functions
457
458 (defun idd-action-copy-region (source destination)
459 "Copy the region from DESTINATION to SOURCE."
460 (idd-set-region source)
461 (let ((region-contents (buffer-substring (point) (mark))))
462 (idd-set-point destination)
463 (insert region-contents)))
464
465 (defun idd-action-copy-replace-region (source destination)
466 "Copy the region from SOURCE and replace the DESTINATION region with it."
467 (idd-set-region source)
468 (let ((region-contents (buffer-substring (point) (mark))))
469 (idd-set-region destination)
470 (delete-region (point) (mark))
471 (insert region-contents)))
472
473 (defmacro* idd-with-source-and-destination (source
474 destination
475 &key
476 do-in-source
477 do-in-destination)
478 "Macro, usefull for the definition of action functions.
479 Look at the example `idd-action-move-region'."
480 `(progn
481 (if (idd-if-region-active-p ,source t)
482 (idd-set-region ,source)
483 (idd-set-point ,source))
484 ,(when do-in-source
485 (cons 'progn do-in-source))
486 (if (idd-if-region-active-p ,destination t)
487 (idd-set-region ,destination)
488 (idd-set-point ,destination))
489 ,(when do-in-destination
490 (cons 'progn do-in-destination))))
491
492 (defun idd-action-move-region (source destination)
493 "Move the region from SOURCE to DESTINATION."
494 (let ((region))
495 (idd-with-source-and-destination
496 source destination
497 :do-in-source ((setq region (buffer-substring (point) (mark)))
498 (delete-region (point) (mark)))
499 :do-in-destination ((insert region)))))
500
501
502 (defun idd-action-move-replace-region (source destination)
503 "Delete the region at SOURCE and overwrite the DESTINATION region with it."
504 (let ((region))
505 (idd-with-source-and-destination
506 source destination
507 :do-in-source ((setq region (buffer-substring (point) (mark)))
508 (delete-region (point) (mark)))
509 :do-in-destination ((delete-region (point) (mark))
510 (insert region)))))
511
512
513 ;;; Performing the drag and drop
514
515 (defun idd-display-help-about-action (action source destination)
516 "Display a help buffer with information about the action."
517 (if (> (car action) 0)
518 (if (symbol-function (cdr action))
519 (progn
520 (with-displaying-help-buffer
521 '(lambda ()
522 (set-buffer "*Help*")
523 (setq idd-help-source source)
524 (setq idd-help-destination destination)
525 (insert "Drag and drop action: `")
526 (let ((start (point)))
527 (insert (format "%s" (cdr action)))
528 (setq idd-help-start-extent (make-extent start (point)))
529 (set-extent-mouse-face idd-help-start-extent 'highlight)
530 (set-extent-face idd-help-start-extent 'bold)
531 (set-extent-keymap idd-help-start-extent
532 idd-help-start-action-keymap)
533 )
534 (insert "'\n")
535 (insert (format "Source buffer : `%s'\n"
536 (buffer-name (cdr (assoc ':buffer source)))))
537 (insert (format "Destination buffer : `%s'\n"
538 (buffer-name (cdr (assoc ':buffer destination))
539 )))
540 (insert "=================================================="
541 "====================\n")
542 (insert "Look at `idd-actions' in the "
543 "destination buffer for other actions!\n")
544 (insert (format "The documentation of `%s':\n\n"
545 (cdr action)))
546 (insert (documentation (cdr action)))))
547 )
548 (error "Error: Action %s isn't a valid function!" (cdr action)))
549 (message "No valid action defined for this source and this destination!")))
550 289
551 (defun idd-call-action (action source destination) 290 (defun idd-call-action (action source destination)
552 "Calls the drag and drop ACTION with its arguments SOURCE and DESTINATION." 291 "Calls the drag and drop ACTION with its arguments SOURCE and DESTINATION."
553 (if (> (car action) 0) 292 (if (> (car action) 0)
554 (if (symbol-function (cdr action)) 293 (if (symbol-function (cdr action))
555 (eval (list (cdr action) 'source 'destination)) 294 (eval (list (cdr action) 'source 'destination))
556 (error "Error: Action %s isn't a valid function!" (cdr action))) 295 (error "Error: Action %s isn't a valid function!" (cdr action)))
557 (message "No valid action defined for this source and this destination!"))) 296 (message "No valid action defined for this source and this destination!")))
558 297
559 (defun idd-start-help-mouse-drag-and-drop ()
560 "Starts help on `idd-start-mouse-drag-and-drop'."
561 (interactive)
562 (let ((idd-help-instead-of-action t))
563 (idd-start-mouse-drag-and-drop)))
564
565 (defun idd-start-mouse-drag-and-drop ()
566 "Starts a drag and drop command.
567 This command could be used to start a drag and drop command without a
568 button event. Therefore this should not be bind direct to a mouse button."
569 (interactive)
570 (let ((source-event)
571 (drag-and-drop-message "Drag&Drop: Click on the source!"))
572 (message drag-and-drop-message)
573 (setq source-event
574 (next-command-event nil drag-and-drop-message))
575 (if (button-press-event-p source-event)
576 (idd-mouse-drag-and-drop source-event)
577 (message "Wrong event! Exit drag and drop."))))
578
579 (defun idd-help-mouse-drag-and-drop (source-event)
580 "Displays help about the drag and drop action."
581 (interactive "@e")
582 (let ((idd-help-instead-of-action t))
583 (idd-mouse-drag-and-drop source-event)))
584
585 (defun idd-mouse-drag-and-drop (source-event) 298 (defun idd-mouse-drag-and-drop (source-event)
586 "Performs a drag and drop action. 299 "Performs a drag and drop action.
587 It calls the command `idd-mouse-drag-and-drop-click' or 300 At first you must click on the source and after that on the destination."
588 `idd-mouse-drag-and-drop-press-button-during-move' depending on
589 the value of `idd-drag-and-drop-mouse-binding-type'."
590 (interactive "@e") 301 (interactive "@e")
591 (if (eq idd-drag-and-drop-mouse-binding-type 'click) 302 (let ((source (list (cons ':buffer (current-buffer))
592 (idd-mouse-drag-and-drop-click source-event) 303 (cons ':drag-or-drop-point
593 (idd-mouse-drag-and-drop-press-button-during-move source-event))) 304 (event-closest-point source-event))
594 305 (cons ':region-active (if (region-active-p)
595 (defun idd-get-source-or-destination-alist (event) 306 (cons (point)
596 "Returns an alist with the description of a source or destination point. 307 (mark))))))
597 The EVENT must be the button event, which has selected the source or
598 destination of the drag and drop command.
599
600 The alist has the following structure:
601 '((:buffer . <buffer-of-the-event>)
602 (:drag-or-drop-point . <closest-point-to-the-event>)
603 (:region-active . <t-or-nil>)
604 (:event . EVENT))
605
606 Note: <closest-point-to-the-event> is (event-closest-point EVENT),
607 if the EVENT is a mouse event and if it isn't nil. Otherwise the
608 point is used."
609 ; (set-buffer (event-buffer event))
610 (list (cons ':buffer (event-buffer event))
611 (cons ':drag-or-drop-point (set-marker
612 (make-marker)
613 (if (mouse-event-p event)
614 (or (event-closest-point event)
615 (point))
616 (point))))
617 (cons ':region-active (if (region-active-p)
618 (cons (set-marker (make-marker) (point))
619 (set-marker (make-marker) (mark)))))
620 (cons ':event event))
621 )
622
623 (defun idd-mouse-drag-and-drop-press-button-during-move (source-event)
624 "Performs a drag and drop action.
625 At first you must press the button down over the source and then
626 move with the pressed button to the destination, where you must leave
627 the button up.
628 This must be bind to a mouse button. The SOURCE-EVENT must be a
629 button-press-event.
630
631 The disadvantage of this command compared with the command
632 `idd-mouse-drag-and-drop-click' is, that you can't select a
633 destination region."
634 (interactive "@e")
635 (let ((drag-and-drop-message
636 "Drag&Drop: Leave the button over the destination!")
637 (source (idd-get-source-or-destination-alist source-event))
638 (destination nil) 308 (destination nil)
639 (destination-event)) 309 (destination-event))
640 (message drag-and-drop-message) 310 (if (adapt-xemacsp)
641 (setq destination-event
642 (next-command-event nil drag-and-drop-message))
643 (message "")
644 (cond ((button-release-event-p destination-event)
645 (setq destination (idd-get-source-or-destination-alist
646 destination-event))
647 (idd-set-point destination)
648 (if idd-help-instead-of-action
649 (idd-display-help-about-action (idd-get-action source
650 destination
651 idd-actions)
652 source
653 destination)
654 (idd-call-action (idd-get-action source destination idd-actions)
655 source
656 destination)))
657 (t (message "Wrong event! Exit drag and drop.") nil))))
658
659 (defun idd-mouse-drag-and-drop-click (source-event)
660 "Performs a drag and drop action.
661 At first you must click on the source and after that on the destination.
662 This must be bind to a mouse button. The SOURCE-EVENT must be a
663 button-press-event."
664 (interactive "@e")
665 (let ((drag-and-drop-message "Drag&Drop: Click on the destination!")
666 (source (idd-get-source-or-destination-alist source-event))
667 (destination nil)
668 (destination-event))
669 (message drag-and-drop-message)
670 (if (and (adapt-xemacsp) (mouse-event-p source-event))
671 (dispatch-event (next-command-event))) 311 (dispatch-event (next-command-event)))
672 (setq destination-event 312 (setq destination-event
673 (next-command-event nil drag-and-drop-message)) 313 (next-command-event nil "Drag&Drop: Click on the destination!"))
674 (message "")
675 (cond ((button-press-event-p destination-event) 314 (cond ((button-press-event-p destination-event)
676 (mouse-track destination-event) 315 (setq destination (list (cons ':buffer
677 (setq destination (idd-get-source-or-destination-alist 316 (event-buffer destination-event))
678 destination-event)) 317 (cons ':drag-or-drop-point
679 (idd-set-point destination) 318 (event-closest-point
319 destination-event))
320 (cons ':region-active nil)))
680 (if (adapt-emacs19p) 321 (if (adapt-emacs19p)
681 (while (not (button-release-event-p (next-command-event))))) 322 (while (not (button-release-event-p (next-command-event)))))
682 (if idd-help-instead-of-action 323 (idd-call-action (idd-get-action source destination idd-actions)
683 (idd-display-help-about-action (idd-get-action source 324 source
684 destination 325 destination))
685 idd-actions) 326 (t (setq action "Wrong event") nil))))
686 source
687 destination)
688 (idd-call-action (idd-get-action source destination idd-actions)
689 source
690 destination)))
691 ((and (adapt-emacs19p)
692 (button-click-event-p destination-event))
693 (setq destination (idd-get-source-or-destination-alist
694 destination-event))
695 (idd-set-point destination)
696 (if idd-help-instead-of-action
697 (idd-display-help-about-action (idd-get-action source
698 destination
699 idd-actions)
700 source
701 destination)
702 (idd-call-action (idd-get-action source destination idd-actions)
703 source
704 destination)))
705 (t (message "Wrong event! Exit drag and drop.") nil))))
706
707 (defun idd-help-start-action (event)
708 "Used to start the action from the help buffer."
709 (interactive "@e")
710 (idd-set-point idd-help-destination)
711 (idd-call-action (idd-get-action idd-help-source
712 idd-help-destination
713 idd-actions)
714 idd-help-source
715 idd-help-destination)
716 (delete-extent idd-help-start-extent))
717
718 ;; keymap for help buffer extents
719 (if (not idd-help-start-action-keymap)
720 (progn
721 (setq idd-help-start-action-keymap
722 (make-sparse-keymap 'idd-help-start-action-keymap))
723 (if (adapt-emacs19p)
724 (define-key idd-help-start-action-keymap [(mouse-2)]
725 'idd-help-start-action)
726 (define-key idd-help-start-action-keymap "[(button2)]"
727 'idd-help-start-action))))
728
729 ;; global key bindings
730 (when idd-global-mouse-keys
731 (unless (where-is-internal 'idd-mouse-drag-and-drop global-map t)
732 (define-key global-map idd-global-mouse-keys 'idd-mouse-drag-and-drop))
733 (unless (where-is-internal 'idd-help-mouse-drag-and-drop global-map t)
734 (define-key global-map
735 idd-global-help-mouse-keys 'idd-help-mouse-drag-and-drop)))
736 327
737 328
738 (provide 'internal-drag-and-drop) 329 (provide 'internal-drag-and-drop)