cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/w3-widget.el

   1 ;;; w3-widget.el --- An image widget
   2 ;; Author: Bill Perry <wmperry@gnu.org>
   3 ;; Created: $Date: 2002/02/01 17:42:49 $
   4 ;; Version: $Revision: 1.8 $
   5 ;; Keywords: faces, images
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
   9 ;;; Copyright (c) 1996, 1997, 2001 Free Software Foundation, Inc.
  10 ;;;
  11 ;;; This file is part of GNU Emacs.
  12 ;;;
  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
  15 ;;; the Free Software Foundation; either version 2, or (at your option)
  16 ;;; any later version.
  17 ;;;
  18 ;;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  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
  25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;;; Boston, MA 02111-1307, USA.
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28
  29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30 ;;; This is a widget that will do the best it can with an image.
  31 ;;;
  32 ;;; It can handle all the common occurences of images on the world wide web
  33 ;;; 1. A plain image - displays either a glyph of the image, or the
  34 ;;;    alternative text
  35 ;;; 2. A hyperlinked image - an image that is also a hypertext link to
  36 ;;;    another page.  Displays either a glyph of the image, or the
  37 ;;;    alternative text.  When activated with the mouse or the keyboard,
  38 ;;;    the 'href' property of the widget is retrieved.
  39 ;;; 3. Server side imagemaps - an image that has hotzones that lead to
  40 ;;;    different areas.  Unfortunately, we cannot tell where the links go
  41 ;;;    from the client - all processing is done by the server.  Displays
  42 ;;;    either a glyph of the image, or the alternative text.  When activated
  43 ;;;    with the mouse or the keyboard, the coordinates clicked on are
  44 ;;;    sent to the remote server as HREF?x,y.  If the link is activated
  45 ;;;    by the keyboard, then 0,0 are sent as the coordinates.
  46 ;;; 4. Client side imagemaps - an image that has hotzones that lead to
  47 ;;;    different areas.  All processing is done on the client side, so
  48 ;;;    we can actually show a decent representation on a TTY.  Displays
  49 ;;;    either a glyph of the image, or a drop-down-list of the destinations
  50 ;;;    These are either URLs (http://foo/...) or alternative text.
  51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52
  53 ;; I don't think there's currently any way to get the pixel position
  54 ;; of a mouse event on an Emacs 21 image, so image maps aren't going
  55 ;; to work properly.  -- fx
  56
  57 (require 'widget)
  58 (require 'url-util)
  59 (require 'w3-vars)
  60 (autoload 'w3-fetch "w3")
  61 (autoload 'w3-point-in-map "w3-imap")
  62
  63 (defvar widget-image-keymap (make-sparse-keymap)
  64   "Keymap used over glyphs in an image widget")
  65
  66 (defconst widget-mouse-button1 nil)
  67 (defconst widget-mouse-button2 nil)
  68 (defconst widget-mouse-button3 nil)
  69
  70 (if (featurep 'xemacs)
  71     (if (featurep 'mouse)
  72         (setq widget-mouse-button1 'button1
  73               widget-mouse-button2 'button2
  74               widget-mouse-button3 'button3)
  75       (setq widget-mouse-button1 'return
  76             widget-mouse-button2 'return
  77             widget-mouse-button3 'return))
  78   (setq widget-mouse-button1 'mouse-1
  79         widget-mouse-button2 'mouse-2
  80         widget-mouse-button3 'mouse-3))
  81
  82 (defvar widget-image-inaudible-p nil
  83   "*Whether to make images inaudible or not.")
  84
  85 (define-key widget-image-keymap (vector widget-mouse-button1)
  86   'widget-image-button-press)
  87 (define-key widget-image-keymap (vector widget-mouse-button2)
  88   'widget-image-button-press)
  89
  90 (define-widget 'image 'default
  91   "A fairly complex image widget."
  92   :convert-widget 'widget-image-convert
  93   :value-to-internal (lambda (widget value) value)
  94   :value-to-external (lambda (widget value) value)
  95   :value-set 'widget-image-value-set
  96   :create 'widget-image-create
  97   :delete 'widget-image-delete
  98   :value-create 'widget-image-value-create
  99   :value-delete 'widget-image-value-delete
 100   :value-get 'widget-image-value-get
 101   :notify 'widget-image-notify
 102   )
 103
 104 (defun widget-image-convert (widget)
 105   (let ((args (widget-get widget :args)))
 106     (widget-put widget :args nil)
 107     (while args
 108       (widget-put widget (car args) (cadr args))
 109       (setq args (cddr args)))
 110     widget))
 111
 112 (defun widget-image-value-get (widget)
 113   (let ((children (widget-get widget :children)))
 114     (and (car children)
 115          (widget-apply (car children) :value-get))))
 116
 117 (defun widget-image-create (widget)
 118   ;; Create an image widget at point in the current buffer
 119   (let ((where (widget-get widget 'where)))
 120     (cond
 121      ((null where)
 122       (setq where (set-marker (make-marker) (point))))
 123      ((markerp where)
 124       nil)
 125      ((integerp where)
 126       (setq where (set-marker (make-marker) where)))
 127      (t
 128       (error "IMPOSSIBLE position in widget-image-create: %s" where)))
 129     (widget-put widget 'where where))
 130   (widget-image-value-create widget))
 131
 132 (defun widget-image-value-set (widget value)
 133   ;; Recreate widget with new value.
 134   (save-excursion
 135     (widget-image-delete widget)
 136     (if (or (eq 'image (car-safe value)) ; Emacs 21
 137             (widget-glyphp value))
 138         (widget-put widget 'glyph value)
 139       (widget-put widget :value value))
 140     (put-text-property (point)
 141                        (progn
 142                          (widget-apply widget :create)
 143                          (point))
 144                        'inaudible
 145                        widget-image-inaudible-p)))
 146
 147 (defsubst widget-image-usemap (widget)
 148   (let ((usemap (widget-get widget 'usemap)))
 149     (if (listp usemap)
 150         usemap
 151       (if (and usemap (> (length usemap) 0) (eq ?# (aref usemap 0)))
 152           (setq usemap (substring usemap 1 nil)))
 153       (cdr-safe (assoc usemap w3-imagemaps)))))
 154
 155 (defun widget-image-callback (widget widget-ignore &optional event)
 156   (if (widget-get widget :href)
 157       (w3-fetch (widget-get widget :href) (widget-get widget :target))))
 158
 159 (defmacro widget-image-create-subwidget (&rest args)
 160   `(widget-create ,@args
 161                   :parent widget
 162                   :help-echo 'widget-image-summarize
 163                   'usemap (widget-get widget 'usemap)
 164                   :href href
 165                   :target target
 166                   :src (widget-get widget :src)
 167                   'ismap server-map))
 168
 169 (defun widget-image-value-create (widget)
 170   ;; Insert the printed representation of the value
 171   (let ((href (widget-get widget :href))
 172         (target (widget-get widget :target))
 173         (face (widget-get widget :button-face))
 174         (server-map (widget-get widget 'ismap))
 175         (client-map (widget-image-usemap widget))
 176         (where (or (widget-get widget 'where) (point)))
 177         (glyph (widget-get widget 'glyph))
 178         (alt (widget-get widget 'alt))
 179         (align (widget-get widget 'align))
 180         (real-widget nil)
 181         (invalid-glyph nil))
 182     (if target (setq target (intern (downcase target))))
 183
 184     ;; Specifier-instance will signal an error if we have an invalid
 185     ;; image specifier, which would be the case if we get screwed up
 186     ;; data back from a URL somewhere.
 187
 188     (cond
 189      ((featurep 'xemacs)
 190       ;; All XEmacsen have support for glyphs
 191       (setq invalid-glyph (and glyph (condition-case ()
 192                                          (if (fboundp 'specifier-instance)
 193                                              (if (specifier-instance
 194                                                   (glyph-image glyph))
 195                                                  nil)
 196                                            nil)
 197                                        (error t)))))
 198      ((boundp 'image-types)
 199       ;; We are in Emacs 21+, which has image support
 200       (require 'image)
 201       (setq invalid-glyph
 202             (and glyph
 203                  (not (image-type-available-p (plist-get (cdr glyph) :type)))))))
 204
 205     (if (or (not glyph) invalid-glyph)
 206         ;; Do a TTY or delayed image version of the image.
 207         (save-excursion
 208           (if (= 0 (length alt)) (setq alt nil))
 209           (goto-char where)
 210           (cond
 211            (client-map
 212             (let* ((default nil)
 213                    (options (mapcar
 214                              (lambda (x)
 215                                (if (eq (aref x 0) 'default)
 216                                    (setq default (aref x 2)))
 217                                (if (and (not default) (stringp (aref x 2)))
 218                                    (setq default (aref x 2)))
 219                                (list 'choice-item
 220                                      :tab-order -1
 221                                      :delete 'widget-default-delete
 222                                      :format "%[%t%]"
 223                                      :tag (or (aref x 3) (aref x 2))
 224                                      :value (aref x 2))) client-map)))
 225               (setq real-widget
 226                     (apply 'widget-create 'menu-choice
 227                            :tag (or (widget-get widget :tag) alt "Imagemap")
 228                            :button-face face
 229                            :format "%[%t:%v%]"
 230                            :ignore-case t
 231                            :notify (widget-get widget :notify)
 232                            :delete 'widget-default-delete
 233                            :action (widget-get widget :action)
 234                            :value default
 235                            :parent widget
 236                            :help-echo 'widget-image-summarize
 237                            options))))
 238            ((and server-map (stringp href))
 239             (setq real-widget
 240                   (widget-image-create-subwidget
 241                    'item :format "%[%t%]"
 242                    :tag alt
 243                    :button-face face
 244                    :delete 'widget-default-delete
 245                    :value href
 246                    :action (widget-get widget :action)
 247                    :notify (widget-get widget :notify))))
 248            (href
 249             (setq real-widget
 250                   (widget-image-create-subwidget
 251                    'item :format "%[%t%]"
 252                    :tag (or alt "Image")
 253                    :button-face face
 254                    :value href
 255                    :delete 'widget-default-delete
 256                    :action (widget-get widget :action)
 257                    :notify 'widget-image-callback)))
 258            (alt
 259             (setq real-widget
 260                   (widget-image-create-subwidget
 261                    'item :format "%[%t%]"
 262                    :tag alt
 263                    :button-face face
 264                    :tab-order -1
 265                    :delete 'widget-default-delete
 266                    :action (widget-get widget :action)
 267                    :notify 'widget-image-callback))))
 268           (if real-widget
 269               (widget-put widget :children (list real-widget))))
 270       ;;; Actually use the image
 271       (cond
 272        ((featurep 'xemacs)
 273         (let ((extent (or (widget-get widget 'extent)
 274                           (make-extent where where))))
 275           (set-extent-endpoints extent where where)
 276           (widget-put widget 'extent extent)
 277           (widget-put widget :children nil)
 278           (set-extent-property extent 'keymap widget-image-keymap)
 279           (set-extent-property extent 'begin-glyph glyph)
 280           (set-extent-property extent 'detachable t)
 281           (set-extent-property extent 'help-echo
 282                                (cond
 283                                 ((and href (or client-map
 284                                                server-map))
 285                                  (format "%s [map]" href))
 286                                 (href href)
 287                                 (t nil)))
 288           (set-glyph-property glyph 'widget widget)))
 289        ((fboundp 'insert-image)
 290         ;; Emacs 21!
 291         (let ((buffer-read-only nil)
 292               (after-change-functions nil)
 293               (before-change-functions nil))
 294           (insert-image glyph
 295                         (propertize " "
 296                                     'keymap widget-image-keymap
 297                                     'help-echo (cond
 298                                                 ((and href (or client-map
 299                                                                server-map))
 300                                                  (format "%s [map]" href))
 301                                                 (href href))))))))))
 302
 303 (defun widget-image-delete (widget)
 304   "Remove WIDGET from the buffer."
 305   (let ((extent (widget-get widget 'extent))
 306         (child  (car (widget-get widget :children))))
 307     (cond
 308      (extent                            ; Remove a glyph
 309       (if (fboundp 'delete-extent)
 310           (delete-extent extent)
 311         (delete-overlay extent)))
 312      (child                             ; Remove a child widget
 313       (widget-apply child :delete))
 314      (t                                 ; Doh!  Do nothing.
 315       nil))))
 316
 317 (if (fboundp 'mouse-event-p)
 318     (defalias 'widget-mouse-event-p 'mouse-event-p)
 319   (defalias 'widget-mouse-event-p 'ignore))
 320
 321 (cond
 322  ((fboundp 'glyphp)
 323   (defalias 'widget-glyphp 'glyphp))
 324  ((boundp 'image-types)
 325   (defun widget-glyphp (glyph)
 326     (and (listp glyph) (eq 'image (car glyph)))))
 327  (t
 328   (defalias 'widget-glyphp 'ignore)))
 329
 330 (defun widget-image-button-press (event)
 331   (interactive "@e")
 332   (if (featurep 'xemacs)
 333       (let* ((glyph (and event (widget-mouse-event-p event)
 334                          (event-glyph event)))
 335              (widget (and glyph (glyph-property glyph 'widget))))
 336         (widget-image-notify widget widget event))
 337     (save-excursion
 338       (mouse-set-point event)
 339       (let ((widget (widget-at (point))))
 340         (widget-image-notify widget widget event)))))
 341
 342 (defun widget-image-usemap-default (usemap)
 343   (let ((rval (and usemap (car usemap))))
 344     (while usemap
 345       (if (equal (aref (car usemap) 0) "default")
 346           (setq rval (car usemap)
 347                 usemap nil))
 348       (setq usemap (cdr usemap)))
 349     rval))
 350
 351 (defun widget-image-summarize (widget)
 352   (if (widget-get widget :parent)
 353       (setq widget (widget-get widget :parent)))
 354   (let* ((ismap  (widget-get widget 'ismap))
 355          (usemap (widget-image-usemap widget))
 356          (href   (widget-get widget :href))
 357          (alt    (widget-get widget 'alt))
 358          (value  (widget-value widget)))
 359     (cond
 360      (usemap
 361       (setq usemap (widget-image-usemap-default usemap))
 362       ;; Perhaps we should do something here with showing the # of entries
 363       ;; in the imagemap as well as the default href?  Could get too long.
 364       (format "Client side imagemap: %s" value))
 365      (ismap
 366       (format "Server side imagemap: %s" href))
 367      ((stringp href)                    ; Normal hyperlink
 368       (format "Image hyperlink: %s" href))
 369      ((stringp alt)                     ; Alternate message was specified
 370       (format "Image: %s" alt))
 371      ((stringp value)
 372       (format "Image: %s" value))
 373      (t                                 ; Huh?
 374       "A very confused image widget."))))
 375
 376 (defvar widget-image-auto-retrieve 'ask
 377   "*Whether to automatically retrieve the source of an image widget
 378 if it is not an active hyperlink or imagemap.
 379 If `nil', don't do anything.
 380 If `t', automatically retrieve the source.
 381 Any other value means ask the user each time.")
 382
 383 (defun widget-image-notify (widget widget-changed &optional event)
 384   ;; Happens when anything changes
 385   (let* ((glyph (and event (widget-mouse-event-p event) (event-glyph event)))
 386          (x (and glyph (event-glyph-x-pixel event)))
 387          (y (and glyph (event-glyph-y-pixel event)))
 388          (ismap  (widget-get widget 'ismap))
 389          (usemap (widget-image-usemap widget))
 390          (href   (widget-get widget :href))
 391          (img-src (or (widget-get widget :src)
 392                       (and widget-changed (widget-get widget-changed :src))))
 393          (target (widget-get widget :target))
 394          )
 395     (if target (setq target (intern (downcase target))))
 396     (cond
 397      ((and glyph usemap)                ; Do the client-side imagemap stuff
 398       (setq href (w3-point-in-map (vector x y) usemap nil))
 399       (if (stringp href)
 400           (w3-fetch href target)
 401         (message "No destination found for %d,%d" x y)))
 402      ((and glyph x y ismap)             ; Do the server-side imagemap stuff
 403       (w3-fetch (format "%s?%d,%d" href x y) target))
 404      (usemap                            ; Dumbed-down tty client side imap
 405       (let ((choices (mapcar (lambda (entry)
 406                                (cons
 407                                 (or (aref entry 3) (aref entry 2))
 408                                 (aref entry 2)))
 409                              usemap))
 410             (choice nil)
 411             (case-fold-search t))
 412         (setq choice (completing-read "Imagemap: " choices nil t)
 413               choice (cdr-safe (assoc choice choices)))
 414         (and (stringp choice) (w3-fetch choice target))))
 415      (ismap                             ; Do server-side dummy imagemap for tty
 416       (w3-fetch (concat href "?0,0") target))
 417      ((stringp href)                    ; Normal hyperlink
 418       (w3-fetch href target))
 419      ((stringp img-src)
 420       (cond
 421        ((null widget-image-auto-retrieve) nil)
 422        ((eq t widget-image-auto-retrieve)
 423         (w3-fetch img-src))
 424        ((funcall url-confirmation-func
 425                  (format "Retrieve image (%s)?"
 426                          (url-truncate-url-for-viewing img-src)))
 427         (w3-fetch img-src))))
 428      (t                                 ; Huh?
 429       nil))))
 430
 431 (provide 'w3-widget)