Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-widget.el @ 116:9f59509498e1 r20-1b10

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b10
author cvs
date Mon, 13 Aug 2007 09:23:06 +0200
parents fe104dbd9147
children cca96a509cfe
comparison
equal deleted inserted replaced
115:f109f7dabbe2 116:9f59509498e1
1 ;;; w3-widget.el --- An image widget 1 ;;; w3-widget.el --- An image widget
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/03/11 15:40:22 3 ;; Created: 1997/03/26 15:31:17
4 ;; Version: 1.23 4 ;; Version: 1.27
5 ;; Keywords: faces, images 5 ;; Keywords: faces, images
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; 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)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
145 (if (and usemap (string-match "^#" usemap)) 145 (if (and usemap (string-match "^#" usemap))
146 (setq usemap (substring usemap 1 nil))) 146 (setq usemap (substring usemap 1 nil)))
147 (cdr-safe (assoc usemap w3-imagemaps))))) 147 (cdr-safe (assoc usemap w3-imagemaps)))))
148 148
149 (defun widget-image-callback (widget widget-ignore &optional event) 149 (defun widget-image-callback (widget widget-ignore &optional event)
150 (and (widget-get widget 'href) (w3-fetch (widget-get widget 'href) (widget-get widget 'target)))) 150 (if (widget-get widget 'href)
151 (w3-fetch (widget-get widget 'href) (widget-get widget 'target))))
151 152
152 (defmacro widget-image-create-subwidget (&rest args) 153 (defmacro widget-image-create-subwidget (&rest args)
153 (` (widget-create (,@ args) 154 (` (widget-create (,@ args)
154 :parent widget 155 :parent widget
155 :help-echo 'widget-image-summarize 156 :help-echo 'widget-image-summarize
156 'usemap (widget-get widget 'usemap) 157 'usemap (widget-get widget 'usemap)
157 'href href 158 'href href
158 'src (widget-get widget 'src) 159 'src (widget-get widget 'src)
159 'ismap server-map))) 160 'ismap server-map)))
160
161 (defun widget-image-emacspeak-tty-imagemap (usemap)
162 (let* ((default nil)
163 (href nil)
164 (tag nil)
165 (options (delete
166 nil
167 (mapcar
168 (function
169 (lambda (x)
170 (if (eq (aref x 0) 'default)
171 (setq default (aref x 2)))
172 (if (and (not default) (stringp (aref x 2)))
173 (setq default (aref x 2)))
174 (setq tag (or (aref x 3) (aref x 2))
175 href (aref x 2))
176 (and (stringp tag)
177 (stringp href)
178 (list 'a
179 (list
180 (cons 'href href)
181 (cons
182 'class
183 (list
184 (if (url-have-visited-url href)
185 ":visited" ":link"))))
186 (list tag)))))
187 usemap))))
188 (w3-display-node (list 'table '((border . "1"))
189 (w3-display-chop-into-table
190 (list nil nil options) 3)))))
191 161
192 (defun widget-image-value-create (widget) 162 (defun widget-image-value-create (widget)
193 ;; Insert the printed representation of the value 163 ;; Insert the printed representation of the value
194 (let ( 164 (let (
195 (href (widget-get widget 'href)) 165 (href (widget-get widget 'href))
216 (save-excursion 186 (save-excursion
217 (if (= 0 (length alt)) (setq alt nil)) 187 (if (= 0 (length alt)) (setq alt nil))
218 (goto-char where) 188 (goto-char where)
219 (cond 189 (cond
220 (client-map 190 (client-map
221 (if (featurep 'emacspeak) 191 (let* ((default nil)
222 (widget-image-emacspeak-tty-imagemap client-map) 192 (options (mapcar
223 (let* ((default nil) 193 (function
224 (href nil) 194 (lambda (x)
225 (tag nil) 195 (if (eq (aref x 0) 'default)
226 (options (mapcar 196 (setq default (aref x 2)))
227 (function 197 (if (and (not default) (stringp (aref x 2)))
228 (lambda (x) 198 (setq default (aref x 2)))
229 (if (eq (aref x 0) 'default) 199 (list 'choice-item
230 (setq default (aref x 2))) 200 :format "%[%t%]"
231 (if (and (not default) (stringp (aref x 2))) 201 :tag (or (aref x 3) (aref x 2))
232 (setq default (aref x 2))) 202 :value (aref x 2)))) client-map)))
233 (list 'choice-item 203 (setq real-widget
234 :format "%[%t%]" 204 (apply 'widget-create 'menu-choice
235 :tag (or (aref x 3) (aref x 2)) 205 :tag (or (widget-get widget :tag) "Imagemap")
236 :value (aref x 2)))) client-map))) 206 :ignore-case t
237 (setq real-widget 207 :notify (widget-get widget :notify)
238 (apply 'widget-create 'menu-choice 208 :action (widget-get widget :action)
239 :tag (or (widget-get widget :tag) "Imagemap") 209 :value default
240 :notify (widget-get widget :notify) 210 :parent widget
241 :action (widget-get widget :action) 211 :help-echo 'widget-image-summarize
242 :value default 212 options))))
243 :parent widget
244 :help-echo 'widget-image-summarize
245 options)))))
246 ((and server-map (stringp href)) 213 ((and server-map (stringp href))
247 (setq real-widget 214 (setq real-widget
248 (widget-image-create-subwidget 215 (widget-image-create-subwidget
249 'push-button 216 'item :format "%[%t%]"
250 :tag alt 217 :tag alt
251 :delete 'widget-default-delete 218 :delete 'widget-default-delete
252 :value href 219 :value href
253 :action (widget-get widget :action) 220 :action (widget-get widget :action)
254 :notify (widget-get widget :notify)))) 221 :notify (widget-get widget :notify))))
255 (href 222 (href
256 (setq real-widget 223 (setq real-widget
257 (widget-image-create-subwidget 224 (widget-image-create-subwidget
258 'push-button :tag (or alt "Image") 225 'item :format "%[%t%]"
226 :tag (or alt "Image")
259 :value href 227 :value href
260 :delete 'widget-default-delete 228 :delete 'widget-default-delete
261 :action (widget-get widget :action) 229 :action (widget-get widget :action)
262 :notify 'widget-image-callback))) 230 :notify 'widget-image-callback)))
263 (alt 231 (alt
264 (setq real-widget 232 (setq real-widget
265 (widget-image-create-subwidget 233 (widget-image-create-subwidget
266 'push-button :tag alt :format "%[%t%]" 234 'item :format "%[%t%]"
235 :tag alt
267 :tab-order -1 236 :tab-order -1
268 :delete 'widget-default-delete 237 :delete 'widget-default-delete
269 :action (widget-get widget :action) 238 :action (widget-get widget :action)
270 :notify 'widget-image-callback)))) 239 :notify 'widget-image-callback))))
271 (if (not real-widget) 240 (if (not real-widget)
277 (set-extent-endpoints extent where where) 246 (set-extent-endpoints extent where where)
278 (widget-put widget 'extent extent) 247 (widget-put widget 'extent extent)
279 (widget-put widget :children nil) 248 (widget-put widget :children nil)
280 (set-extent-property extent 'keymap widget-image-keymap) 249 (set-extent-property extent 'keymap widget-image-keymap)
281 (set-extent-property extent 'begin-glyph glyph) 250 (set-extent-property extent 'begin-glyph glyph)
251 (set-extent-property extent 'detachable t)
282 (set-extent-property extent 'help-echo (cond 252 (set-extent-property extent 'help-echo (cond
283 ((and href (or client-map 253 ((and href (or client-map
284 server-map)) 254 server-map))
285 (format "%s [map]" href)) 255 (format "%s [map]" href))
286 (href href) 256 (href href)
327 (setq widget (widget-get widget :parent))) 297 (setq widget (widget-get widget :parent)))
328 (let* ((ismap (widget-get widget 'ismap)) 298 (let* ((ismap (widget-get widget 'ismap))
329 (usemap (widget-image-usemap widget)) 299 (usemap (widget-image-usemap widget))
330 (href (widget-get widget 'href)) 300 (href (widget-get widget 'href))
331 (alt (widget-get widget 'alt)) 301 (alt (widget-get widget 'alt))
332 (value (widget-value widget)) 302 (value (widget-value widget)))
333 (i nil))
334 (cond 303 (cond
335 (usemap 304 (usemap
336 (setq i (length usemap) 305 (setq usemap (widget-image-usemap-default usemap))
337 usemap (widget-image-usemap-default usemap))
338 ;; Perhaps we should do something here with showing the # of entries 306 ;; Perhaps we should do something here with showing the # of entries
339 ;; in the imagemap as well as the default href? Could get too long. 307 ;; in the imagemap as well as the default href? Could get too long.
340 (format "Client side imagemap: %s" value)) 308 (format "Client side imagemap: %s" value))
341 (ismap 309 (ismap
342 (format "Server side imagemap: %s" href)) 310 (format "Server side imagemap: %s" href))
364 (ismap (widget-get widget 'ismap)) 332 (ismap (widget-get widget 'ismap))
365 (usemap (widget-image-usemap widget)) 333 (usemap (widget-image-usemap widget))
366 (href (widget-get widget 'href)) 334 (href (widget-get widget 'href))
367 (img-src (or (widget-get widget 'src) 335 (img-src (or (widget-get widget 'src)
368 (and widget-changed (widget-get widget-changed 'src)))) 336 (and widget-changed (widget-get widget-changed 'src))))
369 (value (widget-value widget))
370 (target (widget-get widget 'target)) 337 (target (widget-get widget 'target))
371 ) 338 )
372 (cond 339 (cond
373 ((and glyph usemap) ; Do the client-side imagemap stuff 340 ((and glyph usemap) ; Do the client-side imagemap stuff
374 (setq href (w3-point-in-map (vector x y) usemap nil)) 341 (setq href (w3-point-in-map (vector x y) usemap nil))
381 (let ((choices (mapcar (function 348 (let ((choices (mapcar (function
382 (lambda (entry) 349 (lambda (entry)
383 (cons 350 (cons
384 (or (aref entry 3) (aref entry 2)) 351 (or (aref entry 3) (aref entry 2))
385 (aref entry 2)))) usemap)) 352 (aref entry 2)))) usemap))
386 (choice nil)) 353 (choice nil)
354 (case-fold-search t))
387 (setq choice (completing-read "Imagemap: " choices nil t) 355 (setq choice (completing-read "Imagemap: " choices nil t)
388 choice (cdr-safe (assoc choice choices))) 356 choice (cdr-safe (assoc choice choices)))
389 (and (stringp choice) (w3-fetch choice target)))) 357 (and (stringp choice) (w3-fetch choice target))))
390 (ismap ; Do server-side dummy imagemap for tty 358 (ismap ; Do server-side dummy imagemap for tty
391 (w3-fetch (concat href "?0,0") target)) 359 (w3-fetch (concat href "?0,0") target))