Mercurial > hg > xemacs-beta

comparison lisp/hm--html-menus/internal-drag-and-drop.el @ 98:0d2f883870bc r20-1b1

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