XEmacs 21.4.9 "Informed Management".

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

diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index a21f19c..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/

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

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

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

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

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

@@ -808,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

@@ -1041,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

@@ -1348,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")

@@ -1898,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

@@ -1925,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,

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

@@ -1997,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.

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

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