Source

w3 / lisp / w3-widget.el

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
;;; w3-widget.el --- An image widget
;; Author: wmperry
;; Created: 1999/11/09 14:52:35
;; Version: 1.2
;; Keywords: faces, images

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
;;;
;;; This file is part of GNU Emacs.
;;;
;;; GNU Emacs is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
;;;
;;; GNU Emacs is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Emacs; see the file COPYING.  If not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307, USA.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is a widget that will do the best it can with an image.
;;;
;;; It can handle all the common occurences of images on the world wide web
;;; 1. A plain image - displays either a glyph of the image, or the
;;;    alternative text
;;; 2. A hyperlinked image - an image that is also a hypertext link to
;;;    another page.  Displays either a glyph of the image, or the
;;;    alternative text.  When activated with the mouse or the keyboard,
;;;    the 'href' property of the widget is retrieved.
;;; 3. Server side imagemaps - an image that has hotzones that lead to
;;;    different areas.  Unfortunately, we cannot tell where the links go
;;;    from the client - all processing is done by the server.  Displays
;;;    either a glyph of the image, or the alternative text.  When activated
;;;    with the mouse or the keyboard, the coordinates clicked on are
;;;    sent to the remote server as HREF?x,y.  If the link is activated
;;;    by the keyboard, then 0,0 are sent as the coordinates.
;;; 4. Client side imagemaps - an image that has hotzones that lead to
;;;    different areas.  All processing is done on the client side, so
;;;    we can actually show a decent representation on a TTY.  Displays
;;;    either a glyph of the image, or a drop-down-list of the destinations
;;;    These are either URLs (http://foo/...) or alternative text.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'cl)
(require 'widget)
(require 'w3-keyword)

(defvar widget-image-keymap (make-sparse-keymap)
  "Keymap used over glyphs in an image widget")

(defconst widget-mouse-button1 nil)
(defconst widget-mouse-button2 nil)
(defconst widget-mouse-button3 nil)

(if (string-match "XEmacs" (emacs-version))
    (if (featurep 'mouse)
	(setq widget-mouse-button1 'button1
	      widget-mouse-button2 'button2
	      widget-mouse-button3 'button3)
      (setq widget-mouse-button1 'return
	    widget-mouse-button2 'return
	    widget-mouse-button3 'return))
  (setq widget-mouse-button1 'mouse-1
	widget-mouse-button2 'mouse-2
	widget-mouse-button3 'mouse-3))

(defvar widget-image-inaudible-p nil
  "*Whether to make images inaudible or not.")

(define-key widget-image-keymap (vector widget-mouse-button1)
  'widget-image-button-press)
(define-key widget-image-keymap (vector widget-mouse-button2)
  'widget-image-button-press)
  
(define-widget 'image 'default
  "A fairly complex image widget."
  :convert-widget 'widget-image-convert
  :value-to-internal (lambda (widget value) value)
  :value-to-external (lambda (widget value) value)
  :value-set 'widget-image-value-set
  :create 'widget-image-create
  :delete 'widget-image-delete
  :value-create 'widget-image-value-create
  :value-delete 'widget-image-value-delete
  :value-get 'widget-image-value-get
  :notify 'widget-image-notify
  )

(defun widget-image-convert (widget)
  (let ((args (widget-get widget :args)))
    (widget-put widget :args nil)
    (while args
      (widget-put widget (car args) (cadr args))
      (setq args (cddr args)))
    widget))

(defun widget-image-value-get (widget)
  (let ((children (widget-get widget :children)))
    (and (car children)
	 (widget-apply (car children) :value-get))))

(defun widget-image-create (widget)
  ;; Create an image widget at point in the current buffer
  (let ((where (widget-get widget 'where)))
    (cond
     ((null where)
      (setq where (set-marker (make-marker) (point))))
     ((markerp where)
      nil)
     ((integerp where)
      (setq where (set-marker (make-marker) where)))
     (t
      (error "IMPOSSIBLE position in widget-image-create: %s" where)))
    (widget-put widget 'where where))
  (widget-image-value-create widget))

(defun widget-image-value-set (widget value)
  ;; Recreate widget with new value.
  (save-excursion
    (widget-image-delete widget)
    (if (widget-glyphp value)
	(widget-put widget 'glyph value)
      (widget-put widget :value value))
    (put-text-property (point)
		       (progn
			 (widget-apply widget :create)
			 (point))
		       'inaudible
		       widget-image-inaudible-p)))

(defsubst widget-image-usemap (widget)
  (let ((usemap (widget-get widget 'usemap)))
    (if (listp usemap)
	usemap
      (if (and usemap (string-match "^#" usemap))
	  (setq usemap (substring usemap 1 nil)))
      (cdr-safe (assoc usemap w3-imagemaps)))))

(defun widget-image-callback (widget widget-ignore &optional event)
  (if (widget-get widget :href)
      (w3-fetch (widget-get widget :href) (widget-get widget :target))))

(defmacro widget-image-create-subwidget (&rest args)
  (` (widget-create (,@ args)
		    :parent widget
		    :help-echo 'widget-image-summarize
		    'usemap (widget-get widget 'usemap)
		    :href href
		    :target target
		    :src (widget-get widget :src)
		    'ismap server-map)))

(defun widget-image-value-create (widget)
  ;; Insert the printed representation of the value
  (let (
	(href (widget-get widget :href))
	(target (widget-get widget :target))
	(face (widget-get widget :button-face))
	(server-map (widget-get widget 'ismap))
	(client-map (widget-image-usemap widget))
	(where (or (widget-get widget 'where) (point)))
	(glyph (widget-get widget 'glyph))
	(alt (widget-get widget 'alt))
	(real-widget nil)
	(invalid-glyph nil)
	)
    (if target (setq target (intern (downcase target))))

    ;; Specifier-instance will signal an error if we have an invalid
    ;; image specifier, which would be the case if we get screwed up
    ;; data back from a URL somewhere.

    (cond
     (w3-running-xemacs
      ;; All XEmacsen have support for glyphs
      (setq invalid-glyph (and glyph (condition-case ()
					 (if (fboundp 'specifier-instance)
					     (if (specifier-instance
						  (glyph-image glyph))
						 nil)
					   nil)
				       (error t)))))
     ((boundp 'image-types)
      ;; We are in Emacs 20.5+, which has image support
      (require 'image)
      (setq invalid-glyph (and glyph
			       (not (memq (plist-get glyph :type) image-types)))))
     (t
      nil))

    (if (or (not glyph) invalid-glyph)
	;; Do a TTY or delayed image version of the image.
	(save-excursion
	  (if (= 0 (length alt)) (setq alt nil))
	  (goto-char where)
	  (cond
	   (client-map
	    (let* ((default nil)
		   (options (mapcar
			     (function
			      (lambda (x)
				(if (eq (aref x 0) 'default)
				    (setq default (aref x 2)))
				(if (and (not default) (stringp (aref x 2)))
				    (setq default (aref x 2)))
				(list 'choice-item
				      :tab-order -1
				      :delete 'widget-default-delete
				      :format "%[%t%]"
				      :tag (or (aref x 3) (aref x 2))
				      :value (aref x 2)))) client-map)))
	      (setq real-widget
		    (apply 'widget-create 'menu-choice
			   :tag (or (widget-get widget :tag) alt "Imagemap")
			   :button-face face
			   :format "%[%t:%v%]"
			   :ignore-case t
			   :notify (widget-get widget :notify)
			   :delete 'widget-default-delete
			   :action (widget-get widget :action)
			   :value default
			   :parent widget
			   :help-echo 'widget-image-summarize
			   options))))
	   ((and server-map (stringp href))
	    (setq real-widget
		  (widget-image-create-subwidget
		   'item :format "%[%t%]"
		   :tag alt
		   :button-face face
		   :delete 'widget-default-delete
		   :value href
		   :action (widget-get widget :action)
		   :notify (widget-get widget :notify))))
	   (href
	    (setq real-widget
		  (widget-image-create-subwidget
		   'item :format "%[%t%]"
		   :tag (or alt "Image")
		   :button-face face
		   :value href
		   :delete 'widget-default-delete
		   :action (widget-get widget :action)
		   :notify 'widget-image-callback)))
	   (alt
	    (setq real-widget
		  (widget-image-create-subwidget
		   'item :format "%[%t%]"
		   :tag alt
		   :button-face face
		   :tab-order -1
		   :delete 'widget-default-delete
		   :action (widget-get widget :action)
		   :notify 'widget-image-callback))))
	  (if (not real-widget)
	      nil
	    (widget-put widget :children (list real-widget))))
      ;;; Actually use the image
      (let ((extent (or (widget-get widget 'extent)
			(make-extent where where))))
	(set-extent-endpoints extent where where)
	(widget-put widget 'extent extent)
	(widget-put widget :children nil)
	(set-extent-property extent 'keymap widget-image-keymap)
	(set-extent-property extent 'begin-glyph glyph)
	(set-extent-property extent 'detachable t)
	(set-extent-property extent 'help-echo (cond
						((and href (or client-map
							       server-map))
						 (format "%s [map]" href))
						(href href)
						(t nil)))
	(set-glyph-property glyph 'widget widget)))))

(defun widget-image-delete (widget)
  ;; Remove the widget from the buffer
  (let ((extent (widget-get widget 'extent))
	(child  (car (widget-get widget :children))))
    (cond
     (extent				; Remove a glyph
      (delete-extent extent))
     (child				; Remove a child widget
      (widget-apply child :delete))
     (t					; Doh!  Do nothing.
      nil))))     

(if (fboundp 'mouse-event-p)
    (fset 'widget-mouse-event-p 'mouse-event-p)
  (fset 'widget-mouse-event-p 'ignore))

(cond
 ((fboundp 'glyphp)
  (fset 'widget-glyphp 'glyphp))
 ((boundp 'image-types)
  (defun widget-glyphp (glyph)
    (and (listp glyph) (plist-get glyph :type))))
 (t
  (fset 'widget-glyphp 'ignore)))

(defun widget-image-button-press (event)
  (interactive "@e")
  (let* ((glyph (and event (widget-mouse-event-p event) (event-glyph event)))
	 (widget (and glyph (glyph-property glyph 'widget))))
    (widget-image-notify widget widget event)))    

(defun widget-image-usemap-default (usemap)
  (let ((rval (and usemap (car usemap))))
    (while usemap
      (if (equal (aref (car usemap) 0) "default")
	  (setq rval (car usemap)
		usemap nil))
      (setq usemap (cdr usemap)))
    rval))

(defun widget-image-summarize (widget)
  (if (widget-get widget :parent)
      (setq widget (widget-get widget :parent)))
  (let* ((ismap  (widget-get widget 'ismap))
	 (usemap (widget-image-usemap widget))
	 (href   (widget-get widget :href))
	 (alt    (widget-get widget 'alt))
	 (value  (widget-value widget)))
    (cond
     (usemap
      (setq usemap (widget-image-usemap-default usemap))
      ;; Perhaps we should do something here with showing the # of entries
      ;; in the imagemap as well as the default href?  Could get too long.
      (format "Client side imagemap: %s" value))
     (ismap
      (format "Server side imagemap: %s" href))
     ((stringp href)			; Normal hyperlink
      (format "Image hyperlink: %s" href))
     ((stringp alt)			; Alternate message was specified
      (format "Image: %s" alt))
     ((stringp value)
      (format "Image: %s" value))
     (t					; Huh?
      "A very confused image widget."))))

(defvar widget-image-auto-retrieve 'ask
  "*Whether to automatically retrieve the source of an image widget
if it is not an active hyperlink or imagemap.
If `nil', don't do anything.
If `t', automatically retrieve the source.
Any other value means ask the user each time.")

(defun widget-image-notify (widget widget-changed &optional event)
  ;; Happens when anything changes
  (let* ((glyph (and event (widget-mouse-event-p event) (event-glyph event)))
	 (x (and glyph (event-glyph-x-pixel event)))
	 (y (and glyph (event-glyph-y-pixel event)))
	 (ismap  (widget-get widget 'ismap))
	 (usemap (widget-image-usemap widget))
	 (href   (widget-get widget :href))
	 (img-src (or (widget-get widget :src)
		      (and widget-changed (widget-get widget-changed :src))))
	 (target (widget-get widget :target))
	 )
    (if target (setq target (intern (downcase target))))
    (cond
     ((and glyph usemap)		; Do the client-side imagemap stuff
      (setq href (w3-point-in-map (vector x y) usemap nil))
      (if (stringp href)
	  (w3-fetch href target)
	(message "No destination found for %d,%d" x y)))
     ((and glyph x y ismap)		; Do the server-side imagemap stuff
      (w3-fetch (format "%s?%d,%d" href x y) target))
     (usemap				; Dummed-down tty client side imap
      (let ((choices (mapcar (function
			      (lambda (entry)
				(cons
				 (or (aref entry 3) (aref entry 2))
				 (aref entry 2)))) usemap))
	    (choice nil)
	    (case-fold-search t))
	(setq choice (completing-read "Imagemap: " choices nil t)
	      choice (cdr-safe (assoc choice choices)))
	(and (stringp choice) (w3-fetch choice target))))
     (ismap				; Do server-side dummy imagemap for tty
      (w3-fetch (concat href "?0,0") target))
     ((stringp href)			; Normal hyperlink
      (w3-fetch href target))
     ((stringp img-src)
      (cond
       ((null widget-image-auto-retrieve) nil)
       ((eq t widget-image-auto-retrieve)
	(w3-fetch img-src))
       ((funcall url-confirmation-func
		 (format "Retrieve image (%s)?"
			 (url-truncate-url-for-viewing img-src)))
	(w3-fetch img-src))))
     (t					; Huh?
      nil))))

(provide 'w3-widget)