diff lisp/wid-edit.el @ 18033:bccd356a3b7c

Synched with version 1.9900.

--- a/lisp/wid-edit.el	Thu May 29 23:27:40 1997 +0000
+++ b/lisp/wid-edit.el	Fri May 30 00:39:40 1997 +0000
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <[e-mail]>
 ;; Keywords: extensions
-;; Version: 1.97
+;; Version: 1.9900
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 
 ;; This file is part of GNU Emacs.
@@ -31,8 +31,7 @@
 ;;; Code:
 
 (require 'widget)
-
-(eval-when-compile (require 'cl))
+(require 'cl)
 
 ;;; Compatibility.
 
@@ -146,7 +145,7 @@
 			      (:background "gray85"))
 			     (((class grayscale color)
 			       (background dark))
-			      (:background "dark gray"))
+			      (:background "dim gray"))
 			     (t 
 			      (:italic t)))
   "Face used for editable fields."
@@ -542,7 +541,7 @@
 (defcustom widget-glyph-directory (concat data-directory "custom/")
   "Where widget glyphs are located.
 If this variable is nil, widget will try to locate the directory
-automatically. This does not work yet."
+automatically."
   :group 'widgets
   :type 'directory)
 
@@ -551,47 +550,75 @@
   :group 'widgets
   :type 'boolean)
 
+(defcustom widget-image-conversion
+  '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
+    (xbm ".xbm"))
+  "Conversion alist from image formats to file name suffixes."
+  :group 'widgets
+  :type '(repeat (cons :format "%v"
+		       (symbol :tag "Image Format" unknown)
+		       (repeat :tag "Suffixes"
+			       (string :format "%v")))))
+
 (defun widget-glyph-insert (widget tag image)
   "In WIDGET, insert the text TAG or, if supported, IMAGE.
-IMAGE should either be a glyph, or a name sans extension of an xpm or
-xbm file located in `widget-glyph-directory'.
+IMAGE should either be a glyph, an image instantiator, or an image file
+name sans extension (xpm, xbm, gif, jpg, or png) located in
+`widget-glyph-directory'.
 
 WARNING: If you call this with a glyph, and you want the user to be
-able to activate the glyph, make sure it is unique.  If you use the
-same glyph for multiple widgets, activating any of the glyphs will
-cause the last created widget to be activated."
+able to invoke the glyph, make sure it is unique.  If you use the
+same glyph for multiple widgets, invoking any of the glyphs will
+cause the last created widget to be invoked."
   (cond ((not (and (string-match "XEmacs" emacs-version)
 		   widget-glyph-enable
 		   (fboundp 'make-glyph)
+		   (fboundp 'locate-file)
 		   image))
 	 ;; We don't want or can't use glyphs.
 	 (insert tag))
 	((and (fboundp 'glyphp)
 	      (glyphp image))
 	 ;; Already a glyph.  Insert it.
-	 (widget-glyph-insert-glyph widget tag image))
+	 (widget-glyph-insert-glyph widget image))
+	((stringp image)
+	 ;; A string.  Look it up in relevant directories.
+	 (let* ((dirlist (list (or widget-glyph-directory
+				   (concat data-directory
+					   "custom/"))
+			       data-directory))
+		(formats widget-image-conversion)
+		file)
+	   (while (and formats (not file))
+	     (if (valid-image-instantiator-format-p (car (car formats)))
+		 (setq file (locate-file image dirlist
+					 (mapconcat 'identity (cdr (car formats))
+						    ":")))
+	       (setq formats (cdr formats))))
+	   ;; We create a glyph with the file as the default image
+	   ;; instantiator, and the TAG fallback
+	   (widget-glyph-insert-glyph
+	    widget
+	    (make-glyph (if file
+			    (list (vector (car (car formats)) ':file file)
+				  (vector 'string ':data tag))
+			  (vector 'string ':data tag))))))
+	((valid-instantiator-p image 'image)
+	 ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
+	 (widget-glyph-insert-glyph
+	  widget
+	  (make-glyph (list image
+			    (vector 'string ':data tag)))))
 	(t
-	 ;; A string.  Look it up in.
-	 (let ((file (concat widget-glyph-directory 
-			    (if (string-match "/\\'" widget-glyph-directory)
-				""
-			      "/")
-			    image
-			    (if (featurep 'xpm) ".xpm" ".xbm"))))
-	   (if (file-readable-p file)
-	       (widget-glyph-insert-glyph widget tag (make-glyph file))
-	     ;; File not readable, give up.
-	     (insert tag))))))
+	 ;; Oh well.
+	 (insert tag))))
 
-(defun widget-glyph-insert-glyph (widget tag glyph &optional down inactive)
+(defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
   "In WIDGET, with alternative text TAG, insert GLYPH."
-  (set-glyph-image glyph (cons 'tty tag))
   (set-glyph-property glyph 'widget widget)
   (when down
-    (set-glyph-image down (cons 'tty tag))
     (set-glyph-property down 'widget widget))
   (when inactive
-    (set-glyph-image inactive (cons 'tty tag))
     (set-glyph-property inactive 'widget widget))
   (insert "*")
   (add-text-properties (1- (point)) (point) 
@@ -610,6 +637,30 @@
 						      help-echo
 						    'widget-mouse-help))))))
 
+;;; Buttons.
+
+(defgroup widget-button nil
+  "The look of various kinds of buttons."
+  :group 'widgets)
+
+(defcustom widget-button-prefix ""
+  "String used as prefix for buttons."
+  :type 'string
+  :group 'widgets)
+
+(defcustom widget-button-suffix ""
+  "String used as suffix for buttons."
+  :type 'string
+  :group 'widgets)
+
+(defun widget-button-insert-indirect (widget key)
+  "Insert value of WIDGET's KEY property."
+  (let ((val (widget-get widget key)))
+    (while (and val (symbolp val))
+      (setq val (symbol-value val)))
+    (when val 
+      (insert val))))
+
 ;;; Creating Widgets.
 
 ;;;###autoload
@@ -762,7 +813,7 @@
   (set-keymap-parent widget-text-keymap global-map))
 
 (defun widget-field-activate (pos &optional event)
-  "Activate the ediable field at point."
+  "Invoke the ediable field at point."
   (interactive "@d")
   (let ((field (get-text-property pos 'field)))
     (if field
@@ -779,7 +830,7 @@
   :group 'widgets)
 
 (defun widget-button-click (event)
-  "Activate button below mouse pointer."
+  "Invoke button below mouse pointer."
   (interactive "@e")
   (cond ((and (fboundp 'event-glyph)
 	      (event-glyph event))
@@ -828,7 +879,7 @@
 	 (message "You clicked somewhere weird."))))
 
 (defun widget-button1-click (event)
-  "Activate glyph below mouse pointer."
+  "Invoke glyph below mouse pointer."
   (interactive "@e")
   (if (and (fboundp 'event-glyph)
 	   (event-glyph event))
@@ -863,7 +914,7 @@
 	       (widget-apply-action widget event)))))))
 
 (defun widget-button-press (pos &optional event)
-  "Activate button at POS."
+  "Invoke button at POS."
   (interactive "@d")
   (let ((button (get-text-property pos 'button)))
     (if button
@@ -1136,6 +1187,8 @@
   "Basic widget other widgets are derived from."
   :value-to-internal (lambda (widget value) value)
   :value-to-external (lambda (widget value) value)
+  :button-prefix 'widget-button-prefix
+  :button-suffix 'widget-button-suffix
   :create 'widget-default-create
   :indent nil
   :offset 0
@@ -1159,9 +1212,6 @@
   "Create WIDGET at point in the current buffer."
   (widget-specify-insert
    (let ((from (point))
-	 (tag (widget-get widget :tag))
-	 (glyph (widget-get widget :tag-glyph))
-	 (doc (widget-get widget :doc))
 	 button-begin button-end
 	 sample-begin sample-end
 	 doc-begin doc-end
@@ -1175,8 +1225,10 @@
 	 (cond ((eq escape ?%)
 		(insert "%"))
 	       ((eq escape ?\[)
-		(setq button-begin (point)))
+		(setq button-begin (point))
+		(widget-button-insert-indirect widget :button-prefix))
 	       ((eq escape ?\])
+		(widget-button-insert-indirect widget :button-suffix)
 		(setq button-end (point)))
 	       ((eq escape ?\{)
 		(setq sample-begin (point)))
@@ -1187,21 +1239,24 @@
 		  (insert "\n")
 		  (insert-char ?  (widget-get widget :indent))))
 	       ((eq escape ?t)
-		(cond (glyph 
-		       (widget-glyph-insert widget (or tag "image") glyph))
-		      (tag
-		       (insert tag))
-		      (t
-		       (let ((standard-output (current-buffer)))
-			 (princ (widget-get widget :value))))))
+		(let ((glyph (widget-get widget :tag-glyph))
+		      (tag (widget-get widget :tag)))
+		  (cond (glyph 
+			 (widget-glyph-insert widget (or tag "image") glyph))
+			(tag
+			 (insert tag))
+			(t
+			 (let ((standard-output (current-buffer)))
+			   (princ (widget-get widget :value)))))))
 	       ((eq escape ?d)
-		(when doc
-		  (setq doc-begin (point))
-		  (insert doc)
-		  (while (eq (preceding-char) ?\n)
-		    (delete-backward-char 1))
-		  (insert "\n")
-		  (setq doc-end (point))))
+		(let ((doc (widget-get widget :doc)))
+		  (when doc
+		    (setq doc-begin (point))
+		    (insert doc)
+		    (while (eq (preceding-char) ?\n)
+		      (delete-backward-char 1))
+		    (insert "\n")
+		    (setq doc-end (point)))))
 	       ((eq escape ?v)
 		(if (and button-begin (not button-end))
 		    (widget-apply widget :value-create)
@@ -1386,17 +1441,29 @@
 ;; Cache already created GUI objects.
 (defvar widget-push-button-cache nil)
 
+(defcustom widget-push-button-prefix "["
+  "String used as prefix for buttons."
+  :type 'string
+  :group 'widget-button)
+
+(defcustom widget-push-button-suffix "]"
+  "String used as suffix for buttons."
+  :type 'string
+  :group 'widget-button)
+
 (define-widget 'push-button 'item
   "A pushable button."
+  :button-prefix ""
+  :button-suffix ""
   :value-create 'widget-push-button-value-create
-  :text-format "[%s]"
   :format "%[%v%]")
 
 (defun widget-push-button-value-create (widget)
   ;; Insert text representing the `on' and `off' states.
   (let* ((tag (or (widget-get widget :tag)
 		  (widget-get widget :value)))
-	 (text (format (widget-get widget :text-format) tag))
+	 (text (concat widget-push-button-prefix
+		       tag widget-push-button-suffix))
 	 (gui (cdr (assoc tag widget-push-button-cache))))
     (if (and (fboundp 'make-gui-button)
 	     (fboundp 'make-glyph)
@@ -1408,10 +1475,16 @@
 	  (unless gui
 	    (setq gui (make-gui-button tag 'widget-gui-action widget))
 	    (push (cons tag gui) widget-push-button-cache))
-	  (widget-glyph-insert-glyph widget text
-				     (make-glyph (nth 0 (aref gui 1)))
-				     (make-glyph (nth 1 (aref gui 1)))
-				     (make-glyph (nth 2 (aref gui 1)))))
+	  (widget-glyph-insert-glyph widget
+				     (make-glyph
+				      (list (nth 0 (aref gui 1))
+					    (vector 'string ':data text)))
+				     (make-glyph
+				      (list (nth 1 (aref gui 1))
+					    (vector 'string ':data text)))
+				     (make-glyph
+				      (list (nth 2 (aref gui 1))
+					    (vector 'string ':data text)))))
       (insert text))))
 
 (defun widget-gui-action (widget)
@@ -1420,10 +1493,22 @@
 
 ;;; The `link' Widget.
 
+(defcustom widget-link-prefix "["
+  "String used as prefix for links."
+  :type 'string
+  :group 'widget-button)
+
+(defcustom widget-link-suffix "]"
+  "String used as suffix for links."
+  :type 'string
+  :group 'widget-button)
+
 (define-widget 'link 'item
   "An embedded link."
+  :button-prefix 'widget-link-prefix
+  :button-suffix 'widget-link-suffix
   :help-echo "Follow the link."
-  :format "%[_%t_%]")
+  :format "%[%t%]")
 
 ;;; The `info-link' Widget.
 
@@ -1627,7 +1712,7 @@
 (defcustom widget-choice-toggle nil
   "If non-nil, a binary choice will just toggle between the values.
 Otherwise, the user will explicitly have to choose between the values
-when he activate the menu."
+when he invoked the menu."
   :type 'boolean
   :group 'widgets)
 
@@ -1756,6 +1841,8 @@
 
 (define-widget 'checkbox 'toggle
   "A checkbox toggle."
+  :button-suffix ""
+  :button-prefix ""
   :format "%[%v%]"
   :on "[X]"
   :on-glyph "check1"
@@ -1940,6 +2027,8 @@
   "A radio button for use in the `radio' widget."
   :notify 'widget-radio-button-notify
   :format "%[%v%]"
+  :button-suffix ""
+  :button-prefix ""
   :on "(*)"
   :on-glyph "radio1"
   :off "( )"
@@ -2376,7 +2465,7 @@
 
 (define-widget 'widget-help 'push-button
   "The widget documentation button."
-  :format "%[[%t]%] %d"
+  :format "%[%v%] %d"
   :help-echo "Toggle display of documentation."
   :action 'widget-help-action)
 
@@ -2446,7 +2535,7 @@
 
 (define-widget 'file 'string
   "A file widget.  
-It will read a file name from the minibuffer when activated."
+It will read a file name from the minibuffer when invoked."
   :prompt-value 'widget-file-prompt-value
   :format "%{%t%}: %v"
   :tag "File"
@@ -2478,7 +2567,7 @@
 
 (define-widget 'directory 'file
   "A directory widget.  
-It will read a directory name from the minibuffer when activated."
+It will read a directory name from the minibuffer when invoked."
   :tag "Directory")
 
 (defvar widget-symbol-prompt-value-history nil
@@ -2755,11 +2844,14 @@
   :sample-face-get 'widget-color-item-button-face-get)
 
 (defun widget-color-item-button-face-get (widget)
-  ;; We create a face from the value.
-  (require 'facemenu)
-  (condition-case nil
-      (facemenu-get-face (intern (concat "fg:" (widget-value widget))))
-    (error 'default)))
+  (let ((symbol (intern (concat "fg:" (widget-value widget)))))
+    (if (string-match "XEmacs" emacs-version)
+	(prog1 symbol
+	  (or (find-face symbol)
+	      (set-face-foreground (make-face symbol) (widget-value widget))))
+      (condition-case nil
+	  (facemenu-get-face symbol)
+	(error 'default)))))
 
 (define-widget 'color 'push-button
   "Choose a color name (with sample)."