Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-widget.el @ 14:9ee227acff29 r19-15b90

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b90
author cvs
date Mon, 13 Aug 2007 08:48:42 +0200
parents ac2d302a0011
children 0293115a14e9
comparison
equal deleted inserted replaced
13:13c6d0aaafe5 14:9ee227acff29
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;;; w3-widget.el --- An image widget 1 ;;; w3-widget.el --- An image widget
3 ;; Author: wmperry 2 ;; Author: wmperry
4 ;; Created: 1996/07/21 18:11:36 3 ;; Created: 1996/12/29 01:27:32
5 ;; Version: 1.3 4 ;; Version: 1.12
6 ;; Keywords: faces, help, comm, news, mail, processes, mouse, hypermedia 5 ;; Keywords: faces, images
7 6
8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
10 ;;; 9 ;;; Copyright (c) 1996 Free Software Foundation, Inc.
11 ;;; This file is not part of GNU Emacs, but the same permissions apply. 10 ;;;
11 ;;; This file is part of GNU Emacs.
12 ;;; 12 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify 13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by 14 ;;; it under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 2, or (at your option) 15 ;;; the Free Software Foundation; either version 2, or (at your option)
16 ;;; any later version. 16 ;;; any later version.
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details. 21 ;;; GNU General Public License for more details.
22 ;;; 22 ;;;
23 ;;; You should have received a copy of the GNU General Public License 23 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to 24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307, USA.
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27 28
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29 ;;; This is a widget that will do the best it can with an image. 30 ;;; This is a widget that will do the best it can with an image.
30 ;;; 31 ;;;
49 ;;; These are either URLs (http://foo/...) or alternative text. 50 ;;; These are either URLs (http://foo/...) or alternative text.
50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 52
52 (require 'cl) 53 (require 'cl)
53 (require 'widget) 54 (require 'widget)
54 (require 'w3-vars) 55
55 (require 'w3-mouse) 56 (defvar widget-image-keymap (make-sparse-keymap)
56
57 (defvar w3-image-widget-keymap (make-sparse-keymap)
58 "Keymap used over glyphs in an image widget") 57 "Keymap used over glyphs in an image widget")
59 58
60 (define-key w3-image-widget-keymap (vector w3-mouse-button1) 59 (defconst widget-mouse-button1 nil)
61 'w3-image-widget-button-press) 60 (defconst widget-mouse-button2 nil)
62 (define-key w3-image-widget-keymap (vector w3-mouse-button2) 61 (defconst widget-mouse-button3 nil)
63 'w3-image-widget-button-press) 62
63 (if (string-match "XEmacs" (emacs-version))
64 (if (featurep 'mouse)
65 (setq widget-mouse-button1 'button1
66 widget-mouse-button2 'button2
67 widget-mouse-button3 'button3)
68 (setq widget-mouse-button1 'return
69 widget-mouse-button2 'return
70 widget-mouse-button3 'return))
71 (setq widget-mouse-button1 'mouse-1
72 widget-mouse-button2 'mouse-2
73 widget-mouse-button3 'mouse-3))
74
75 (define-key widget-image-keymap (vector widget-mouse-button1)
76 'widget-image-button-press)
77 (define-key widget-image-keymap (vector widget-mouse-button2)
78 'widget-image-button-press)
64 79
65 (define-widget 'image 'default 80 (define-widget 'image 'default
66 "A fairly complex image widget." 81 "A fairly complex image widget."
67 :convert-widget 'w3-image-widget-convert 82 :convert-widget 'widget-image-convert
68 :value-to-internal (lambda (widget value) value) 83 :value-to-internal (lambda (widget value) value)
69 :value-to-external (lambda (widget value) value) 84 :value-to-external (lambda (widget value) value)
70 :value-set 'w3-image-widget-value-set 85 :value-set 'widget-image-value-set
71 :create 'w3-image-widget-create 86 :create 'widget-image-create
72 :delete 'w3-image-widget-delete 87 :delete 'widget-image-delete
73 :value-create 'w3-image-widget-value-create 88 :value-create 'widget-image-value-create
74 :value-delete 'w3-image-widget-value-delete 89 :value-delete 'widget-image-value-delete
75 :value-get 'w3-image-widget-value-get 90 :value-get 'widget-image-value-get
76 :notify 'w3-image-widget-notify 91 :notify 'widget-image-notify
77 ) 92 )
78 93
79 (defun w3-image-widget-convert (widget) 94 (defun widget-image-convert (widget)
80 (let ((args (widget-get widget :args))) 95 (let ((args (widget-get widget :args)))
81 (widget-put widget :args nil) 96 (widget-put widget :args nil)
82 (while args 97 (while args
83 (widget-put widget (car args) (cadr args)) 98 (widget-put widget (car args) (cadr args))
84 (setq args (cddr args))) 99 (setq args (cddr args)))
85 widget)) 100 widget))
86 101
87 (defun w3-image-widget-value-get (widget) 102 (defun widget-image-value-get (widget)
88 (let ((children (widget-get widget :children))) 103 (let ((children (widget-get widget :children)))
89 (and (car children) 104 (and (car children)
90 (widget-apply (car children) :value-get)))) 105 (widget-apply (car children) :value-get))))
91 106
92 (defun w3-image-widget-create (widget) 107 (defun widget-image-create (widget)
93 ;; Create an image widget at point in the current buffer 108 ;; Create an image widget at point in the current buffer
94 (let ((where (widget-get widget 'where))) 109 (let ((where (widget-get widget 'where)))
95 (cond 110 (cond
96 ((null where) 111 ((null where)
97 (setq where (set-marker (make-marker) (point)))) 112 (setq where (set-marker (make-marker) (point))))
98 ((markerp where) 113 ((markerp where)
99 nil) 114 nil)
100 ((integerp where) 115 ((integerp where)
101 (setq where (set-marker (make-marker) where))) 116 (setq where (set-marker (make-marker) where)))
102 (t 117 (t
103 (error "IMPOSSIBLE position in w3-image-widget-create: %s" where))) 118 (error "IMPOSSIBLE position in widget-image-create: %s" where)))
104 (widget-put widget 'where where)) 119 (widget-put widget 'where where))
105 (w3-image-widget-value-create widget)) 120 (widget-image-value-create widget))
106 121
107 (defun w3-image-widget-value-set (widget value) 122 (defun widget-image-value-set (widget value)
108 ;; Recreate widget with new value. 123 ;; Recreate widget with new value.
109 (save-excursion 124 (save-excursion
110 (w3-image-widget-delete widget) 125 (widget-image-delete widget)
111 (if (w3-glyphp value) 126 (if (widget-glyphp value)
112 (widget-put widget 'glyph value) 127 (widget-put widget 'glyph value)
113 (widget-put widget :value value)) 128 (widget-put widget :value value))
114 (widget-apply widget :create))) 129 (widget-apply widget :create)))
115 130
116 (defsubst w3-image-widget-usemap (widget) 131 (defsubst widget-image-usemap (widget)
117 (let ((usemap (widget-get widget 'usemap))) 132 (let ((usemap (widget-get widget 'usemap)))
118 (if (listp usemap) 133 (if (listp usemap)
119 usemap 134 usemap
120 (if (and usemap (string-match "^#" usemap)) 135 (if (and usemap (string-match "^#" usemap))
121 (setq usemap (substring usemap 1 nil))) 136 (setq usemap (substring usemap 1 nil)))
122 (cdr-safe (assoc usemap w3-imagemaps))))) 137 (cdr-safe (assoc usemap w3-imagemaps)))))
123 138
124 (defun w3-image-widget-callback (widget widget-ignore &optional event) 139 (defun widget-image-callback (widget widget-ignore &optional event)
125 (and (widget-get widget 'href) (w3-fetch (widget-get widget 'href)))) 140 (and (widget-get widget 'href) (w3-fetch (widget-get widget 'href))))
126 141
127 (defun w3-image-widget-value-create (widget) 142 (defmacro widget-image-create-subwidget (&rest args)
143 (` (widget-create (,@ args)
144 :parent widget
145 :help-echo 'widget-image-summarize
146 'usemap (widget-get widget 'usemap)
147 'href href
148 'src (widget-get widget 'src)
149 'ismap server-map)))
150
151 (defun widget-image-value-create (widget)
128 ;; Insert the printed representation of the value 152 ;; Insert the printed representation of the value
129 (let ( 153 (let (
130 (href (widget-get widget 'href)) 154 (href (widget-get widget 'href))
131 (server-map (widget-get widget 'ismap)) 155 (server-map (widget-get widget 'ismap))
132 (client-map (w3-image-widget-usemap widget)) 156 (client-map (widget-image-usemap widget))
133 (where (or (widget-get widget 'where) (point))) 157 (where (or (widget-get widget 'where) (point)))
134 (glyph (widget-get widget 'glyph)) 158 (glyph (widget-get widget 'glyph))
135 (alt (widget-get widget 'alt)) 159 (alt (widget-get widget 'alt))
136 (real-widget nil) 160 (real-widget nil)
137 (invalid-glyph nil) 161 (invalid-glyph nil)
164 (list 'choice-item 188 (list 'choice-item
165 :format "%[%t%]" 189 :format "%[%t%]"
166 :tag (or (aref x 3) (aref x 2)) 190 :tag (or (aref x 3) (aref x 2))
167 :value (aref x 2)))) client-map))) 191 :value (aref x 2)))) client-map)))
168 (setq real-widget 192 (setq real-widget
169 (apply 'widget-create 'choice 193 (apply 'widget-create 'menu-choice
170 :tag (or (widget-get widget :tag) "Imagemap") 194 :tag (or (widget-get widget :tag) "Imagemap")
171 :notify (widget-get widget :notify) 195 :notify (widget-get widget :notify)
172 :value default options)))) 196 :action (widget-get widget :action)
197 :value default
198 :parent widget
199 :help-echo 'widget-image-summarize
200 options))))
173 ((and server-map (stringp href)) 201 ((and server-map (stringp href))
174 (setq real-widget 202 (setq real-widget
175 (widget-create 'push :tag alt 203 (widget-image-create-subwidget
176 :delete 'widget-default-delete 204 'push-button :tag alt
177 :value href 205 :delete 'widget-default-delete
178 :notify (widget-get widget :notify)))) 206 :value href
207 :action (widget-get widget :action)
208 :notify (widget-get widget :notify))))
179 (href 209 (href
180 (setq real-widget 210 (setq real-widget
181 (widget-create 'push :tag (or alt "Image") 211 (widget-image-create-subwidget
182 :value href 212 'push-button :tag (or alt "Image")
183 :delete 'widget-default-delete 213 :value href
184 :notify 'w3-image-widget-callback))) 214 :delete 'widget-default-delete
215 :action (widget-get widget :action)
216 :notify 'widget-image-callback)))
185 (alt 217 (alt
186 (setq real-widget 218 (setq real-widget
187 (widget-create 'push :tag alt :format "%[%t%]" 219 (widget-image-create-subwidget
188 :delete 'widget-default-delete 220 'push-button :tag alt :format "%[%t%]"
189 :notify 'w3-image-widget-callback)))) 221 :delete 'widget-default-delete
222 :action (widget-get widget :action)
223 :notify 'widget-image-callback))))
190 (if (not real-widget) 224 (if (not real-widget)
191 nil 225 nil
192 (widget-put real-widget 'usemap (widget-get widget 'usemap))
193 (widget-put real-widget 'href href)
194 (widget-put real-widget 'src (widget-get widget 'src))
195 (widget-put real-widget 'ismap server-map)
196 (widget-put real-widget :parent widget)
197 (widget-put widget :children (list real-widget)))) 226 (widget-put widget :children (list real-widget))))
198 ;;; Actually use the image 227 ;;; Actually use the image
199 (let ((extent (or (widget-get widget 'extent) 228 (let ((extent (or (widget-get widget 'extent)
200 (make-extent where where)))) 229 (make-extent where where))))
201 (set-extent-endpoints extent where where) 230 (set-extent-endpoints extent where where)
202 (widget-put widget 'extent extent) 231 (widget-put widget 'extent extent)
203 (widget-put widget :children nil) 232 (widget-put widget :children nil)
204 (set-extent-property extent 'keymap w3-image-widget-keymap) 233 (set-extent-property extent 'keymap widget-image-keymap)
205 (set-extent-property extent 'begin-glyph glyph) 234 (set-extent-property extent 'begin-glyph glyph)
206 (set-extent-property extent 'help-echo (cond 235 (set-extent-property extent 'help-echo (cond
207 ((and href (or client-map 236 ((and href (or client-map
208 server-map)) 237 server-map))
209 (format "%s [map]" href)) 238 (format "%s [map]" href))
210 (href href) 239 (href href)
211 (t nil))) 240 (t nil)))
212 (set-glyph-property glyph 'widget widget))))) 241 (set-glyph-property glyph 'widget widget)))))
213 242
214 (defun w3-image-widget-delete (widget) 243 (defun widget-image-delete (widget)
215 ;; Remove the widget from the buffer 244 ;; Remove the widget from the buffer
216 (let ((extent (widget-get widget 'extent)) 245 (let ((extent (widget-get widget 'extent))
217 (child (car (widget-get widget :children)))) 246 (child (car (widget-get widget :children))))
218 (cond 247 (cond
219 (extent ; Remove a glyph 248 (extent ; Remove a glyph
222 (widget-apply child :delete)) 251 (widget-apply child :delete))
223 (t ; Doh! Do nothing. 252 (t ; Doh! Do nothing.
224 nil)))) 253 nil))))
225 254
226 (if (fboundp 'mouse-event-p) 255 (if (fboundp 'mouse-event-p)
227 (fset 'w3-mouse-event-p 'mouse-event-p) 256 (fset 'widget-mouse-event-p 'mouse-event-p)
228 (fset 'w3-mouse-event-p 'ignore)) 257 (fset 'widget-mouse-event-p 'ignore))
229 258
230 (if (fboundp 'glyphp) 259 (if (fboundp 'glyphp)
231 (fset 'w3-glyphp 'glyphp) 260 (fset 'widget-glyphp 'glyphp)
232 (fset 'w3-glyphp 'ignore)) 261 (fset 'widget-glyphp 'ignore))
233 262
234 (defun w3-image-widget-button-press (event) 263 (defun widget-image-button-press (event)
235 (interactive "@e") 264 (interactive "@e")
236 (let* ((glyph (and event (w3-mouse-event-p event) (event-glyph event))) 265 (let* ((glyph (and event (widget-mouse-event-p event) (event-glyph event)))
237 (widget (and glyph (glyph-property glyph 'widget)))) 266 (widget (and glyph (glyph-property glyph 'widget))))
238 (w3-image-widget-notify widget widget event))) 267 (widget-image-notify widget widget event)))
239 268
240 (defun w3-image-widget-notify (widget widget-changed &optional event) 269 (defun widget-image-usemap-default (usemap)
270 (let ((rval (and usemap (car usemap))))
271 (while usemap
272 (if (equal (aref (car usemap) 0) "default")
273 (setq rval (car usemap)
274 usemap nil))
275 (setq usemap (cdr usemap)))
276 rval))
277
278 (defun widget-image-summarize (widget)
279 (if (widget-get widget :parent)
280 (setq widget (widget-get widget :parent)))
281 (let* ((ismap (widget-get widget 'ismap))
282 (usemap (widget-image-usemap widget))
283 (href (widget-get widget 'href))
284 (alt (widget-get widget 'alt))
285 (value (widget-value widget))
286 (i nil))
287 (cond
288 (usemap
289 (setq i (length usemap)
290 usemap (widget-image-usemap-default usemap))
291 ;; Perhaps we should do something here with showing the # of entries
292 ;; in the imagemap as well as the default href? Could get too long.
293 (format "Client side imagemap: %s" value))
294 (ismap
295 (format "Server side imagemap: %s" href))
296 ((stringp href) ; Normal hyperlink
297 (format "Image hyperlink: %s" href))
298 ((stringp alt) ; Alternate message was specified
299 (format "Image: %s" alt))
300 ((stringp value)
301 (format "Image: %s" value))
302 (t ; Huh?
303 "A very confused image widget."))))
304
305 (defun widget-image-notify (widget widget-changed &optional event)
241 ;; Happens when anything changes 306 ;; Happens when anything changes
242 (let* ((glyph (and event (w3-mouse-event-p event) (event-glyph event))) 307 (let* ((glyph (and event (widget-mouse-event-p event) (event-glyph event)))
243 (x (and glyph (event-glyph-x-pixel event))) 308 (x (and glyph (event-glyph-x-pixel event)))
244 (y (and glyph (event-glyph-y-pixel event))) 309 (y (and glyph (event-glyph-y-pixel event)))
245 (ismap (widget-get widget 'ismap)) 310 (ismap (widget-get widget 'ismap))
246 (usemap (w3-image-widget-usemap widget)) 311 (usemap (widget-image-usemap widget))
247 (href (widget-get widget 'href)) 312 (href (widget-get widget 'href))
248 (value (widget-value widget)) 313 (value (widget-value widget))
249 ) 314 )
250 (cond 315 (cond
251 ((and glyph usemap) ; Do the client-side imagemap stuff 316 ((and glyph usemap) ; Do the client-side imagemap stuff