Mercurial > hg > xemacs-beta

comparison tests/Dnd/droptest.el @ 288:e11d67e05968 r21-0b42

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b42
author cvs
date Mon, 13 Aug 2007 10:35:54 +0200
parents 558f606b08ae
children c9fe270a4101
comparison
equal deleted inserted replaced
287:13a0bd77a29d 288:e11d67e05968
2 ;; combination with extents. 2 ;; combination with extents.
3 ;; 3 ;;
4 4
5 (defun dnd-drop-message (event object text) 5 (defun dnd-drop-message (event object text)
6 (message "Dropped %s with :%s" text object) 6 (message "Dropped %s with :%s" text object)
7 ;; signal that we have done something with the data
7 t) 8 t)
8 9
9 (defun do-nothing (event object) 10 (defun do-nothing (event object)
11 ;; signal that the data is still unprocessed
10 nil) 12 nil)
11 13
12 (defun start-drag (event what &optional typ) 14 (defun start-drag (event what &optional typ)
15 ;; short drag interface, until the real one is implemented
13 (cond ((featurep 'offix) 16 (cond ((featurep 'offix)
14 (if (numberp typ) 17 (if (numberp typ)
15 (offix-start-drag event what typ) 18 (offix-start-drag event what typ)
16 (offix-start-drag event what))) 19 (offix-start-drag event what)))
17 ((featurep 'cde) 20 ((featurep 'cde)
18 (funcall (intern "cde-start-drag-internal") what)) 21 (if (not typ)
22 (funcall (intern "cde-start-drag-internal") event nil (list what))
23 (funcall (intern "cde-start-drag-internal") event t what)))
19 (t display-message 'error "no valid drag protocols implemented"))) 24 (t display-message 'error "no valid drag protocols implemented")))
20 25
21 (defun make-drop-targets () 26 (defun make-drop-targets ()
22 (let ((buf (get-buffer-create "*DND misc-user extent test buffer*")) 27 (let ((buf (get-buffer-create "*DND misc-user extent test buffer*"))
23 (s nil) 28 (s nil)
60 (ext nil) 65 (ext nil)
61 (kmap nil)) 66 (kmap nil))
62 (set-buffer buf) 67 (set-buffer buf)
63 (pop-to-buffer buf) 68 (pop-to-buffer buf)
64 (erase-buffer buf) 69 (erase-buffer buf)
65 (insert "Try to drag data from one of the upper extents to one\nof the lower extents. Make sure that your minibuffer is big\ncause it is used to display the data.\n\nYou may also try to select some of this text and drag it with button2.") 70 (insert "Try to drag data from one of the upper extents to one\nof the lower extents. Make sure that your minibuffer is big\ncause it is used to display the data.\n\nYou may also try to select some of this text and drag it with button2.\n\nTo ")
71 (setq s (point))
72 (insert "EXIT")
73 (setq e (point))
74 (insert " this demo, press 'q'.")
75 (setq ext (make-extent s e))
76 (setq kmap (make-keymap))
77 (define-key kmap [button1] 'end-dnd-demo)
78 (set-extent-property ext 'keymap kmap)
79 (set-extent-property ext 'mouse-face 'highlight)
66 (newline 2) 80 (newline 2)
67 (setq s (point)) 81 (setq s (point))
68 (insert "[ TEXT DRAG TEST ]") 82 (insert "[ TEXT DRAG TEST ]")
69 (setq e (point)) 83 (setq e (point))
70 (setq ext (make-extent s e)) 84 (setq ext (make-extent s e))
77 (insert "[ FILE DRAG TEST ]") 91 (insert "[ FILE DRAG TEST ]")
78 (setq e (point)) 92 (setq e (point))
79 (setq ext (make-extent s e)) 93 (setq ext (make-extent s e))
80 (set-extent-property ext 'mouse-face 'isearch) 94 (set-extent-property ext 'mouse-face 'isearch)
81 (setq kmap (make-keymap)) 95 (setq kmap (make-keymap))
82 (define-key kmap [button1] 'file-drag) 96 (if (featurep 'cde)
97 (define-key kmap [button1] 'cde-file-drag)
98 (define-key kmap [button1] 'file-drag))
83 (set-extent-property ext 'keymap kmap) 99 (set-extent-property ext 'keymap kmap)
84 (insert " ") 100 (insert " ")
85 (setq s (point)) 101 (setq s (point))
86 (insert "[ FILES DRAG TEST ]") 102 (insert "[ FILES DRAG TEST ]")
87 (setq e (point)) 103 (setq e (point))
95 (insert "[ URL DRAG TEST ]") 111 (insert "[ URL DRAG TEST ]")
96 (setq e (point)) 112 (setq e (point))
97 (setq ext (make-extent s e)) 113 (setq ext (make-extent s e))
98 (set-extent-property ext 'mouse-face 'isearch) 114 (set-extent-property ext 'mouse-face 'isearch)
99 (setq kmap (make-keymap)) 115 (setq kmap (make-keymap))
100 (define-key kmap [button1] 'url-drag) 116 (if (featurep 'cde)
117 (define-key kmap [button1] 'cde-file-drag)
118 (define-key kmap [button1] 'url-drag))
101 (set-extent-property ext 'keymap kmap) 119 (set-extent-property ext 'keymap kmap)
102 (newline 3))) 120 (newline 3)))
103 121
104 (defun text-drag (event) 122 (defun text-drag (event)
105 (interactive "@e") 123 (interactive "@e")
107 125
108 (defun file-drag (event) 126 (defun file-drag (event)
109 (interactive "@e") 127 (interactive "@e")
110 (start-drag event "/tmp/printcap" 2)) 128 (start-drag event "/tmp/printcap" 2))
111 129
130 (defun cde-file-drag (event)
131 (interactive "@e")
132 (start-drag event '("/tmp/printcap") t))
133
112 (defun url-drag (event) 134 (defun url-drag (event)
113 (interactive "@e") 135 (interactive "@e")
114 (start-drag event "http://www.xemacs.org/" 8)) 136 (start-drag event "http://www.xemacs.org/" 8))
115 137
116 (defun files-drag (event) 138 (defun files-drag (event)
117 (interactive "@e") 139 (interactive "@e")
118 (start-drag event '("/tmp/dragtest" "/tmp/droptest" "/tmp/printcap") 3)) 140 (start-drag event '("/tmp/dragtest" "/tmp/droptest" "/tmp/printcap") 3))
119 141
120 (setq dragdrop-drop-functions '((do-nothing t t) 142 (setq dragdrop-drop-functions '((do-nothing t t)
143 ;; CDE does not have any button info...
144 (dnd-drop-message 0 t "cde-drop somewhere else")
121 (dnd-drop-message 2 t "region somewhere else") 145 (dnd-drop-message 2 t "region somewhere else")
122 (dnd-drop-message 1 t "drag-source somewhere else") 146 (dnd-drop-message 1 t "drag-source somewhere else")
123 (do-nothing t t))) 147 (do-nothing t t)))
148
124 (make-drag-starters) 149 (make-drag-starters)
125 (make-drop-targets) 150 (make-drop-targets)
151
152 (defun end-dnd-demo ()
153 (interactive)
154 (global-set-key [button2] button2-func)
155 (bury-buffer))
156
157 (setq lmap (make-keymap))
158 (use-local-map lmap)
159 (local-set-key [q] 'end-dnd-demo)
160 (setq button2-func (lookup-key global-map [button2]))
161 (global-unset-key [button2])