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

Synched with version 1.9900.

18032:fd3f0a7e79b9

;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: extensions
;; Version: 1.97
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;; See `widget.el'.

;;; Code:

(require 'widget)

(eval-when-compile (require 'cl))

;;; Compatibility.

(eval-and-compile
  (autoload 'pp-to-string "pp")

(defface widget-field-face '((((class grayscale color)
			       (background light))
			      (:background "gray85"))
			     (((class grayscale color)
			       (background dark))
			      (:background "dark gray"))
			     (t 
			      (:italic t)))
  "Face used for editable fields."
  :group 'widgets)

;;; Glyphs.

(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."
  :group 'widgets
  :type 'directory)

(defcustom widget-glyph-enable t
  "If non nil, use glyphs in images when available."
  :group 'widgets
  :type 'boolean)

(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'.

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."
  (cond ((not (and (string-match "XEmacs" emacs-version)
		   widget-glyph-enable
		   (fboundp 'make-glyph)
		   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))
	(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))))))

(defun widget-glyph-insert-glyph (widget tag 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) 
		       (list 'invisible t
			     'end-glyph glyph))

			       'balloon-help
			     'help-echo)))
	(set-extent-property extent help-property (if (stringp help-echo)
						      help-echo
						    'widget-mouse-help))))))

;;; Creating Widgets.

;;;###autoload
(defun widget-create (type &rest args)

  (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
  (define-key widget-text-keymap "\C-e" 'widget-end-of-line)
  (set-keymap-parent widget-text-keymap global-map))

(defun widget-field-activate (pos &optional event)
  "Activate the ediable field at point."
  (interactive "@d")
  (let ((field (get-text-property pos 'field)))
    (if field
	(widget-apply-action field event)
      (call-interactively

     (:bold t :underline t)))
  "Face used for pressed buttons."
  :group 'widgets)

(defun widget-button-click (event)
  "Activate button below mouse pointer."
  (interactive "@e")
  (cond ((and (fboundp 'event-glyph)
	      (event-glyph event))
	 (widget-glyph-click event))
	((widget-event-point event)

		  (lookup-key widget-global-map [ mouse-2]))))))
	(t
	 (message "You clicked somewhere weird."))))

(defun widget-button1-click (event)
  "Activate glyph below mouse pointer."
  (interactive "@e")
  (if (and (fboundp 'event-glyph)
	   (event-glyph event))
      (widget-glyph-click event)
    (call-interactively (lookup-key widget-global-map (this-command-keys)))))

	       (message "This glyph is inactive."))
	      (t
	       (widget-apply-action widget event)))))))

(defun widget-button-press (pos &optional event)
  "Activate button at POS."
  (interactive "@d")
  (let ((button (get-text-property pos 'button)))
    (if button
	(widget-apply-action button event)
      (let ((command (lookup-key widget-global-map (this-command-keys))))

(define-widget 'default nil
  "Basic widget other widgets are derived from."
  :value-to-internal (lambda (widget value) value)
  :value-to-external (lambda (widget value) value)
  :create 'widget-default-create
  :indent nil
  :offset 0
  :format-handler 'widget-default-format-handler
  :button-face-get 'widget-default-button-face-get 

(defun widget-default-create (widget)
  "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
	 value-pos)
     (insert (widget-get widget :format))

       (let ((escape (aref (match-string 1) 0)))
	 (replace-match "" t t)
	 (cond ((eq escape ?%)
		(insert "%"))
	       ((eq escape ?\[)
		(setq button-begin (point)))
	       ((eq escape ?\])
		(setq button-end (point)))
	       ((eq escape ?\{)
		(setq sample-begin (point)))
	       ((eq escape ?\})
		(setq sample-end (point)))
	       ((eq escape ?n)
		(when (widget-get widget :indent)
		  (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))))))
	       ((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))))
	       ((eq escape ?v)
		(if (and button-begin (not button-end))
		    (widget-apply widget :value-create)
		  (setq value-pos (point))))
	       (t 

  :type 'boolean)

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

(define-widget 'push-button 'item
  "A pushable button."
  :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))
	 (gui (cdr (assoc tag widget-push-button-cache))))
    (if (and (fboundp 'make-gui-button)
	     (fboundp 'make-glyph)
	     widget-push-button-gui
	     (fboundp 'device-on-window-system-p)

	     (string-match "XEmacs" emacs-version))
	(progn 
	  (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)))))
      (insert text))))

(defun widget-gui-action (widget)
  "Apply :action for WIDGET."
  (widget-apply-action widget (this-command-keys)))

;;; The `link' Widget.

(define-widget 'link 'item
  "An embedded link."
  :help-echo "Follow the link."
  :format "%[_%t_%]")

;;; The `info-link' Widget.

(define-widget 'info-link 'link
  "A link to an info file."

  (widget-apply (car (widget-get widget :children)) :value-inline))

(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."
  :type 'boolean
  :group 'widgets)

(defun widget-choice-mouse-down-action (widget &optional event)
  ;; Return non-nil if we need a menu.

;;; The `checkbox' Widget.

(define-widget 'checkbox 'toggle
  "A checkbox toggle."
  :format "%[%v%]"
  :on "[X]"
  :on-glyph "check1"
  :off "[ ]"
  :off-glyph "check0"

(define-widget 'radio-button 'toggle
  "A radio button for use in the `radio' widget."
  :notify 'widget-radio-button-notify
  :format "%[%v%]"
  :on "(*)"
  :on-glyph "radio1"
  :off "( )"
  :off-glyph "radio0")

;;; The `widget-help' Widget.

(define-widget 'widget-help 'push-button
  "The widget documentation button."
  :format "%[[%t]%] %d"
  :help-echo "Toggle display of documentation."
  :action 'widget-help-action)

(defun widget-help-action (widget &optional event)
  "Toggle documentation for WIDGET."

      (error (widget-put widget :error (error-message-string data))
	     widget))))

(define-widget 'file 'string
  "A file widget.  
It will read a file name from the minibuffer when activated."
  :prompt-value 'widget-file-prompt-value
  :format "%{%t%}: %v"
  :tag "File"
  :action 'widget-file-action)

    (widget-apply widget :notify widget event)
    (widget-setup)))

(define-widget 'directory 'file
  "A directory widget.  
It will read a directory name from the minibuffer when activated."
  :tag "Directory")

(defvar widget-symbol-prompt-value-history nil
  "History of input to `widget-symbol-prompt-value'.")

  "A color name (with sample)."
  :format "%v (%{sample%})\n"
  :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)))

(define-widget 'color 'push-button
  "Choose a color name (with sample)."
  :format "%[%t%]: %v"
  :tag "Color"

18033:bccd356a3b7c

;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: extensions
;; Version: 1.9900
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;; See `widget.el'.

;;; Code:

(require 'widget)
(require 'cl)

;;; Compatibility.

(eval-and-compile
  (autoload 'pp-to-string "pp")

(defface widget-field-face '((((class grayscale color)
			       (background light))
			      (:background "gray85"))
			     (((class grayscale color)
			       (background dark))
			      (:background "dim gray"))
			     (t 
			      (:italic t)))
  "Face used for editable fields."
  :group 'widgets)

;;; Glyphs.

(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."
  :group 'widgets
  :type 'directory)

(defcustom widget-glyph-enable t
  "If non nil, use glyphs in images when available."
  :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, 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 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 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
	 ;; Oh well.
	 (insert tag))))

(defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
  "In WIDGET, with alternative text TAG, insert GLYPH."
  (set-glyph-property glyph 'widget widget)
  (when down
    (set-glyph-property down 'widget widget))
  (when inactive
    (set-glyph-property inactive 'widget widget))
  (insert "*")
  (add-text-properties (1- (point)) (point) 
		       (list 'invisible t
			     'end-glyph glyph))

			       'balloon-help
			     'help-echo)))
	(set-extent-property extent help-property (if (stringp help-echo)
						      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
(defun widget-create (type &rest args)

  (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
  (define-key widget-text-keymap "\C-e" 'widget-end-of-line)
  (set-keymap-parent widget-text-keymap global-map))

(defun widget-field-activate (pos &optional event)
  "Invoke the ediable field at point."
  (interactive "@d")
  (let ((field (get-text-property pos 'field)))
    (if field
	(widget-apply-action field event)
      (call-interactively

     (:bold t :underline t)))
  "Face used for pressed buttons."
  :group 'widgets)

(defun widget-button-click (event)
  "Invoke button below mouse pointer."
  (interactive "@e")
  (cond ((and (fboundp 'event-glyph)
	      (event-glyph event))
	 (widget-glyph-click event))
	((widget-event-point event)

		  (lookup-key widget-global-map [ mouse-2]))))))
	(t
	 (message "You clicked somewhere weird."))))

(defun widget-button1-click (event)
  "Invoke glyph below mouse pointer."
  (interactive "@e")
  (if (and (fboundp 'event-glyph)
	   (event-glyph event))
      (widget-glyph-click event)
    (call-interactively (lookup-key widget-global-map (this-command-keys)))))

	       (message "This glyph is inactive."))
	      (t
	       (widget-apply-action widget event)))))))

(defun widget-button-press (pos &optional event)
  "Invoke button at POS."
  (interactive "@d")
  (let ((button (get-text-property pos 'button)))
    (if button
	(widget-apply-action button event)
      (let ((command (lookup-key widget-global-map (this-command-keys))))

(define-widget 'default nil
  "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
  :format-handler 'widget-default-format-handler
  :button-face-get 'widget-default-button-face-get 

(defun widget-default-create (widget)
  "Create WIDGET at point in the current buffer."
  (widget-specify-insert
   (let ((from (point))
	 button-begin button-end
	 sample-begin sample-end
	 doc-begin doc-end
	 value-pos)
     (insert (widget-get widget :format))

       (let ((escape (aref (match-string 1) 0)))
	 (replace-match "" t t)
	 (cond ((eq escape ?%)
		(insert "%"))
	       ((eq escape ?\[)
		(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)))
	       ((eq escape ?\})
		(setq sample-end (point)))
	       ((eq escape ?n)
		(when (widget-get widget :indent)
		  (insert "\n")
		  (insert-char ?  (widget-get widget :indent))))
	       ((eq escape ?t)
		(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)
		(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)
		  (setq value-pos (point))))
	       (t 

  :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
  :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
  :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 (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)
	     widget-push-button-gui
	     (fboundp 'device-on-window-system-p)

	     (string-match "XEmacs" emacs-version))
	(progn 
	  (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
				     (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)
  "Apply :action for WIDGET."
  (widget-apply-action widget (this-command-keys)))

;;; 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%]")

;;; The `info-link' Widget.

(define-widget 'info-link 'link
  "A link to an info file."

  (widget-apply (car (widget-get widget :children)) :value-inline))

(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 invoked the menu."
  :type 'boolean
  :group 'widgets)

(defun widget-choice-mouse-down-action (widget &optional event)
  ;; Return non-nil if we need a menu.

;;; The `checkbox' Widget.

(define-widget 'checkbox 'toggle
  "A checkbox toggle."
  :button-suffix ""
  :button-prefix ""
  :format "%[%v%]"
  :on "[X]"
  :on-glyph "check1"
  :off "[ ]"
  :off-glyph "check0"

(define-widget 'radio-button 'toggle
  "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 "( )"
  :off-glyph "radio0")

;;; The `widget-help' Widget.

(define-widget 'widget-help 'push-button
  "The widget documentation button."
  :format "%[%v%] %d"
  :help-echo "Toggle display of documentation."
  :action 'widget-help-action)

(defun widget-help-action (widget &optional event)
  "Toggle documentation for WIDGET."

      (error (widget-put widget :error (error-message-string data))
	     widget))))

(define-widget 'file 'string
  "A file widget.  
It will read a file name from the minibuffer when invoked."
  :prompt-value 'widget-file-prompt-value
  :format "%{%t%}: %v"
  :tag "File"
  :action 'widget-file-action)

    (widget-apply widget :notify widget event)
    (widget-setup)))

(define-widget 'directory 'file
  "A directory widget.  
It will read a directory name from the minibuffer when invoked."
  :tag "Directory")

(defvar widget-symbol-prompt-value-history nil
  "History of input to `widget-symbol-prompt-value'.")

  "A color name (with sample)."
  :format "%v (%{sample%})\n"
  :sample-face-get 'widget-color-item-button-face-get)

(defun widget-color-item-button-face-get (widget)
  (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)."
  :format "%[%t%]: %v"
  :tag "Color"