(U+536A): Add UU+537D as a target of `->interchangeable'.

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

diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index a311bc4..aaa80ca 100644 (file)
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -1,9 +1,9 @@
 ;;; wid-edit.el --- Functions for creating and using widgets.
 ;;
 ;;; wid-edit.el --- Functions for creating and using widgets.
 ;;

-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc.

 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>

-;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
+;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>

 ;; Keywords: extensions
 ;; Version: 1.9960-x
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;; Keywords: extensions
 ;; Version: 1.9960-x
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/

@@ -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)

@@ -479,14 +480,22 @@ Suitable for use with `map-extents'."
       (let* ((glyph-widget (extent-property extent 'glyph-widget))
             (up-glyph (widget-get glyph-widget :glyph-up))
             (inactive-glyph (widget-get glyph-widget :glyph-inactive))
       (let* ((glyph-widget (extent-property extent 'glyph-widget))
             (up-glyph (widget-get glyph-widget :glyph-up))
             (inactive-glyph (widget-get glyph-widget :glyph-inactive))

+            (instantiator (widget-get glyph-widget :glyph-instantiator))

             (new-glyph (if activate-p up-glyph inactive-glyph)))
             (new-glyph (if activate-p up-glyph inactive-glyph)))

+       (cond
+        ;; Assume that an instantiator means a native widget.
+        (instantiator
+         (setq instantiator
+               (set-instantiator-property instantiator :active activate-p))
+         (widget-put glyph-widget :glyph-instantiator instantiator)
+         (set-glyph-image up-glyph instantiator))

         ;; Check that the new glyph exists, and differs from the
         ;; default one.
         ;; Check that the new glyph exists, and differs from the
         ;; default one.

-       (and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph))
-            ;; Check if the glyph is already installed.
-            (not (eq (extent-end-glyph extent) new-glyph))
-            ;; Change it.
-            (set-extent-end-glyph extent new-glyph)))))
+        ((and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph))
+              ;; Check if the glyph is already installed.
+              (not (eq (extent-end-glyph extent) new-glyph)))
+         ;; Change it.
+         (set-extent-end-glyph extent new-glyph))))))

   nil)
 
 (defun widget-specify-inactive (widget from to)
   nil)
 
 (defun widget-specify-inactive (widget from to)

@@ -511,14 +520,16 @@ Suitable for use with `map-extents'."
 
 (defun widget-specify-active (widget)
   "Make WIDGET active for user modifications."
 
 (defun widget-specify-active (widget)
   "Make WIDGET active for user modifications."

-  (let ((inactive (widget-get widget :inactive)))
+  (let ((inactive (widget-get widget :inactive))
+        (from (widget-get widget :from))
+        (to (widget-get widget :to)))

     (when (and inactive (not (extent-detached-p inactive)))
       ;; Reactivate the buttons and fields covered by the extent.
       (map-extents 'widget-activation-widget-mapper
     (when (and inactive (not (extent-detached-p inactive)))
       ;; Reactivate the buttons and fields covered by the extent.
       (map-extents 'widget-activation-widget-mapper

-                  inactive nil nil :activate nil 'button-or-field)
+                   nil from to :activate nil 'button-or-field)

       ;; Reactivate the glyphs.
       (map-extents 'widget-activation-glyph-mapper
       ;; Reactivate the glyphs.
       (map-extents 'widget-activation-glyph-mapper

-                  inactive nil nil :activate nil 'end-glyph)
+                   nil from to :activate nil 'end-glyph)

       (delete-extent inactive)
       (widget-put widget :inactive nil))))
 
       (delete-extent inactive)
       (widget-put widget :inactive nil))))
 

@@ -533,7 +544,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:

@@ -565,7 +576,7 @@ Otherwise, just return the value."
       value)))
 
 (defun widget-member (widget property)
       value)))
 
 (defun widget-member (widget property)

-  "Non-nil iff there is a definition in WIDGET for PROPERTY."
+  "Return t if there is a definition in WIDGET for PROPERTY."

   (cond ((widget-plist-member (cdr widget) property)
         t)
        ((car widget)
   (cond ((widget-plist-member (cdr widget) property)
         t)
        ((car widget)

@@ -600,7 +611,7 @@ ARGS are passed as extra arguments to the function."
   ;; In WIDGET, match the start of VALS.
   (cond ((widget-get widget :inline)
         (widget-apply widget :match-inline vals))
   ;; In WIDGET, match the start of VALS.
   (cond ((widget-get widget :inline)
         (widget-apply widget :match-inline vals))

-       ((and vals
+       ((and (listp vals)

              (widget-apply widget :match (car vals)))
         (cons (list (car vals)) (cdr vals)))
        (t nil)))
              (widget-apply widget :match (car vals)))
         (cons (list (car vals)) (cdr vals)))
        (t nil)))

@@ -673,7 +684,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 +733,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])))

@@ -782,10 +793,12 @@ only because of compatibility."
       (insert tag))
     glyph))
 
       (insert tag))
     glyph))
 

-(defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
+(defun widget-glyph-insert-glyph (widget glyph &optional down inactive
+                                        instantiator)

   "In WIDGET, insert GLYPH.
 If optional arguments DOWN and INACTIVE are given, they should be
   "In WIDGET, insert GLYPH.
 If optional arguments DOWN and INACTIVE are given, they should be

-glyphs used when the widget is pushed and inactive, respectively."
+glyphs used when the widget is pushed and inactive, respectively.
+INSTANTIATOR is the vector used to create the glyph."

   (insert "*")
   (let ((extent (make-extent (point) (1- (point))))
        (help-echo (and widget (widget-get widget :help-echo)))
   (insert "*")
   (let ((extent (make-extent (point) (1- (point))))
        (help-echo (and widget (widget-get widget :help-echo)))

@@ -807,6 +820,7 @@ glyphs used when the widget is pushed and inactive, respectively."
   (when widget
     (widget-put widget :glyph-up glyph)
     (when down (widget-put widget :glyph-down down))
   (when widget
     (widget-put widget :glyph-up glyph)
     (when down (widget-put widget :glyph-down down))

+    (when instantiator (widget-put widget :glyph-instantiator instantiator))

     (when inactive (widget-put widget :glyph-inactive inactive))))
 
 \f
     (when inactive (widget-put widget :glyph-inactive inactive))))
 
 \f

@@ -1040,7 +1054,7 @@ Recommended as a parent keymap for modes using widgets.")
 
 
 (defun widget-field-activate (pos &optional event)
 
 
 (defun widget-field-activate (pos &optional event)

-  "Invoke the ediable field at point."
+  "Invoke the editable field at point."

   (interactive "@d")
   (let ((field (widget-field-find pos)))
     (if field
   (interactive "@d")
   (let ((field (widget-field-find pos)))
     (if field

@@ -1063,48 +1077,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 +1143,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.

@@ -1346,7 +1361,7 @@ With optional ARG, move across that many fields."
          (t
           (when (and (null arg)
                      (= last-non-space (point)))
          (t
           (when (and (null arg)
                      (= last-non-space (point)))

-            (forward-char -1))
+            (backward-char 1))

           (transpose-chars arg)))))
 
 (defcustom widget-complete-field (lookup-key global-map "\M-\t")
           (transpose-chars arg)))))
 
 (defcustom widget-complete-field (lookup-key global-map "\M-\t")

@@ -1896,9 +1911,6 @@ If END is omitted, it defaults to the length of LIST."
   :group 'widgets
   :type 'boolean)
 
   :group 'widgets
   :type 'boolean)
 

-;; Cache already created GUI objects.
-(defvar widget-push-button-cache nil)
-

 (defcustom widget-push-button-prefix "["
   "String used as prefix for buttons."
   :type 'string
 (defcustom widget-push-button-prefix "["
   "String used as prefix for buttons."
   :type 'string

@@ -1923,7 +1935,7 @@ If END is omitted, it defaults to the length of LIST."
         (tag-glyph (widget-get widget :tag-glyph))
         (text (concat widget-push-button-prefix
                       tag widget-push-button-suffix))
         (tag-glyph (widget-get widget :tag-glyph))
         (text (concat widget-push-button-prefix
                       tag widget-push-button-suffix))

-        (gui-glyphs (lax-plist-get widget-push-button-cache tag)))
+        gui inst)

     (cond (tag-glyph
           (widget-glyph-insert widget text tag-glyph))
          ;; We must check for console-on-window-system-p here,
     (cond (tag-glyph
           (widget-glyph-insert widget text tag-glyph))
          ;; We must check for console-on-window-system-p here,

@@ -1931,18 +1943,10 @@ If END is omitted, it defaults to the length of LIST."
          ;; components for colors, and they are not known on TTYs).
          ((and widget-push-button-gui
                (console-on-window-system-p))
          ;; components for colors, and they are not known on TTYs).
          ((and widget-push-button-gui
                (console-on-window-system-p))

-          (unless gui-glyphs
-            (let* ((gui-button-shadow-thickness 1)
-                   (gui (make-gui-button tag 'widget-gui-action widget)))
-              (setq
-               gui-glyphs
-               (list
-                (make-glyph `(,(nth 0 (aref gui 1)) [string :data ,text]))
-                (make-glyph `(,(nth 1 (aref gui 1)) [string :data ,text]))
-                (make-glyph `(,(nth 2 (aref gui 1)) [string :data ,text]))))
-              (laxputf widget-push-button-cache tag gui-glyphs)))
-          (widget-glyph-insert-glyph
-           widget (nth 0 gui-glyphs) (nth 1 gui-glyphs) (nth 2 gui-glyphs)))
+          (let* ((gui-button-shadow-thickness 1))
+            (setq inst (make-gui-button tag 'widget-gui-action widget))
+            (setq gui (make-glyph inst)))
+          (widget-glyph-insert-glyph widget gui nil nil inst))

          (t
           (insert text)))))
 
          (t
           (insert text)))))
 

@@ -1995,8 +1999,8 @@ If END is omitted, it defaults to the length of LIST."
 
 (defun widget-url-link-action (widget &optional event)
   "Open the url specified by WIDGET."
 
 (defun widget-url-link-action (widget &optional event)
   "Open the url specified by WIDGET."

-  (if (boundp 'browse-url-browser-function)
-      (funcall browse-url-browser-function (widget-value widget))
+  (if (fboundp 'browse-url)
+      (browse-url (widget-value widget))

     (error "Cannot follow URLs in this XEmacs")))
 
 ;;; The `function-link' Widget.
     (error "Cannot follow URLs in this XEmacs")))
 
 ;;; The `function-link' Widget.

@@ -2530,7 +2534,7 @@ when he invoked the menu."
     found))
 
 (defun widget-checklist-match-up (args vals)
     found))
 
 (defun widget-checklist-match-up (args vals)

-  ;; Rerturn the first type from ARGS that matches VALS.
+  ;; Return the first type from ARGS that matches VALS.

   (let (current found)
     (while (and args (null found))
       (setq current (car args)
   (let (current found)
     (while (and args (null found))
       (setq current (car args)

@@ -2552,7 +2556,7 @@ when he invoked the menu."
     result))
 
 (defun widget-checklist-validate (widget)
     result))
 
 (defun widget-checklist-validate (widget)

-  ;; Ticked chilren must be valid.
+  ;; Ticked children must be valid.

   (let ((children (widget-get widget :children))
        child button found)
     (while (and children (not found))
   (let ((children (widget-get widget :children))
        child button found)
     (while (and children (not found))