Add mapping-table for `latin-viscii'.

[chise/xemacs-chise.git] / lisp / wid-edit.el

diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index a311bc4..a21f19c 100644 (file)
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -49,7 +49,7 @@
   :group 'hypermedia)
 
 (defgroup widget-documentation nil
   :group 'hypermedia)
 
 (defgroup widget-documentation nil

-  "Options controling the display of documentation strings."
+  "Options controlling the display of documentation strings."

   :group 'widgets)
 
 (defgroup widget-faces nil
   :group 'widgets)
 
 (defgroup widget-faces nil

@@ -302,6 +302,7 @@ new value."
     (and (functionp help-echo)
         (setq help-echo (funcall help-echo widget)))
     (when (stringp help-echo)
     (and (functionp help-echo)
         (setq help-echo (funcall help-echo widget)))
     (when (stringp help-echo)

+      (setq help-echo-owns-message t)

       (display-message 'help-echo help-echo))))
 
 (defsubst widget-handle-help-echo (extent help-echo)
       (display-message 'help-echo help-echo))))
 
 (defsubst widget-handle-help-echo (extent help-echo)

@@ -533,7 +534,7 @@ Suitable for use with `map-extents'."
          widget-shadow-subrs)
   (defun widget-put (widget property value)
     "In WIDGET set PROPERTY to VALUE.
          widget-shadow-subrs)
   (defun widget-put (widget property value)
     "In WIDGET set PROPERTY to VALUE.

-The value can later be retrived with `widget-get'."
+The value can later be retrieved with `widget-get'."

     (setcdr widget (plist-put (cdr widget) property value))))
 
 ;; Recoded in C, for efficiency:
     (setcdr widget (plist-put (cdr widget) property value))))
 
 ;; Recoded in C, for efficiency:

@@ -673,7 +674,7 @@ automatically."
   :group 'widgets
   :type 'boolean)
 
   :group 'widgets
   :type 'boolean)
 

-(defcustom widget-image-conversion
+(defcustom widget-image-file-name-suffixes

   '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
     (xbm ".xbm"))
   "Conversion alist from image formats to file name suffixes."
   '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
     (xbm ".xbm"))
   "Conversion alist from image formats to file name suffixes."

@@ -722,27 +723,27 @@ It can also be a valid image instantiator, in which case it will be
             (let* ((dirlist (cons (or widget-glyph-directory
                                       (locate-data-directory "custom"))
                                   data-directory-list))
             (let* ((dirlist (cons (or widget-glyph-directory
                                       (locate-data-directory "custom"))
                                   data-directory-list))

-                   (formats widget-image-conversion)
-                   file)
-              (while (and formats (not file))
-                ;; This dance is necessary, because XEmacs signals an
-                ;; error when it encounters an unrecognized image
-                ;; format.
-                (when (valid-image-instantiator-format-p (caar formats))
-                  (setq file (locate-file image dirlist
-                                          (mapconcat 'identity (cdar formats)
-                                                     ":"))))
-                (unless file
-                  (pop formats)))
+                   (all-suffixes
+                    (apply #'append
+                           (mapcar
+                            (lambda (el)
+                              (and (valid-image-instantiator-format-p (car el))
+                                   (cdr el)))
+                            widget-image-file-name-suffixes)))
+                   (file (locate-file image dirlist all-suffixes)))

               (when file
               (when file

-                ;; We create a glyph with the file as the default image
-                ;; instantiator, and the TAG fallback
-                (let ((glyph (make-glyph `([,(caar formats) :file ,file]
-                                           [string :data ,tag]))))
-                  ;; Cache the glyph
-                  (laxputf widget-glyph-cache image glyph)
-                  ;; ...and return it
-                  glyph)))))
+                (let* ((extension (concat "." (file-name-extension file)))
+                       (format (car (rassoc* extension
+                                             widget-image-file-name-suffixes
+                                             :test #'member))))
+                  ;; We create a glyph with the file as the default image
+                  ;; instantiator, and the TAG fallback
+                  (let ((glyph (make-glyph `([,format :file ,file]
+                                             [string :data ,tag]))))
+                    ;; Cache the glyph
+                    (laxputf widget-glyph-cache image glyph)
+                    ;; ...and return it
+                    glyph))))))

        ((valid-instantiator-p image 'image)
         ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
         (make-glyph `(,image [string :data ,tag])))
        ((valid-instantiator-p image 'image)
         ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
         (make-glyph `(,image [string :data ,tag])))

@@ -1063,48 +1064,49 @@ Recommended as a parent keymap for modes using widgets.")
 
 (defun widget-button-click (event)
   "Invoke button below mouse pointer."
 
 (defun widget-button-click (event)
   "Invoke button below mouse pointer."

-  (interactive "@e")
-  (cond ((event-glyph event)
-        (widget-glyph-click event))
-       ((widget-event-point event)
-        (let* ((pos (widget-event-point event))
-               (button (get-char-property pos 'button)))
-          (if button
-              (let* ((extent (widget-get button :button-extent))
-                     (face (extent-property extent 'face))
-                     (mouse-face (extent-property extent 'mouse-face))
-                     (help-echo (extent-property extent 'help-echo)))
-                (unwind-protect
-                    (progn
-                      ;; Merge relevant faces, and make the result mouse-face.
-                      (let ((merge `(widget-button-pressed-face ,mouse-face)))
-                        (nconc merge (if (listp face)
-                                         face (list face)))
-                        (setq merge (delete-if-not 'find-face merge))
-                        (set-extent-property extent 'mouse-face merge))
-                      (unless (widget-apply button :mouse-down-action event)
-                        ;; Wait for button release.
-                        (while (not (button-release-event-p
-                                     (setq event (next-event))))
-                          (dispatch-event event)))
-                      ;; Disallow mouse-face and help-echo.
-                      (set-extent-property extent 'mouse-face nil)
-                      (set-extent-property extent 'help-echo nil)
-                      (setq pos (widget-event-point event))
-                      (unless (eq (current-buffer) (extent-object extent))
-                        ;; Barf if dispatch-event tripped us by
-                        ;; changing buffer.
-                        (error "Buffer changed during mouse motion"))
-                      ;; Do the associated action.
-                      (when (and pos (extent-in-region-p extent pos pos))
-                        (widget-apply-action button event)))
-                  ;; Unwinding: fully release the button.
-                  (set-extent-property extent 'mouse-face mouse-face)
-                  (set-extent-property extent 'help-echo help-echo)))
-            ;; This should not happen!
-            (error "`widget-button-click' called outside button"))))
-       (t
-        (message "You clicked somewhere weird"))))
+  (interactive "e")
+  (with-current-buffer (event-buffer event)
+    (cond ((event-glyph event)
+          (widget-glyph-click event))
+         ((widget-event-point event)
+          (let* ((pos (widget-event-point event))
+                 (button (get-char-property pos 'button)))
+            (if button
+                (let* ((extent (widget-get button :button-extent))
+                       (face (extent-property extent 'face))
+                       (mouse-face (extent-property extent 'mouse-face))
+                       (help-echo (extent-property extent 'help-echo)))
+                  (unwind-protect
+                      (progn
+                        ;; Merge relevant faces, and make the result mouse-face.
+                        (let ((merge `(widget-button-pressed-face ,mouse-face)))
+                          (nconc merge (if (listp face)
+                                           face (list face)))
+                          (setq merge (delete-if-not 'find-face merge))
+                          (set-extent-property extent 'mouse-face merge))
+                        (unless (widget-apply button :mouse-down-action event)
+                          ;; Wait for button release.
+                          (while (not (button-release-event-p
+                                       (setq event (next-event))))
+                            (dispatch-event event)))
+                        ;; Disallow mouse-face and help-echo.
+                        (set-extent-property extent 'mouse-face nil)
+                        (set-extent-property extent 'help-echo nil)
+                        (setq pos (widget-event-point event))
+                        (unless (eq (current-buffer) (extent-object extent))
+                          ;; Barf if dispatch-event tripped us by
+                          ;; changing buffer.
+                          (error "Buffer changed during mouse motion"))
+                        ;; Do the associated action.
+                        (when (and pos (extent-in-region-p extent pos pos))
+                          (widget-apply-action button event)))
+                    ;; Unwinding: fully release the button.
+                    (set-extent-property extent 'mouse-face mouse-face)
+                    (set-extent-property extent 'help-echo help-echo)))
+              ;; This should not happen!
+              (error "`widget-button-click' called outside button"))))
+         (t
+          (message "You clicked somewhere weird")))))

 
 (defun widget-button1-click (event)
   "Invoke glyph below mouse pointer."
 
 (defun widget-button1-click (event)
   "Invoke glyph below mouse pointer."

@@ -1128,7 +1130,7 @@ Recommended as a parent keymap for modes using widgets.")
       (error "This widget is inactive"))
     (let ((current-glyph 'down))
       ;; We always know what glyph is drawn currently, to avoid
       (error "This widget is inactive"))
     (let ((current-glyph 'down))
       ;; We always know what glyph is drawn currently, to avoid

-      ;; unnecessary extent changes.  Is this any noticable gain?
+      ;; unnecessary extent changes.  Is this any noticeable gain?

       (unwind-protect
          (progn
            ;; Press the glyph.
       (unwind-protect
          (progn
            ;; Press the glyph.