Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-widget.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 1ce6082ce73f
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1 ;;; w3-widget.el --- An image widget 2 ;;; w3-widget.el --- An image widget
2 ;; Author: wmperry 3 ;; Author: wmperry
3 ;; Created: 1997/03/26 15:31:17 4 ;; Created: 1996/07/21 18:11:36
4 ;; Version: 1.27 5 ;; Version: 1.3
5 ;; Keywords: faces, images 6 ;; Keywords: faces, help, comm, news, mail, processes, mouse, hypermedia
6 7
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu) 9 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 10 ;;;
10 ;;; 11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
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 the 24 ;;; along with GNU Emacs; see the file COPYING. If not, write to
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 25 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
26 ;;; Boston, MA 02111-1307, USA.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 27
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;; This is a widget that will do the best it can with an image. 29 ;;; This is a widget that will do the best it can with an image.
31 ;;; 30 ;;;
50 ;;; These are either URLs (http://foo/...) or alternative text. 49 ;;; These are either URLs (http://foo/...) or alternative text.
51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 51
53 (require 'cl) 52 (require 'cl)
54 (require 'widget) 53 (require 'widget)
55 54 (require 'w3-vars)
56 (defvar widget-image-keymap (make-sparse-keymap) 55 (require 'w3-mouse)
56
57 (defvar w3-image-widget-keymap (make-sparse-keymap)
57 "Keymap used over glyphs in an image widget") 58 "Keymap used over glyphs in an image widget")
58 59
59 (define-widget-keywords :tab-order) 60 (define-key w3-image-widget-keymap (vector w3-mouse-button1)
60 61 'w3-image-widget-button-press)
61 (defconst widget-mouse-button1 nil) 62 (define-key w3-image-widget-keymap (vector w3-mouse-button2)
62 (defconst widget-mouse-button2 nil) 63 'w3-image-widget-button-press)
63 (defconst widget-mouse-button3 nil)
64
65 (if (string-match "XEmacs" (emacs-version))
66 (if (featurep 'mouse)
67 (setq widget-mouse-button1 'button1
68 widget-mouse-button2 'button2
69 widget-mouse-button3 'button3)
70 (setq widget-mouse-button1 'return
71 widget-mouse-button2 'return
72 widget-mouse-button3 'return))
73 (setq widget-mouse-button1 'mouse-1
74 widget-mouse-button2 'mouse-2
75 widget-mouse-button3 'mouse-3))
76
77 (defvar widget-image-inaudible-p nil
78 "*Whether to make images inaudible or not.")
79
80 (define-key widget-image-keymap (vector widget-mouse-button1)
81 'widget-image-button-press)
82 (define-key widget-image-keymap (vector widget-mouse-button2)
83 'widget-image-button-press)
84 64
85 (define-widget 'image 'default 65 (define-widget 'image 'default
86 "A fairly complex image widget." 66 "A fairly complex image widget."
87 :convert-widget 'widget-image-convert 67 :convert-widget 'w3-image-widget-convert
88 :value-to-internal (lambda (widget value) value) 68 :value-to-internal (lambda (widget value) value)
89 :value-to-external (lambda (widget value) value) 69 :value-to-external (lambda (widget value) value)
90 :value-set 'widget-image-value-set 70 :value-set 'w3-image-widget-value-set
91 :create 'widget-image-create 71 :create 'w3-image-widget-create
92 :delete 'widget-image-delete 72 :delete 'w3-image-widget-delete
93 :value-create 'widget-image-value-create 73 :value-create 'w3-image-widget-value-create
94 :value-delete 'widget-image-value-delete 74 :value-delete 'w3-image-widget-value-delete
95 :value-get 'widget-image-value-get 75 :value-get 'w3-image-widget-value-get
96 :notify 'widget-image-notify 76 :notify 'w3-image-widget-notify
97 ) 77 )
98 78
99 (defun widget-image-convert (widget) 79 (defun w3-image-widget-convert (widget)
100 (let ((args (widget-get widget :args))) 80 (let ((args (widget-get widget :args)))
101 (widget-put widget :args nil) 81 (widget-put widget :args nil)
102 (while args 82 (while args
103 (widget-put widget (car args) (cadr args)) 83 (widget-put widget (car args) (cadr args))
104 (setq args (cddr args))) 84 (setq args (cddr args)))
105 widget)) 85 widget))
106 86
107 (defun widget-image-value-get (widget) 87 (defun w3-image-widget-value-get (widget)
108 (let ((children (widget-get widget :children))) 88 (let ((children (widget-get widget :children)))
109 (and (car children) 89 (and (car children)
110 (widget-apply (car children) :value-get)))) 90 (widget-apply (car children) :value-get))))
111 91
112 (defun widget-image-create (widget) 92 (defun w3-image-widget-create (widget)
113 ;; Create an image widget at point in the current buffer 93 ;; Create an image widget at point in the current buffer
114 (let ((where (widget-get widget 'where))) 94 (let ((where (widget-get widget 'where)))
115 (cond 95 (cond
116 ((null where) 96 ((null where)
117 (setq where (set-marker (make-marker) (point)))) 97 (setq where (set-marker (make-marker) (point))))
118 ((markerp where) 98 ((markerp where)
119 nil) 99 nil)
120 ((integerp where) 100 ((integerp where)
121 (setq where (set-marker (make-marker) where))) 101 (setq where (set-marker (make-marker) where)))
122 (t 102 (t
123 (error "IMPOSSIBLE position in widget-image-create: %s" where))) 103 (error "IMPOSSIBLE position in w3-image-widget-create: %s" where)))
124 (widget-put widget 'where where)) 104 (widget-put widget 'where where))
125 (widget-image-value-create widget)) 105 (w3-image-widget-value-create widget))
126 106
127 (defun widget-image-value-set (widget value) 107 (defun w3-image-widget-value-set (widget value)
128 ;; Recreate widget with new value. 108 ;; Recreate widget with new value.
129 (save-excursion 109 (save-excursion
130 (widget-image-delete widget) 110 (w3-image-widget-delete widget)
131 (if (widget-glyphp value) 111 (if (w3-glyphp value)
132 (widget-put widget 'glyph value) 112 (widget-put widget 'glyph value)
133 (widget-put widget :value value)) 113 (widget-put widget :value value))
134 (put-text-property (point) 114 (widget-apply widget :create)))
135 (progn 115
136 (widget-apply widget :create) 116 (defsubst w3-image-widget-usemap (widget)
137 (point))
138 'inaudible
139 widget-image-inaudible-p)))
140
141 (defsubst widget-image-usemap (widget)
142 (let ((usemap (widget-get widget 'usemap))) 117 (let ((usemap (widget-get widget 'usemap)))
143 (if (listp usemap) 118 (if (listp usemap)
144 usemap 119 usemap
145 (if (and usemap (string-match "^#" usemap)) 120 (if (and usemap (string-match "^#" usemap))
146 (setq usemap (substring usemap 1 nil))) 121 (setq usemap (substring usemap 1 nil)))
147 (cdr-safe (assoc usemap w3-imagemaps))))) 122 (cdr-safe (assoc usemap w3-imagemaps)))))
148 123
149 (defun widget-image-callback (widget widget-ignore &optional event) 124 (defun w3-image-widget-callback (widget widget-ignore &optional event)
150 (if (widget-get widget 'href) 125 (and (widget-get widget 'href) (w3-fetch (widget-get widget 'href))))
151 (w3-fetch (widget-get widget 'href) (widget-get widget 'target)))) 126
152 127 (defun w3-image-widget-value-create (widget)
153 (defmacro widget-image-create-subwidget (&rest args)
154 (` (widget-create (,@ args)
155 :parent widget
156 :help-echo 'widget-image-summarize
157 'usemap (widget-get widget 'usemap)
158 'href href
159 'src (widget-get widget 'src)
160 'ismap server-map)))
161
162 (defun widget-image-value-create (widget)
163 ;; Insert the printed representation of the value 128 ;; Insert the printed representation of the value
164 (let ( 129 (let (
165 (href (widget-get widget 'href)) 130 (href (widget-get widget 'href))
166 (server-map (widget-get widget 'ismap)) 131 (server-map (widget-get widget 'ismap))
167 (client-map (widget-image-usemap widget)) 132 (client-map (w3-image-widget-usemap widget))
168 (where (or (widget-get widget 'where) (point))) 133 (where (or (widget-get widget 'where) (point)))
169 (glyph (widget-get widget 'glyph)) 134 (glyph (widget-get widget 'glyph))
170 (alt (widget-get widget 'alt)) 135 (alt (widget-get widget 'alt))
171 (real-widget nil) 136 (real-widget nil)
172 (invalid-glyph nil) 137 (invalid-glyph nil)
199 (list 'choice-item 164 (list 'choice-item
200 :format "%[%t%]" 165 :format "%[%t%]"
201 :tag (or (aref x 3) (aref x 2)) 166 :tag (or (aref x 3) (aref x 2))
202 :value (aref x 2)))) client-map))) 167 :value (aref x 2)))) client-map)))
203 (setq real-widget 168 (setq real-widget
204 (apply 'widget-create 'menu-choice 169 (apply 'widget-create 'choice
205 :tag (or (widget-get widget :tag) "Imagemap") 170 :tag (or (widget-get widget :tag) "Imagemap")
206 :ignore-case t
207 :notify (widget-get widget :notify) 171 :notify (widget-get widget :notify)
208 :action (widget-get widget :action) 172 :value default options))))
209 :value default
210 :parent widget
211 :help-echo 'widget-image-summarize
212 options))))
213 ((and server-map (stringp href)) 173 ((and server-map (stringp href))
214 (setq real-widget 174 (setq real-widget
215 (widget-image-create-subwidget 175 (widget-create 'push :tag alt
216 'item :format "%[%t%]" 176 :delete 'widget-default-delete
217 :tag alt 177 :value href
218 :delete 'widget-default-delete 178 :notify (widget-get widget :notify))))
219 :value href
220 :action (widget-get widget :action)
221 :notify (widget-get widget :notify))))
222 (href 179 (href
223 (setq real-widget 180 (setq real-widget
224 (widget-image-create-subwidget 181 (widget-create 'push :tag (or alt "Image")
225 'item :format "%[%t%]" 182 :value href
226 :tag (or alt "Image") 183 :delete 'widget-default-delete
227 :value href 184 :notify 'w3-image-widget-callback)))
228 :delete 'widget-default-delete
229 :action (widget-get widget :action)
230 :notify 'widget-image-callback)))
231 (alt 185 (alt
232 (setq real-widget 186 (setq real-widget
233 (widget-image-create-subwidget 187 (widget-create 'push :tag alt :format "%[%t%]"
234 'item :format "%[%t%]" 188 :delete 'widget-default-delete
235 :tag alt 189 :notify 'w3-image-widget-callback))))
236 :tab-order -1
237 :delete 'widget-default-delete
238 :action (widget-get widget :action)
239 :notify 'widget-image-callback))))
240 (if (not real-widget) 190 (if (not real-widget)
241 nil 191 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)
242 (widget-put widget :children (list real-widget)))) 197 (widget-put widget :children (list real-widget))))
243 ;;; Actually use the image 198 ;;; Actually use the image
244 (let ((extent (or (widget-get widget 'extent) 199 (let ((extent (or (widget-get widget 'extent)
245 (make-extent where where)))) 200 (make-extent where where))))
246 (set-extent-endpoints extent where where) 201 (set-extent-endpoints extent where where)
247 (widget-put widget 'extent extent) 202 (widget-put widget 'extent extent)
248 (widget-put widget :children nil) 203 (widget-put widget :children nil)
249 (set-extent-property extent 'keymap widget-image-keymap) 204 (set-extent-property extent 'keymap w3-image-widget-keymap)
250 (set-extent-property extent 'begin-glyph glyph) 205 (set-extent-property extent 'begin-glyph glyph)
251 (set-extent-property extent 'detachable t)
252 (set-extent-property extent 'help-echo (cond 206 (set-extent-property extent 'help-echo (cond
253 ((and href (or client-map 207 ((and href (or client-map
254 server-map)) 208 server-map))
255 (format "%s [map]" href)) 209 (format "%s [map]" href))
256 (href href) 210 (href href)
257 (t nil))) 211 (t nil)))
258 (set-glyph-property glyph 'widget widget))))) 212 (set-glyph-property glyph 'widget widget)))))
259 213
260 (defun widget-image-delete (widget) 214 (defun w3-image-widget-delete (widget)
261 ;; Remove the widget from the buffer 215 ;; Remove the widget from the buffer
262 (let ((extent (widget-get widget 'extent)) 216 (let ((extent (widget-get widget 'extent))
263 (child (car (widget-get widget :children)))) 217 (child (car (widget-get widget :children))))
264 (cond 218 (cond
265 (extent ; Remove a glyph 219 (extent ; Remove a glyph
268 (widget-apply child :delete)) 222 (widget-apply child :delete))
269 (t ; Doh! Do nothing. 223 (t ; Doh! Do nothing.
270 nil)))) 224 nil))))
271 225
272 (if (fboundp 'mouse-event-p) 226 (if (fboundp 'mouse-event-p)
273 (fset 'widget-mouse-event-p 'mouse-event-p) 227 (fset 'w3-mouse-event-p 'mouse-event-p)
274 (fset 'widget-mouse-event-p 'ignore)) 228 (fset 'w3-mouse-event-p 'ignore))
275 229
276 (if (fboundp 'glyphp) 230 (if (fboundp 'glyphp)
277 (fset 'widget-glyphp 'glyphp) 231 (fset 'w3-glyphp 'glyphp)
278 (fset 'widget-glyphp 'ignore)) 232 (fset 'w3-glyphp 'ignore))
279 233
280 (defun widget-image-button-press (event) 234 (defun w3-image-widget-button-press (event)
281 (interactive "@e") 235 (interactive "@e")
282 (let* ((glyph (and event (widget-mouse-event-p event) (event-glyph event))) 236 (let* ((glyph (and event (w3-mouse-event-p event) (event-glyph event)))
283 (widget (and glyph (glyph-property glyph 'widget)))) 237 (widget (and glyph (glyph-property glyph 'widget))))
284 (widget-image-notify widget widget event))) 238 (w3-image-widget-notify widget widget event)))
285 239
286 (defun widget-image-usemap-default (usemap) 240 (defun w3-image-widget-notify (widget widget-changed &optional event)
287 (let ((rval (and usemap (car usemap))))
288 (while usemap
289 (if (equal (aref (car usemap) 0) "default")
290 (setq rval (car usemap)
291 usemap nil))
292 (setq usemap (cdr usemap)))
293 rval))
294
295 (defun widget-image-summarize (widget)
296 (if (widget-get widget :parent)
297 (setq widget (widget-get widget :parent)))
298 (let* ((ismap (widget-get widget 'ismap))
299 (usemap (widget-image-usemap widget))
300 (href (widget-get widget 'href))
301 (alt (widget-get widget 'alt))
302 (value (widget-value widget)))
303 (cond
304 (usemap
305 (setq usemap (widget-image-usemap-default usemap))
306 ;; Perhaps we should do something here with showing the # of entries
307 ;; in the imagemap as well as the default href? Could get too long.
308 (format "Client side imagemap: %s" value))
309 (ismap
310 (format "Server side imagemap: %s" href))
311 ((stringp href) ; Normal hyperlink
312 (format "Image hyperlink: %s" href))
313 ((stringp alt) ; Alternate message was specified
314 (format "Image: %s" alt))
315 ((stringp value)
316 (format "Image: %s" value))
317 (t ; Huh?
318 "A very confused image widget."))))
319
320 (defvar widget-image-auto-retrieve 'ask
321 "*Whether to automatically retrieve the source of an image widget
322 if it is not an active hyperlink or imagemap.
323 If `nil', don't do anything.
324 If `t', automatically retrieve the source.
325 Any other value means ask the user each time.")
326
327 (defun widget-image-notify (widget widget-changed &optional event)
328 ;; Happens when anything changes 241 ;; Happens when anything changes
329 (let* ((glyph (and event (widget-mouse-event-p event) (event-glyph event))) 242 (let* ((glyph (and event (w3-mouse-event-p event) (event-glyph event)))
330 (x (and glyph (event-glyph-x-pixel event))) 243 (x (and glyph (event-glyph-x-pixel event)))
331 (y (and glyph (event-glyph-y-pixel event))) 244 (y (and glyph (event-glyph-y-pixel event)))
332 (ismap (widget-get widget 'ismap)) 245 (ismap (widget-get widget 'ismap))
333 (usemap (widget-image-usemap widget)) 246 (usemap (w3-image-widget-usemap widget))
334 (href (widget-get widget 'href)) 247 (href (widget-get widget 'href))
335 (img-src (or (widget-get widget 'src) 248 (value (widget-value widget))
336 (and widget-changed (widget-get widget-changed 'src))))
337 (target (widget-get widget 'target))
338 ) 249 )
339 (cond 250 (cond
340 ((and glyph usemap) ; Do the client-side imagemap stuff 251 ((and glyph usemap) ; Do the client-side imagemap stuff
341 (setq href (w3-point-in-map (vector x y) usemap nil)) 252 (setq href (w3-point-in-map (vector x y) usemap nil))
342 (if (stringp href) 253 (if href
343 (w3-fetch href target) 254 (w3-fetch href)
344 (message "No destination found for %d,%d" x y))) 255 (message "No destination found for %d,%d" x y)))
345 ((and glyph x y ismap) ; Do the server-side imagemap stuff 256 ((and glyph x y ismap) ; Do the server-side imagemap stuff
346 (w3-fetch (format "%s?%d,%d" href x y) target)) 257 (w3-fetch (format "%s?%d,%d" href x y)))
347 (usemap ; Dummed-down tty client side imap 258 (usemap ; Dummed-down tty client side imap
348 (let ((choices (mapcar (function 259 (w3-fetch value))
349 (lambda (entry)
350 (cons
351 (or (aref entry 3) (aref entry 2))
352 (aref entry 2)))) usemap))
353 (choice nil)
354 (case-fold-search t))
355 (setq choice (completing-read "Imagemap: " choices nil t)
356 choice (cdr-safe (assoc choice choices)))
357 (and (stringp choice) (w3-fetch choice target))))
358 (ismap ; Do server-side dummy imagemap for tty 260 (ismap ; Do server-side dummy imagemap for tty
359 (w3-fetch (concat href "?0,0") target)) 261 (w3-fetch (concat href "?0,0")))
360 ((stringp href) ; Normal hyperlink 262 ((stringp href) ; Normal hyperlink
361 (w3-fetch href target)) 263 (w3-fetch href))
362 ((stringp img-src)
363 (cond
364 ((null widget-image-auto-retrieve) nil)
365 ((eq t widget-image-auto-retrieve)
366 (w3-fetch img-src))
367 ((funcall url-confirmation-func
368 (format "Retrieve image (%s)?"
369 (url-truncate-url-for-viewing img-src)))
370 (w3-fetch img-src))))
371 (t ; Huh? 264 (t ; Huh?
372 nil)))) 265 nil))))
373 266
374 (provide 'w3-widget) 267 (provide 'w3-widget)