comparison lisp/wid-edit.el @ 18067:0e2aa3b58e16

Synched with version 1.9901.

18066:eecd891e2b63

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

;;; Compatibility.

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

  :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/"))

		(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))
  (widget-put widget :glyph-up glyph)
  (when down (widget-put widget :glyph-down down))
  (when inactive (widget-put widget :glyph-inactive inactive))
  (let ((help-echo (widget-get widget :help-echo)))
    (when help-echo
      (let ((extent (extent-at (1- (point)) nil 'end-glyph))
	    (help-property (if (featurep 'balloon-help)
			       '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))

	     (when (eq (aref doc-text  0) ?*)
	       (setq doc-text (substring doc-text 1)))
	     ;; Get rid of trailing newlines.
	     (when (string-match "\n+\\'" doc-text)
	       (setq doc-text (substring doc-text 0 (match-beginning 0))))
	     (setq buttons
		   (cons (if (string-match "\n." doc-text)
			     ;; Allow multiline doc to be hiden.
			     (widget-create-child-and-convert
			      widget 'widget-help 
			      :doc (progn
				     (string-match "\\`.*" doc-text)
				     (match-string 0 doc-text))
			      :widget-doc doc-text
			      "?")
			   ;; A single line is just inserted.
			   (widget-create-child-and-convert
			    widget 'item :format "%d" :doc doc-text nil))
			 buttons))))
	  (t 
	   (error "Unknown escape `%c'" escape)))
    (widget-put widget :buttons buttons)))

(defun widget-default-button-face-get (widget)

	     (device-on-window-system-p)
	     (string-match "XEmacs" emacs-version))
	(progn 
	  (unless gui
	    (setq gui (make-gui-button tag 'widget-gui-action widget))
	    (setq widget-push-button-cache
		  (cons (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

	    answer (widget-match-inline arg value)
	    value (cdr answer))
      (and (eq (preceding-char) ?\n)
	   (widget-get widget :indent)
	   (insert-char ?  (widget-get widget :indent)))
      (setq children
	    (cons (cond ((null answer)
			 (widget-create-child widget arg))
			((widget-get arg :inline)
			 (widget-create-child-value widget arg  (car answer)))
			(t
			 (widget-create-child-value widget arg  (car (car answer)))))
		  children)))
    (widget-put widget :children (nreverse children))))

(defun widget-group-match (widget values)
  ;; Match if the components match.
  (and (listp values)

	      args nil)))
    (if answer
	(cons found vals)
      nil)))

;;; 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."
  (let ((old (widget-get widget :doc))
	(new (widget-get widget :widget-doc)))
    (widget-put widget :doc new)
    (widget-put widget :widget-doc old))
  (widget-value-set widget (widget-value widget)))

;;; The Sexp Widgets.

(define-widget 'const 'item

18067:0e2aa3b58e16

;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: extensions
;; Version: 1.9901
;; 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")

  :type '(repeat (cons :format "%v"
		       (symbol :tag "Image Format" unknown)
		       (repeat :tag "Suffixes"
			       (string :format "%v")))))

(defun widget-glyph-find (image tag)
  "Create a glyph corresponding to IMAGE with string TAG as fallback.
IMAGE should either already be a glyph, or be a file name sans
extension (xpm, xbm, gif, jpg, or png) located in
`widget-glyph-directory'." 
  (cond ((not (and image 
		   (string-match "XEmacs" emacs-version)
		   widget-glyph-enable
		   (fboundp 'make-glyph)
		   (fboundp 'locate-file)
		   image))
	 ;; We don't want or can't use glyphs.
	 nil)
	((and (fboundp 'glyphp)
	      (glyphp image))
	 ;; Already a glyph.  Use it.
	 image)
	((stringp image)
	 ;; A string.  Look it up in relevant directories.
	 (let* ((dirlist (list (or widget-glyph-directory
				   (concat data-directory
					   "custom/"))

		(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
	   (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.)
	 (make-glyph (list image
			   (vector 'string ':data tag))))
	(t
	 ;; Oh well.
	 nil)))

(defun widget-glyph-insert (widget tag image &optional down inactive)
  "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'.

Optional arguments DOWN and INACTIVE is used instead of IMAGE when the
glyph is pressed or inactive, respectively. 

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."
  (let ((glyph (widget-glyph-find image tag)))
    (if glyph 
	(widget-glyph-insert-glyph widget 
				   glyph
				   (widget-glyph-find down tag)
				   (widget-glyph-find inactive tag))
      (insert tag))))

(defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
  "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."
  (set-glyph-property glyph 'widget widget)
  (when down
    (set-glyph-property down 'widget widget))
  (when inactive
    (set-glyph-property inactive 'widget widget))
  (insert "*")
  (let ((ext (make-extent (point) (1- (point))))
	(help-echo (widget-get widget :help-echo)))
    (set-extent-property ext 'invisible t)
    (set-extent-end-glyph ext glyph)
    (when help-echo
      (set-extent-property ext 'balloon-help help-echo)
      (set-extent-property ext 'help-echo help-echo)))
  (widget-put widget :glyph-up glyph)
  (when down (widget-put widget :glyph-down down))
  (when inactive (widget-put widget :glyph-inactive inactive)))

;;; 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 'widget-button)

(defcustom widget-button-suffix ""
  "String used as suffix for buttons."
  :type 'string
  :group 'widget-button)

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

	     (when (eq (aref doc-text  0) ?*)
	       (setq doc-text (substring doc-text 1)))
	     ;; Get rid of trailing newlines.
	     (when (string-match "\n+\\'" doc-text)
	       (setq doc-text (substring doc-text 0 (match-beginning 0))))
	     (push (widget-create-child-and-convert
		    widget 'documentation-string
		    doc-text)
		   buttons)))
	  (t 
	   (error "Unknown escape `%c'" escape)))
    (widget-put widget :buttons buttons)))

(defun widget-default-button-face-get (widget)

	     (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

	    answer (widget-match-inline arg value)
	    value (cdr answer))
      (and (eq (preceding-char) ?\n)
	   (widget-get widget :indent)
	   (insert-char ?  (widget-get widget :indent)))
      (push (cond ((null answer)
		   (widget-create-child widget arg))
		  ((widget-get arg :inline)
		   (widget-create-child-value widget arg  (car answer)))
		  (t
		   (widget-create-child-value widget arg  (car (car answer)))))
	    children))
    (widget-put widget :children (nreverse children))))

(defun widget-group-match (widget values)
  ;; Match if the components match.
  (and (listp values)

	      args nil)))
    (if answer
	(cons found vals)
      nil)))

;;; The `visibility' Widget.

(define-widget 'visibility 'item
  "An indicator and manipulator for hidden items."
  :format "%[%v%]"
  :button-prefix ""
  :button-suffix ""
  :on "hide"
  :off "more"
  :value-create 'widget-visibility-value-create
  :action 'widget-toggle-action
  :match (lambda (widget value) t))

(defun widget-visibility-value-create (widget)
  ;; Insert text representing the `on' and `off' states.
  (let ((on (widget-get widget :on))
	(off (widget-get widget :off)))
    (if on
	(setq on (concat widget-push-button-prefix
			 on
			 widget-push-button-suffix))
      (setq on ""))
    (if off
	(setq off (concat widget-push-button-prefix
			 off
			 widget-push-button-suffix))
      (setq off ""))
    (if (widget-value widget)
	(widget-glyph-insert widget on "down" "down-pushed")
      (widget-glyph-insert widget off "right" "right-pushed")
      (insert "..."))))

;;; The `documentation-string' Widget.

(define-widget 'documentation-string 'item
  "A documentation string."
  :format "%v"
  :action 'widget-documentation-string-action
  :value-delete 'widget-children-value-delete
  :value-create 'widget-documentation-string-value-create)

(defun widget-documentation-string-value-create (widget)
  ;; Insert documentation string.
  (let ((doc (widget-value widget))
	(shown (widget-get (widget-get widget :parent) :documentation-shown)))
    (if (string-match "\n" doc)
	(let ((before (substring doc 0 (match-beginning 0)))
	      (after (substring doc (match-beginning 0)))
	      buttons)
	  (insert before " ")
	  (push (widget-create-child-and-convert
		 widget 'visibility
		 :off nil
		 :action 'widget-parent-action
		 shown)
		buttons)
	  (when shown
	    (insert after))
	  (widget-put widget :buttons buttons))
      (insert doc)))
  (insert "\n"))

(defun widget-documentation-string-action (widget &rest ignore)
  ;; Toggle documentation.
  (let ((parent (widget-get widget :parent)))
    (widget-put parent :documentation-shown 
		(not (widget-get parent :documentation-shown))))
  ;; Redraw.
  (widget-value-set widget (widget-value widget)))

;;; The Sexp Widgets.

(define-widget 'const 'item