xemacs-beta: lisp/wid-edit.el comparison

comparison lisp/wid-edit.el @ 1362:cfe4bcb9bdd4

[xemacs-hg @ 2003-03-18 06:58:19 by stephent] wid-edit.el cleanup <878yvdi2rz.fsf@tleepslib.sk.tsukuba.ac.jp> buffers tab control doc improvements <87bs09i3w5.fsf_-_@tleepslib.sk.tsukuba.ac.jp>

author	stephent
date	Tue, 18 Mar 2003 06:58:24 +0000
parents	1b0339b048ce
children	2e0147538471

comparison

equal deleted inserted replaced

-:ffdb1a771055
+:cfe4bcb9bdd4
 ;;; Code:
 (require 'widget)
-(autoload 'finder-commentary "finder" nil t)
+;; XEmacs: autoload of `finder-commentary' is redundant.
 ;;; Customization.
 (defgroup widgets nil
 "Customization support for the Widget Library."
 ;; #### comment from GNU Emacs 21.3.50, test the first spec.
 ;; TTY gets special definitions here and in the next defface, because
 ;; the gray colors defined for other displays cause black text on a black
 ;; background, at least on light-background TTYs.
-(defface widget-field-face '((((type tty))
+(defface widget-field-face '(
+			     ;; #### sjt sez:  XEmacs doesn't like this.
+			     ;; The Custom face editor widget shows a Lisp
+			     ;; form, not a face structure.  Does it produce
+			     ;; the right face on TTYs?
+			     ;; One hypothesis is that the editor doesn't
+			     ;; grok non-default display types in the value.
+			     (((type tty))
 			      (:background "yellow3")
 			      (:foreground "black"))
 			     (((class grayscale color)
 			       (background light))
 			      (:background "gray85"))
 ;; The value is actually the tail of PLIST whose car is PROP.
 (while (and plist (not (eq (car plist) prop)))
 (setq plist (cddr plist)))
 plist))
-(defun widget-princ-to-string (object)
+(defsubst widget-princ-to-string (object)
 "Return string representation of OBJECT, any Lisp object.
-No quoting characters are used; no delimiters are printed around
-the contents of strings."
+No quoting characters or string delimiters are used."
-(with-current-buffer (get-buffer-create " *widget-tmp*")
+;(with-current-buffer (get-buffer-create " *widget-tmp*")
-(erase-buffer)
+;  (erase-buffer)
-(princ object (current-buffer))
+;  (princ object (current-buffer))
-(buffer-string)))
+;  (buffer-string))
+(prin1-to-string object t)
+)
 (defun widget-prettyprint-to-string (object)
-;; Like pp-to-string, but uses `cl-prettyprint'
+"Use `cl-prettyprint' to generate a string representation of OBJECT.
-(with-current-buffer (get-buffer-create " *widget-tmp*")
-(erase-buffer)
+Cleans up `cl-prettyprint''s gratuitous surrounding newlines."
+(with-temp-buffer
 (cl-prettyprint object)
 ;; `cl-prettyprint' always surrounds the text with newlines.
-(when (eq (char-after (point-min)) ?\n)
+(buffer-string (if (eq (char-after (point-min)) ?\n)
-(delete-region (point-min) (1+ (point-min))))
+		       (1+ (point-min))
-(when (eq (char-before (point-max)) ?\n)
+		     (point-min))
-(delete-region (1- (point-max)) (point-max)))
+		   (if (eq (char-before (point-max)) ?\n)
-(buffer-string)))
+		       (1- (point-max))
+		     (point-max)))))
 (defun widget-clear-undo ()
 "Clear all undo information."
 (buffer-disable-undo)
 (buffer-enable-undo))
+(defun widget-sublist (list start &optional end)
+"Return the sublist of LIST from START to END.
+If END is omitted, it defaults to the length of LIST."
+(if (> start 0) (setq list (nthcdr start list)))
+(if end
+(if (<= end start)
+	  nil
+	(setq list (copy-sequence list))
+	(setcdr (nthcdr (- end start 1) list) nil)
+	list)
+(copy-sequence list)))
+;; Is unimplemented the right superclass?
+(define-error 'missing-package "Package not installed" 'unimplemented)
 (defcustom widget-menu-max-size 40
 "Largest number of items allowed in a popup-menu.
 Larger menus are read through the minibuffer."
 :group 'widgets
 Second argument ITEMS is a list whose members are either
 (NAME . VALUE), to indicate selectable items, or just strings to
 indicate unselectable items.
 Optional third argument EVENT is an input event.
-The user is asked to choose between each NAME from the items alist,
+The user is asked to choose a NAME from the items alist, and the VALUE of
-and the VALUE of the chosen element will be returned.  If EVENT is a
+the chosen element will be returned.  If EVENT is a mouse event, and the
-mouse event, and the number of elements in items is less than
+number of elements in items is less than `widget-menu-max-size', a popup
-`widget-menu-max-size', a popup menu will be used, otherwise the
+menu will be used, otherwise the minibuffer is used."
-minibuffer."
 (cond	((and (< (length items) widget-menu-max-size)
 	      event
 	      (console-on-window-system-p))
 	 ;; Pressed by the mouse.
 	 (let ((val (get-popup-menu-response
 ;;; Widget text specifications.
 ;;
 ;; These functions are for specifying text properties.
+;; XEmacs: This probably should be unnecessary with end-closed extents.
+;; If it doesn't work, it should be made to work.
 (defcustom widget-field-add-space t
 ;; Setting this to nil might be available, once some problems are resolved.
 "Non-nil means add extra space at the end of editable text fields.
-This is needed on all versions of Emacs.  If you don't add the space,
+Currently should be left set to `t', because without the space it becomes
-it will become impossible to edit a zero size field."
+impossible to edit a zero size field."
 :type 'boolean
 :group 'widgets)
+;; #### Why aren't these used in XEmacs?
 (defcustom widget-field-use-before-change
 (and (or (> emacs-minor-version 34)
 	   (> emacs-major-version 19))
 (not (string-match "XEmacs" emacs-version)))
 "Non-nil means use `before-change-functions' to track editable fields.
 "Specify editable button for WIDGET between FROM and TO."
 (save-excursion
 (goto-char to)
 (cond ((null (widget-get widget :size))
 	   (forward-char 1))
-	  ;; #### This comment goes outside of the save-excursion in GNU
+	  ;; XEmacs: This comment goes outside of the save-excursion in GNU.
 	  ;; Terminating space is not part of the field, but necessary in
 	  ;; order for local-map to work.  Remove next sexp if local-map works
 	  ;; at the end of the extent.
 	  (widget-field-add-space
 	   (insert-and-inherit " ")))
 (set-extent-property extent 'face face)
 (widget-handle-help-echo extent help-echo))
 (widget-specify-secret widget))
 (defun widget-specify-secret (field)
-"Replace text in FIELD with value of `:secret', if non-nil.
+"Replace text in FIELD with value of the `:secret' property, if non-nil.
+The value of the `:secret' property, if non-nil, must be a character.
 It is an error to use this function after creating the widget but before
 invoking `widget-setup'."
 (let ((secret (widget-get field :secret))
 	(size (widget-get field :size)))
 (when secret
 ;;; Creating Widgets.
 ;;;###autoload
 (defun widget-create (type &rest args)
 "Create a widget of type TYPE.
-The optional ARGS are additional keyword arguments."
+TYPE is copied, then converted to a widget using the keyword arguments ARGS."
 (let ((widget (apply 'widget-convert type args)))
 (widget-apply widget :create)
 widget))
 (defun widget-create-child-and-convert (parent type &rest args)
 "As a child of widget PARENT, create a widget of type TYPE.
-The child is converted, using the keyword arguments ARGS."
+TYPE is copied, then converted to a widget using the keyword arguments ARGS."
 (let ((widget (apply 'widget-convert type args)))
 (widget-put widget :parent parent)
 (unless (widget-get widget :indent)
 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 				    (or (widget-get widget :extra-offset) 0)
 (widget-apply widget :create)
 widget))
 (defun widget-create-child (parent type)
 "As a child of widget PARENT, create a widget of type TYPE.
-The child is not converted."
+TYPE is copied, then used as a widget as-is."
 (let ((widget (copy-sequence type)))
 (widget-put widget :parent parent)
 (unless (widget-get widget :indent)
 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 				    (or (widget-get widget :extra-offset) 0)
 				    (widget-get parent :offset))))
 (widget-apply widget :create)
 widget))
 (defun widget-create-child-value (parent type value)
-"Create widget of TYPE with value VALUE."
+"As a child of widget PARENT, create a widget with type TYPE and value VALUE.
+TYPE is copied, then used as a widget as-is."
 (let ((widget (copy-sequence type)))
 (widget-put widget :value (widget-apply widget :value-to-internal value))
 (widget-put widget :parent parent)
 (unless (widget-get widget :indent)
 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
 (widget-apply (copy-sequence widget) :copy))
 ;;;###autoload
 (defun widget-convert (type &rest args)
 "Convert TYPE to a widget without inserting it in the buffer.
-The optional ARGS are additional keyword arguments."
+The optional ARGS are additional keyword arguments.
+The widget's :args property is set from the longest tail of ARGS whose cdr
+is not a keyword, or from the longest tail of TYPE's :args property whose
+cdr is not a keyword.  Keyword arguments from ARGS are set, and the :value
+property (if any) is converted from external to internal format."
 ;; Don't touch the type.
 (let* ((widget (if (symbolp type)
 		     (list type)
 		   (copy-sequence type)))
 	 (current widget)
 	 (keys args))
-;; First set the :args keyword.
+;; First set the :args.
-(while (cdr current)		;Look in the type.
+(while (cdr current)	; Use first non-keyword element of type.
 (let ((next (car (cdr current))))
-	(if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
+	(if (keywordp next)
 	    (setq current (cdr (cdr current)))
 	  (setcdr current (list :args (cdr current)))
 	  (setq current nil))))
-(while args				;Look in the args.
+(while args			; Use first non-keyword element in ARGS.
 (let ((next (nth 0 args)))
-	(if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
+	(if (keywordp next)
 	    (setq args (nthcdr 2 args))
 	  (widget-put widget :args args)
 	  (setq args nil))))
 ;; Then convert the widget.
 (setq type widget)
 (error "Not in an editable field"))))
 ;;; Setting up the buffer.
-(defvar widget-field-new nil)
+(defvar widget-field-new nil
-;; List of all newly created editable fields in the buffer.
+"List of all newly created editable fields in the buffer.")
 (make-variable-buffer-local 'widget-field-new)
-(defvar widget-field-list nil)
+(defvar widget-field-list nil
-;; List of all editable fields in the buffer.
+"List of all editable fields in the buffer.")
 (make-variable-buffer-local 'widget-field-list)
 ;; Is this a misnomer?
 (defun widget-at (pos)
 "The button or field at POS."
 (widget-put widget :args (mapcar 'widget-copy (widget-get widget :args)))
 widget)
 ;; Made defsubst to speed up face editor creation.
 (defsubst widget-types-convert-widget (widget)
-"Convert :args as widget types in WIDGET."
+"Convert each member of :args in WIDGET from a widget type to a widget."
 (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
 widget)
 (defun widget-value-convert-widget (widget)
-"Initialize :value from :args in WIDGET."
+"Initialize :value from `(car :args)' in WIDGET, and reset :args."
 (let ((args (widget-get widget :args)))
 (when args
 (widget-put widget :value (car args))
 ;; Don't convert :value here, as this is done in `widget-convert'.
 ;; (widget-put widget :value (widget-apply widget
 	 value-pos)
 (insert (widget-get widget :format))
 (goto-char from)
 ;; Parse escapes in format.
 ;; Coding this in C would speed up things *a lot*.
+;; sjt sez:
+;; There are other things to try:
+;; 1. Use skip-chars-forward.
+;; 2. Use a LIMIT (or narrow buffer?) in the search/skip expression.
+;; 3. Search/skip backward to allow LIMIT to be constant.
+;; 4. Use a char-table to dispatch to code, instead of a cond.
 (while (re-search-forward "%\\(.\\)" nil t)
 (let ((escape (aref (match-string 1) 0)))
 	 (replace-match "" t t)
 	 (cond ((eq escape ?%)
 		(insert ?%))
 (let ((parent (widget-get widget :parent)))
 	(if parent
 	    (widget-apply parent :button-face-get)
 	  widget-button-face))))
+;; Shouldn't this be like `widget-default-button-face-get', and recurse, and
+;; have a fallback?
 (defun widget-default-sample-face-get (widget)
 ;; Use :sample-face.
 (widget-get widget :sample-face))
 (defun widget-default-delete (widget)
 	(doc-extent (widget-get widget :doc-extent))
 	before-change-functions
 	after-change-functions
 	(inhibit-read-only t))
 (widget-apply widget :value-delete)
+;; #### In current code, these are never reinserted, but recreated.
+;; So they should either be destroyed, or we should think about how to
+;; reuse them.
 (when inactive-extent
 (detach-extent inactive-extent))
 (when button-extent
 (detach-extent button-extent))
 (when sample-extent
 (or (widget-get widget :menu-tag)
 (widget-get widget :tag)
 (widget-princ-to-string (widget-get widget :value))))
 (defun widget-default-active (widget)
-"Return t iff this widget active (user modifiable)."
+"Return non-nil iff WIDGET is user-modifiable."
 (and (not (widget-get widget :inactive))
 (let ((parent (widget-get widget :parent)))
 	 (or (null parent)
 	     (widget-apply parent :active)))))
 (defun widget-default-notify (widget child &optional event)
 "Pass notification to parent."
 (widget-default-action widget event))
 (defun widget-default-prompt-value (widget prompt value unbound)
-"Read an arbitrary value.  Stolen from `set-variable'."
+"Read an arbitrary value."
+;; #### XEmacs: What does this mean?
+;; Stolen from `set-variable'.
 ;; (let ((initial (if unbound
 ;; nil
 ;; It would be nice if we could do a `(cons val 1)' here.
 ;; (prin1-to-string (custom-quote value))))))
+;; XEmacs: make this use default VALUE.  Need to check callers.
 (eval-minibuffer prompt))
 ;;; The `item' Widget.
 (define-widget 'item 'default
 	 (<= (length value) (length values))
 	 (let ((head (widget-sublist values 0 (length value))))
 	   (and (equal head value)
 		(cons head (widget-sublist values (length value))))))))
-(defun widget-sublist (list start &optional end)
-"Return the sublist of LIST from START to END.
-If END is omitted, it defaults to the length of LIST."
-(if (> start 0) (setq list (nthcdr start list)))
-(if end
-(unless (<= end start)
-	(setq list (copy-sequence list))
-	(setcdr (nthcdr (- end start 1) list) nil)
-	list)
-(copy-sequence list)))
 (defun widget-item-action (widget &optional event)
 ;; Just notify itself.
 (widget-apply widget :notify widget event))
 ;;; The `push-button' Widget.
+;; XEmacs: this seems to refer to button images.  How about native widgets?
 (defcustom widget-push-button-gui widget-glyph-enable
 "If non nil, use GUI push buttons when available."
 :group 'widgets
 :type 'boolean)
 "String used as suffix for buttons."
 :type 'string
 :group 'widget-button)
 (define-widget 'push-button 'item
-"A pushable button."
+"A button which invokes an action.
+Creators should usually specify `:action' and `:help-echo' members."
 :button-prefix ""
 :button-suffix ""
 :value-create 'widget-push-button-value-create
 :format "%[%v%]")
 "String used as suffix for links."
 :type 'string
 :group 'widget-button)
 (define-widget 'link 'item
-"An embedded link."
+"An embedded link.
+This is an abstract widget.  Subclasses should usually specify `:action'
+and `:help-echo' members."
 :button-prefix 'widget-link-prefix
 :button-suffix 'widget-link-suffix
 :help-echo "Follow the link."
 :format "%[%t%]")
 (defun widget-url-link-action (widget &optional event)
 "Open the url specified by WIDGET."
 (if-fboundp 'browse-url
 (browse-url (widget-value widget))
-;; #### Should subclass a 'missing-package error.
+(error 'missing-package "Cannot browse URLs in this Emacs" 'browse-url)))
-(error 'unimplemented
-	   "No `browse-url' package; cannot follow URLs in this XEmacs")))
 ;;; The `function-link' Widget.
 (define-widget 'function-link 'link
 "A link to an Emacs function."
 				(cons (widget-apply widget
 						    :value-to-internal value)
 				      0))
 			      (widget-get widget :prompt-history))))
-(defvar widget-edit-functions nil)
+;; #### Should be named `widget-action-hooks'.
+(defvar widget-edit-functions nil
+"Functions run on certain actions.
+Not a regular hook; each function should take a widget as an argument.
+The standard widget functions `widget-field-action', `widget-choice-action',
+and `widget-toggle-action' use `run-hook-with-args' to run these functions.")
 (defun widget-field-action (widget &optional event)
 ;; Edit the value in the minibuffer.
 (let* ((invalid (widget-apply widget :validate))
 	 (prompt (concat (widget-apply widget :menu-tag-get) ": "))
 	(widget-apply sibling :deactivate)))))
 ;;; The `checklist' Widget.
 (define-widget 'checklist 'default
-"A multiple choice widget."
+"A set widget, selecting zero or more of many.
+The parent of several `checkbox' widgets, one for each option."
 :convert-widget 'widget-types-convert-widget
 :format "%v"
 :offset 4
 :entry-format "%b %v"
 :menu-tag "checklist"
 found))
 ;;; The `option' Widget
 (define-widget 'option 'checklist
-"An widget with an optional item."
+"A widget presenting optional items for inline inclusion in a parent widget."
 :inline t)
 ;;; The `choice-item' Widget.
 (define-widget 'choice-item 'item
 (widget-apply (widget-get widget :parent) :action widget event))
 ;;; The `radio-button-choice' Widget.
 (define-widget 'radio-button-choice 'default
-"Select one of multiple options."
+"A set widget, selecting exactly one of many options.
+The parent of several `radio-button' widgets, one for each option."
 :convert-widget 'widget-types-convert-widget
 :offset 4
 :format "%v"
 :entry-format "%b %v"
 :menu-tag "radio"
 (widget-value-set widget (widget-value widget)))
 ;;; The Sexp Widgets.
+(define-widget 'sexp 'editable-field
+"An arbitrary Lisp expression."
+:tag "Lisp expression"
+:format "%{%t%}: %v"
+:value nil
+:validate 'widget-sexp-validate
+:match (lambda (widget value) t)
+:value-to-internal 'widget-sexp-value-to-internal
+:value-to-external (lambda (widget value) (read value))
+:prompt-history 'widget-sexp-prompt-value-history
+:prompt-value 'widget-sexp-prompt-value)
+(defun widget-sexp-value-to-internal (widget value)
+;; Use cl-prettyprint for printer representation.
+(let ((pp (if (symbolp value)
+		(prin1-to-string value)
+	      (widget-prettyprint-to-string value))))
+(if (> (length pp) 40)
+	(concat "\n" pp)
+pp)))
+(defun widget-sexp-validate (widget)
+;; Valid if we can read the string and there is no junk left after it.
+(save-excursion
+(let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
+(erase-buffer)
+(insert (widget-apply widget :value-get))
+(goto-char (point-min))
+(condition-case data
+	  (let ((value (read buffer)))
+	    (if (eobp)
+		(if (widget-apply widget :match value)
+		    nil
+		  (widget-put widget :error (widget-get widget :type-error))
+		  widget)
+	      (widget-put widget
+			  :error (format "Junk at end of expression: %s"
+					 (buffer-substring (point)
+							   (point-max))))
+	      widget))
+	(error (widget-put widget :error (error-message-string data))
+	       widget)))))
+(defvar widget-sexp-prompt-value-history nil
+"History of input to `widget-sexp-prompt-value'.")
+(defun widget-sexp-prompt-value (widget prompt value unbound)
+;; Read an arbitrary sexp.
+(let ((found (read-string prompt
+			    (if unbound nil (cons (prin1-to-string value) 0))
+			    (widget-get widget :prompt-history))))
+(save-excursion
+(let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
+	(erase-buffer)
+	(insert found)
+	(goto-char (point-min))
+	(let ((answer (read buffer)))
+	  (unless (eobp)
+	    (signal 'error
+		    (list "Junk at end of expression"
+			  (buffer-substring (point) (point-max)))))
+	  answer)))))
+;; Various constant sexps.
 (define-widget 'const 'item
 "An immutable sexp."
 :prompt-value 'widget-const-prompt-value
 :format "%t\n%d")
 (defvar widget-symbol-prompt-value-history nil
 "History of input to `widget-symbol-prompt-value'.")
 (define-widget 'symbol 'editable-field
 "A Lisp symbol."
-:value nil
+:value t
 :tag "Symbol"
 :format "%{%t%}: %v"
 :match (lambda (widget value) (symbolp value))
 :complete-function 'lisp-complete-symbol
 :prompt-internal 'widget-symbol-prompt-internal
 			  (buffer-substring (point) (point-max)))))
 	  answer)))))
 (define-widget 'restricted-sexp 'sexp
 "A Lisp expression restricted to values that match.
-To use this type, you must define :match or :match-alternatives."
+Either the `:match' or the `:match-alternatives' property must be defined."
 :type-error "The specified value is not valid"
 :match 'widget-restricted-sexp-match
 :value-to-internal (lambda (widget value)
 		       (if (widget-apply widget :match value)
 			   (prin1-to-string value)
 "A character."
 :tag "Character"
 :value ?\0
 :size 1
 :format "%{%t%}: %v"
+;; #### This is incorrect for Mule.
 :valid-regexp "\\`[\0-\377]\\'"
 :error "This field should contain a single character"
 :value-to-internal (lambda (widget value)
 		       (if (stringp value)
 			   value
 			 value))
 :match (lambda (widget value)
 	   (characterp value)))
 (define-widget 'list 'group
-"A Lisp list."
+"A Lisp list of fixed length with fixed type for each element."
 :tag "List"
 :format "%{%t%}:\n%v")
 (define-widget 'vector 'group
-"A Lisp vector."
+"A Lisp vector of fixed length with fixed type for each element."
 :tag "Vector"
 :format "%{%t%}:\n%v"
 :match 'widget-vector-match
 :value-to-internal (lambda (widget value) (append value nil))
 :value-to-external (lambda (widget value) (vconcat value)))
 (if current
 	(widget-prompt-value current prompt nil t)
 value)))
 (define-widget 'radio 'radio-button-choice
-"A union of several sexp types."
+"A set widget, selecting exactly one from many.
+The parent of several `radio-button' widgets, one for each option."
 :tag "Choice"
 :format "%{%t%}:\n%v"
 :prompt-value 'widget-choice-prompt-value)
 (define-widget 'repeat 'editable-list

Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 1362:cfe4bcb9bdd4