diff options
| -rw-r--r-- | etc/widget.texi | 1422 | ||||
| -rw-r--r-- | lisp/cus-edit.el | 1993 | ||||
| -rw-r--r-- | lisp/cus-face.el | 590 | ||||
| -rw-r--r-- | lisp/custom.el | 332 | ||||
| -rw-r--r-- | lisp/wid-browse.el | 232 | ||||
| -rw-r--r-- | lisp/wid-edit.el | 2542 | ||||
| -rw-r--r-- | lisp/widget.el | 76 |
7 files changed, 7187 insertions, 0 deletions
diff --git a/etc/widget.texi b/etc/widget.texi new file mode 100644 index 00000000000..c4761748105 --- /dev/null +++ b/etc/widget.texi @@ -0,0 +1,1422 @@ +\input texinfo.tex + +@c $Id: widget.texi,v 1.99 1997/04/06 20:34:01 abraham Exp $ + +@c %**start of header +@setfilename widget +@settitle The Emacs Widget Library +@iftex +@afourpaper +@headings double +@end iftex +@c %**end of header + +@node Top, Introduction, (dir), (dir) +@comment node-name, next, previous, up +@top The Emacs Widget Library + +Version: 1.71 + +@menu +* Introduction:: +* User Interface:: +* Programming Example:: +* Setting Up the Buffer:: +* Basic Types:: +* Sexp Types:: +* Widget Properties:: +* Defining New Widgets:: +* Widget Wishlist.:: +@end menu + +@node Introduction, User Interface, Top, Top +@comment node-name, next, previous, up +@section Introduction + +Most graphical user interface toolkits, such as Motif and XView, provide +a number of standard user interface controls (sometimes known as +`widgets' or `gadgets'). Emacs doesn't really support anything like +this, except for an incredible powerful text ``widget''. On the other +hand, Emacs does provide the necessary primitives to implement many +other widgets within a text buffer. The @code{widget} package +simplifies this task. + +The basic widgets are: + +@table @code +@item link +Areas of text with an associated action. Intended for hypertext links +embedded in text. +@item push-button +Like link, but intended for stand-alone buttons. +@item editable-field +An editable text field. It can be either variable or fixed length. +@item menu-choice +Allows the user to choose one of multiple options from a menu, each +option is itself a widget. Only the selected option will be visible in +the buffer. +@item radio-button-choice +Allows the user to choose one of multiple options by pushing radio +buttons. The options are implemented as widgets. All options will be +visible in the buffer. +@item item +A simple constant widget intended to be used in the @code{menu-choice} and +@code{radio-button-choice} widgets. +@item choice-item +An button item only intended for use in choices. When pushed, the user +will be asked to select another option from the choice widget. +@item toggle +A simple @samp{on}/@samp{off} switch. +@item checkbox +A checkbox (@samp{[ ]}/@samp{[X]}). +@item editable-list +Create an editable list. The user can insert or delete items in the +list. Each list item is itself a widget. +@end table + +Now of what possible use can support for widgets be in a text editor? +I'm glad you asked. The answer is that widgets are useful for +implementing forms. A @dfn{form} in emacs is a buffer where the user is +supposed to fill out a number of fields, each of which has a specific +meaning. The user is not supposed to change or delete any of the text +between the fields. Examples of forms in Emacs are the @file{forms} +package (of course), the customize buffers, the mail and news compose +modes, and the @sc{html} form support in the @file{w3} browser. + +The advantages for a programmer of using the @code{widget} package to +implement forms are: + +@enumerate +@item +More complex field than just editable text are supported. +@item +You can give the user immediate feedback if he enters invalid data in a +text field, and sometimes prevent entering invalid data. +@item +You can have fixed sized fields, thus allowing multiple field to be +lined up in columns. +@item +It is simple to query or set the value of a field. +@item +Editing happens in buffer, not in the mini-buffer. +@item +Packages using the library get a uniform look, making them easier for +the user to learn. +@item +As support for embedded graphics improve, the widget library will +extended to support it. This means that your code using the widget +library will also use the new graphic features by automatic. +@end enumerate + +In order to minimize the code that is loaded by users who does not +create any widgets, the code has been split in two files: + +@table @file +@item widget.el +This will declare the user variables, define the function +@code{widget-define}, and autoload the function @code{widget-create}. +@item wid-edit.el +Everything else is here, there is no reason to load it explicitly, as +it will be autoloaded when needed. +@end table + +@node User Interface, Programming Example, Introduction, Top +@comment node-name, next, previous, up +@section User Interface + +A form consist of read only text for documentation and some fields, +where each the fields contain two parts, as tag and a value. The tags +are used to identify the fields, so the documentation can refer to the +foo field, meaning the field tagged with @samp{Foo}. Here is an example +form: + +@example +Here is some documentation. + +Name: @i{My Name} @strong{Choose}: This option +Address: @i{Some Place +In some City +Some country.} + +See also @b{_other work_} for more information. + +Numbers: count to three below +@b{[INS]} @b{[DEL]} @i{One} +@b{[INS]} @b{[DEL]} @i{Eh, two?} +@b{[INS]} @b{[DEL]} @i{Five!} +@b{[INS]} + +Select multiple: + +@b{[X]} This +@b{[ ]} That +@b{[X]} Thus + +Select one: + +@b{(*)} One +@b{( )} Another One. +@b{( )} A Final One. + +@b{[Apply Form]} @b{[Reset Form]} +@end example + +The top level widgets in is example are tagged @samp{Name}, +@samp{Choose}, @samp{Address}, @samp{_other work_}, @samp{Numbers}, +@samp{Select multiple}, @samp{Select one}, @samp{[Apply Form]}, and +@samp{[Reset Form]}. There are basically two thing the user can do within +a form, namely editing the editable text fields and activating the +buttons. + +@subsection Editable Text Fields + +In the example, the value for the @samp{Name} is most likely displayed +in an editable text field, and so are values for each of the members of +the @samp{Numbers} list. All the normal Emacs editing operations are +available for editing these fields. The only restriction is that each +change you make must be contained within a single editable text field. +For example, capitalizing all text from the middle of one field to the +middle of another field is prohibited. + +Editing text fields are created by the @code{editable-field} widget. + +The editing text fields are highlighted with the +@code{widget-field-face} face, making them easy to find. + +@deffn Face widget-field-face +Face used for other editing fields. +@end deffn + +@subsection Buttons + +Some portions of the buffer have an associated @dfn{action}, which can +be @dfn{activated} by a standard key or mouse command. These portions +are called @dfn{buttons}. The default commands for activating a button +are: + +@table @kbd +@item @key{RET} +@deffn Command widget-button-press @var{pos} &optional @var{event} +Activate the button at @var{pos}, defaulting to point. +If point is not located on a button, activate the binding in +@code{widget-global-map} (by default the global map). +@end deffn + +@item mouse-2 +@deffn Command widget-button-click @var{event} +Activate the button at the location of the mouse pointer. If the mouse +pointer is located in an editable text field, activate the binding in +@code{widget-global-map} (by default the global map). +@end deffn +@end table + +There are several different kind of buttons, all of which are present in +the example: + +@table @emph +@item The Option Field Tags. +When you activate one of these buttons, you will be asked to choose +between a number of different options. This is how you edit an option +field. Option fields are created by the @code{menu-choice} widget. In +the example, @samp{@b{Choose}} is an option field tag. +@item The @samp{@b{[INS]}} and @samp{@b{[DEL]}} buttons. +Activating these will insert or delete elements from a editable list. +The list is created by the @code{editable-list} widget. +@item Embedded Buttons. +The @samp{@b{_other work_}} is an example of an embedded +button. Embedded buttons are not associated with a fields, but can serve +any purpose, such as implementing hypertext references. They are +usually created by the @code{link} widget. +@item The @samp{@b{[ ]}} and @samp{@b{[X]}} buttons. +Activating one of these will convert it to the other. This is useful +for implementing multiple-choice fields. You can create it wit +@item The @samp{@b{( )}} and @samp{@b{(*)}} buttons. +Only one radio button in a @code{radio-button-choice} widget can be selected at any +time. When you push one of the unselected radio buttons, it will be +selected and the previous selected radio button will become unselected. +@item The @samp{@b{[Apply Form]}} @samp{@b{[Reset Form]}} buttons. +These are explicit buttons made with the @code{push-button} widget. The main +difference from the @code{link} widget is that the buttons are will be +displayed as GUI buttons when possible. +enough. +@end table + +To make them easier to locate, buttons are emphasized in the buffer. + +@deffn Face widget-button-face +Face used for buttons. +@end deffn + +@defopt widget-mouse-face +Face used for buttons when the mouse pointer is above it. +@end defopt + +@subsection Navigation + +You can use all the normal Emacs commands to move around in a form +buffer, plus you will have these additional commands: + +@table @kbd +@item @key{TAB} +@deffn Command widget-forward &optional count +Move point @var{count} buttons or editing fields forward. +@end deffn +@item @key{M-TAB} +@deffn Command widget-backward &optional count +Move point @var{count} buttons or editing fields backward. +@end deffn +@end table + +@node Programming Example, Setting Up the Buffer, User Interface, Top +@comment node-name, next, previous, up +@section Programming Example + +Here is the code to implement the user interface example (see @ref{User +Interface}). + +@lisp +(require 'widget) + +(eval-when-compile + (require 'wid-edit)) + +(defvar widget-example-repeat) + +(defun widget-example () + "Create the widgets from the Widget manual." + (interactive) + (switch-to-buffer "*Widget Example*") + (kill-all-local-variables) + (make-local-variable 'widget-example-repeat) + (let ((inhibit-read-only t)) + (erase-buffer)) + (widget-insert "Here is some documentation.\n\nName: ") + (widget-create 'editable-field + :size 13 + "My Name") + (widget-create 'menu-choice + :tag "Choose" + :value "This" + :help-echo "Choose me, please!" + :notify (lambda (widget &rest ignore) + (message "%s is a good choice!" + (widget-value widget))) + '(item :tag "This option" :value "This") + '(choice-item "That option") + '(editable-field :menu-tag "No option" "Thus option")) + (widget-insert "Address: ") + (widget-create 'editable-field + "Some Place\nIn some City\nSome country.") + (widget-insert "\nSee also ") + (widget-create 'link + :notify (lambda (&rest ignore) + (widget-value-set widget-example-repeat + '("En" "To" "Tre")) + (widget-setup)) + "other work") + (widget-insert " for more information.\n\nNumbers: count to three below\n") + (setq widget-example-repeat + (widget-create 'editable-list + :entry-format "%i %d %v" + :notify (lambda (widget &rest ignore) + (let ((old (widget-get widget + ':example-length)) + (new (length (widget-value widget)))) + (unless (eq old new) + (widget-put widget ':example-length new) + (message "You can count to %d." new)))) + :value '("One" "Eh, two?" "Five!") + '(editable-field :value "three"))) + (widget-insert "\n\nSelect multiple:\n\n") + (widget-create 'checkbox t) + (widget-insert " This\n") + (widget-create 'checkbox nil) + (widget-insert " That\n") + (widget-create 'checkbox + :notify (lambda (&rest ignore) (message "Tickle")) + t) + (widget-insert " Thus\n\nSelect one:\n\n") + (widget-create 'radio-button-choice + :value "One" + :notify (lambda (widget &rest ignore) + (message "You selected %s" + (widget-value widget))) + '(item "One") '(item "Anthor One.") '(item "A Final One.")) + (widget-insert "\n") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (if (= (length (widget-value widget-example-repeat)) + 3) + (message "Congratulation!") + (error "Three was the count!"))) + "Apply Form") + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (widget-example)) + "Reset Form") + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup)) +@end lisp + +@node Setting Up the Buffer, Basic Types, Programming Example, Top +@comment node-name, next, previous, up +@section Setting Up the Buffer + +Widgets are created with @code{widget-create}, which returns a +@dfn{widget} object. This object can be queried and manipulated by +other widget functions, until it is deleted with @code{widget-delete}. +After the widgets have been created, @code{widget-setup} must be called +to enable them. + +@defun widget-create type [ keyword argument ]@dots{} +Create and return a widget of type @var{type}. +The syntax for the @var{type} argument is described in @ref{Basic Types}. + +The keyword arguments can be used to overwrite the keyword arguments +that are part of @var{type}. +@end defun + +@defun widget-delete widget +Delete @var{widget} and remove it from the buffer. +@end defun + +@defun widget-setup +Setup a buffer to support widgets. + +This should be called after creating all the widgets and before allowing +the user to edit them. +@refill +@end defun + +If you want to insert text outside the widgets in the form, the +recommended way to do that is with @code{widget-insert}. + +@defun widget-insert +Insert the arguments, either strings or characters, at point. +The inserted text will be read only. +@end defun + +There is a standard widget keymap which you might find useful. + +@defvr Const widget-keymap +A keymap with the global keymap as its parent.@* +@key{TAB} and @kbd{C-@key{TAB}} are bound to @code{widget-forward} and +@code{widget-backward}, respectively. @kbd{@key{RET}} and @kbd{mouse-2} +are bound to @code{widget-button-press} and +@code{widget-button-}.@refill +@end defvr + +@defvar widget-global-map +Keymap used by @code{widget-button-press} and @code{widget-button-click} +when not on a button. By default this is @code{global-map}. +@end defvar + +@node Basic Types, Sexp Types, Setting Up the Buffer, Top +@comment node-name, next, previous, up +@section Basic Types + +The syntax of a type specification is given below: + +@example +NAME ::= (NAME [KEYWORD ARGUMENT]... ARGS) + | NAME +@end example + +Where, @var{name} is a widget name, @var{keyword} is the name of a +property, @var{argument} is the value of the property, and @var{args} +are interpreted in a widget specific way. + +There following keyword arguments that apply to all widgets: + +@table @code +@item :value +The initial value for widgets of this type. + +@item :format +This string will be inserted in the buffer when you create a widget. +The following @samp{%} escapes are available: + +@table @samp +@item %[ +@itemx %] +The text inside will be marked as a button. + +@item %@{ +@itemx %@} +The text inside will be displayed with the face specified by +@code{:sample-face}. + +@item %v +This will be replaces with the buffer representation of the widgets +value. What this is depends on the widget type. + +@item %d +Insert the string specified by @code{:doc} here. + +@item %h +Like @samp{%d}, with the following modifications: If the documentation +string is more than one line, it will add a button which will toggle +between showing only the first line, and showing the full text. +Furthermore, if there is no @code{:doc} property in the widget, it will +instead examine the @code{:documentation-property} property. If it is a +lambda expression, it will be called with the widget's value as an +argument, and the result will be used as the documentation text. + +@item %t +Insert the string specified by @code{:tag} here, or the @code{princ} +representation of the value if there is no tag. + +@item %% +Insert a literal @samp{%}. +@end table + +@item :button-face +Face used to highlight text inside %[ %] in the format. + +@item :doc +The string inserted by the @samp{%d} escape in the format +string. + +@item :tag +The string inserted by the @samp{%t} escape in the format +string. + +@item :tag-glyph +Name of image to use instead of the string specified by `:tag' on +Emacsen that supports it. + +@item :help-echo +Message displayed whenever you move to the widget with either +@code{widget-forward} or @code{widget-backward}. + +@item :indent +An integer indicating the absolute number of spaces to indent children +of this widget. + +@item :offset +An integer indicating how many extra spaces to add to the widget's +grandchildren compared to this widget. + +@item :extra-offset +An integer indicating how many extra spaces to add to the widget's +children compared to this widget. + +@item :notify +A function called each time the widget or a nested widget is changed. +The function is called with two or three arguments. The first argument +is the widget itself, the second argument is the widget that was +changed, and the third argument is the event leading to the change, if +any. + +@item :menu-tag +Tag used in the menu when the widget is used as an option in a +@code{menu-choice} widget. + +@item :menu-tag-get +Function used for finding the tag when the widget is used as an option +in a @code{menu-choice} widget. By default, the tag used will be either the +@code{:menu-tag} or @code{:tag} property if present, or the @code{princ} +representation of the @code{:value} property if not. + +@item :match +Should be a function called with two arguments, the widget and a value, +and returning non-nil if the widget can represent the specified value. + +@item :validate +A function which takes a widget as an argument, and return nil if the +widgets current value is valid for the widget. Otherwise, it should +return the widget containing the invalid data, and set that widgets +@code{:error} property to a string explaining the error. + +@item :tab-order +Specify the order in which widgets are traversed with +@code{widget-forward} or @code{widget-backward}. This is only partially +implemented. + +@enumerate a +@item +Widgets with tabbing order @code{-1} are ignored. + +@item +(Unimplemented) When on a widget with tabbing order @var{n}, go to the +next widget in the buffer with tabbing order @var{n+1} or @code{nil}, +whichever comes first. + +@item +When on a widget with no tabbing order specified, go to the next widget +in the buffer with a positive tabbing order, or @code{nil} +@end enumerate + +@item :parent +The parent of a nested widget (e.g. a @code{menu-choice} item or an +element of a @code{editable-list} widget). + +@item :sibling-args +This keyword is only used for members of a @code{radio-button-choice} or +@code{checklist}. The value should be a list of extra keyword +arguments, which will be used when creating the @code{radio-button} or +@code{checkbox} associated with this item. + +@end table + +@deffn {User Option} widget-glyph-directory +Directory where glyphs are found. +Widget will look here for a file with the same name as specified for the +image, with either a @samp{.xpm} (if supported) or @samp{.xbm} extension. +@end deffn + +@deffn{User Option} widget-glyph-enable +If non-nil, allow glyphs to appear on displayes where they are supported. +@end deffn + + +@menu +* link:: +* url-link:: +* info-link:: +* push-button:: +* editable-field:: +* text:: +* menu-choice:: +* radio-button-choice:: +* item:: +* choice-item:: +* toggle:: +* checkbox:: +* checklist:: +* editable-list:: +@end menu + +@node link, url-link, Basic Types, Basic Types +@comment node-name, next, previous, up +@subsection The @code{link} Widget + +Syntax: + +@example +TYPE ::= (link [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer. + +@node url-link, info-link, link, Basic Types +@comment node-name, next, previous, up +@subsection The @code{url-link} Widget + +Syntax: + +@example +TYPE ::= (url-link [KEYWORD ARGUMENT]... URL) +@end example + +When this link is activated, the @sc{www} browser specified by +@code{browse-url-browser-function} will be called with @var{url}. + +@node info-link, push-button, url-link, Basic Types +@comment node-name, next, previous, up +@subsection The @code{info-link} Widget + +Syntax: + +@example +TYPE ::= (info-link [KEYWORD ARGUMENT]... ADDRESS) +@end example + +When this link is activated, the build-in info browser is started on +@var{address}. + +@node push-button, editable-field, info-link, Basic Types +@comment node-name, next, previous, up +@subsection The @code{push-button} Widget + +Syntax: + +@example +TYPE ::= (push-button [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer. + +@node editable-field, text, push-button, Basic Types +@comment node-name, next, previous, up +@subsection The @code{editable-field} Widget + +Syntax: + +@example +TYPE ::= (editable-field [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in +field. This widget will match all string values. + +The following extra properties are recognized. + +@table @code +@item :size +The width of the editable field.@* +By default the field will reach to the end of the line. + +@item :value-face +Face used for highlighting the editable field. Default is +@code{widget-field-face}. + +@item :secret +Character used to display the value. You can set this to e.g. @code{?*} +if the field contains a password or other secret information. By +default, the value is not secret. + +@item :valid-regexp +By default the @code{:validate} function will match the content of the +field with the value of this attribute. The default value is @code{""} +which matches everything. + +@item :keymap +Keymap used in the editable field. The default value is +@code{widget-field-keymap}, which allows you to use all the normal +editing commands, even if the buffers major mode supress some of them. +Pressing return activates the function specified by @code{:activate}. + +@item :hide-front-space +@itemx :hide-rear-space +In order to keep track of the editable field, emacs places an invisible +space character in front of the field, and for fixed sized fields also +in the rear end of the field. For fields that extent to the end of the +line, the terminating linefeed serves that purpose instead. + +Emacs will try to make the spaces intangible when it is safe to do so. +Intangible means that the cursor motion commands will skip over the +character as if it didn't exist. This is safe to do when the text +preceding or following the widget cannot possible change during the +lifetime of the @code{editable-field} widget. The preferred way to tell +Emacs this, is to add text to the @code{:format} property around the +value. For example @code{:format "Tag: %v "}. + +You can overwrite the internal safety check by setting the +@code{:hide-front-space} or @code{:hide-rear-space} properties to +non-nil. This is not recommended. For example, @emph{all} text that +belongs to a widget (i.e. is created from its @code{:format} string) will +change whenever the widget changes its value. + +@end table + +@node text, menu-choice, editable-field, Basic Types +@comment node-name, next, previous, up +@subsection The @code{text} Widget + +This is just like @code{editable-field}, but intended for multiline text +fields. The default @code{:keymap} is @code{widget-text-keymap}, which +does not rebind the return key. + +@node menu-choice, radio-button-choice, text, Basic Types +@comment node-name, next, previous, up +@subsection The @code{menu-choice} Widget + +Syntax: + +@example +TYPE ::= (menu-choice [KEYWORD ARGUMENT]... TYPE ... ) +@end example + +The @var{type} arguments represents each possible choice. The widgets +value of will be the value of the chosen @var{type} argument. This +widget will match any value that matches at least one of the specified +@var{type} arguments. + +@table @code +@item :void +Widget type used as a fallback when the value does not match any of the +specified @var{type} arguments. + +@item :case-fold +Set this to nil if you don't want to ignore case when prompting for a +choice through the minibuffer. + +@item :children +A list whose car is the widget representing the currently chosen type in +the buffer. + +@item :choice +The current chosen type + +@item :args +The list of types. +@end table + +@node radio-button-choice, item, menu-choice, Basic Types +@comment node-name, next, previous, up +@subsection The @code{radio-button-choice} Widget + +Syntax: + +@example +TYPE ::= (radio-button-choice [KEYWORD ARGUMENT]... TYPE ... ) +@end example + +The @var{type} arguments represents each possible choice. The widgets +value of will be the value of the chosen @var{type} argument. This +widget will match any value that matches at least one of the specified +@var{type} arguments. + +The following extra properties are recognized. + +@table @code +@item :entry-format +This string will be inserted for each entry in the list. +The following @samp{%} escapes are available: +@table @samp +@item %v +Replaced with the buffer representation of the @var{type} widget. +@item %b +Replace with the radio button. +@item %% +Insert a literal @samp{%}. +@end table + +@item button-args +A list of keywords to pass to the radio buttons. Useful for setting +e.g. the @samp{:help-echo} for each button. + +@item :buttons +The widgets representing the radio buttons. + +@item :children +The widgets representing each type. + +@item :choice +The current chosen type + +@item :args +The list of types. +@end table + +You can add extra radio button items to a @code{radio-button-choice} +widget after it has been created with the function +@code{widget-radio-add-item}. + +@defun widget-radio-add-item widget type +Add to @code{radio-button-choice} widget @var{widget} a new radio button item of type +@var{type}. +@end defun + +Please note that such items added after the @code{radio-button-choice} +widget has been created will @strong{not} be properly destructed when +you call @code{widget-delete}. + +@node item, choice-item, radio-button-choice, Basic Types +@comment node-name, next, previous, up +@subsection The @code{item} Widget + +Syntax: + +@example +ITEM ::= (item [KEYWORD ARGUMENT]... VALUE) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer. This widget will only match the specified value. + +@node choice-item, toggle, item, Basic Types +@comment node-name, next, previous, up +@subsection The @code{choice-item} Widget + +Syntax: + +@example +ITEM ::= (choice-item [KEYWORD ARGUMENT]... VALUE) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer as a button. Activating the button of a @code{choice-item} is +equivalent to activating the parent widget. This widget will only match +the specified value. + +@node toggle, checkbox, choice-item, Basic Types +@comment node-name, next, previous, up +@subsection The @code{toggle} Widget + +Syntax: + +@example +TYPE ::= (toggle [KEYWORD ARGUMENT]...) +@end example + +The widget has two possible states, `on' and `off', which corresponds to +a @code{t} or @code{nil} value. + +The following extra properties are recognized. + +@table @code +@item :on +String representing the `on' state. By default the string @samp{on}. +@item :off +String representing the `off' state. By default the string @samp{off}. +@item :on-glyph +Name of a glyph to be used instead of the `:on' text string, on emacsen +that supports it. +@item :off-glyph +Name of a glyph to be used instead of the `:off' text string, on emacsen +that supports it. +@end table + +@node checkbox, checklist, toggle, Basic Types +@comment node-name, next, previous, up +@subsection The @code{checkbox} Widget + +The widget has two possible states, `selected' and `unselected', which +corresponds to a @code{t} or @code{nil} value. + +Syntax: + +@example +TYPE ::= (checkbox [KEYWORD ARGUMENT]...) +@end example + +@node checklist, editable-list, checkbox, Basic Types +@comment node-name, next, previous, up +@subsection The @code{checklist} Widget + +Syntax: + +@example +TYPE ::= (checklist [KEYWORD ARGUMENT]... TYPE ... ) +@end example + +The @var{type} arguments represents each checklist item. The widgets +value of will be a list containing the value of each ticked @var{type} +argument. The checklist widget will match a list whose elements all +matches at least one of the specified @var{type} arguments. + +The following extra properties are recognized. + +@table @code +@item :entry-format +This string will be inserted for each entry in the list. +The following @samp{%} escapes are available: +@table @samp +@item %v +Replaced with the buffer representation of the @var{type} widget. +@item %b +Replace with the checkbox. +@item %% +Insert a literal @samp{%}. +@end table + +@item button-args +A list of keywords to pass to the checkboxes. Useful for setting +e.g. the @samp{:help-echo} for each checkbox. + +@item :buttons +The widgets representing the checkboxes. + +@item :children +The widgets representing each type. + +@item :args +The list of types. +@end table + +@node editable-list, , checklist, Basic Types +@comment node-name, next, previous, up +@subsection The @code{editable-list} Widget + +Syntax: + +@example +TYPE ::= (editable-list [KEYWORD ARGUMENT]... TYPE) +@end example + +The value is a list, where each member represent one widget of type +@var{type}. + +The following extra properties are recognized. + +@table @code +@item :entry-format +This string will be inserted for each entry in the list. +The following @samp{%} escapes are available: +@table @samp +@item %v +This will be replaced with the buffer representation of the @var{type} +widget. +@item %i +Insert the @b{[INS]} button. +@item %d +Insert the @b{[DEL]} button. +@item %% +Insert a literal @samp{%}. +@end table + +@item :insert-button-args +A list of keyword arguments to pass to the insert buttons. + +@item :delete-button-args +A list of keyword arguments to pass to the delete buttons. + +@item :append-button-args +A list of keyword arguments to pass to the trailing insert button. + + +@item :buttons +The widgets representing the insert and delete buttons. + +@item :children +The widgets representing the elements of the list. + +@item :args +List whose car is the type of the list elements. + +@end table + +@node Sexp Types, Widget Properties, Basic Types, Top +@comment +@section Sexp Types + +A number of widgets for editing s-expressions (lisp types) are also +available. These basically fall in three categories: @dfn{atoms}, +@dfn{composite types}, and @dfn{generic}. + +@menu +* generic:: +* atoms:: +* composite:: +@end menu + +@node generic, atoms, Sexp Types, Sexp Types +@comment node-name, next, previous, up +@subsection The Generic Widget. + +The @code{const} and @code{sexp} widgets can contain any lisp +expression. In the case of the @code{const} widget the user is +prohibited from editing edit it, which is mainly useful as a component +of one of the composite widgets. + +The syntax for the generic widgets is + +@example +TYPE ::= (const [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property and can be any s-expression. + +@deffn Widget const +This will display any valid s-expression in an immutable part of the +buffer. +@end deffn + +@deffn Widget sexp +This will allow you to edit any valid s-expression in an editable buffer +field. + +The @code{sexp} widget takes the same keyword arguments as the +@code{editable-field} widget. +@end deffn + +@node atoms, composite, generic, Sexp Types +@comment node-name, next, previous, up +@subsection Atomic Sexp Widgets. + +The atoms are s-expressions that does not consist of other +s-expressions. A string is an atom, while a list is a composite type. +You can edit the value of an atom with the following widgets. + +The syntax for all the atoms are + +@example +TYPE ::= (NAME [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property and must be an expression of the same type as the widget. +I.e. the string widget can only be initialized with a string. + +All the atom widgets take the same keyword arguments as the @code{editable-field} +widget. + +@deffn Widget string +Allows you to edit a string in an editable field. +@end deffn + +@deffn Widget file +Allows you to edit a file name in an editable field. You you activate +the tag button, you can edit the file name in the mini-buffer with +completion. + +Keywords: +@table @code +@item :must-match +If this is set to non-nil, only existing file names will be allowed in +the minibuffer. +@end table +@end deffn + +@deffn Widget directory +Allows you to edit a directory name in an editable field. +Similar to the @code{file} widget. +@end deffn + +@deffn Widget symbol +Allows you to edit a lisp symbol in an editable field. +@end deffn + +@deffn Widget integer +Allows you to edit an integer in an editable field. +@end deffn + +@deffn Widget number +Allows you to edit a number in an editable field. +@end deffn + +@deffn Widget boolean +Allows you to edit a boolean. In lisp this means a variable which is +either nil meaning false, or non-nil meaning true. +@end deffn + + +@node composite, , atoms, Sexp Types +@comment node-name, next, previous, up +@subsection Composite Sexp Widgets. + +The syntax for the composite are + +@example +TYPE ::= (NAME [KEYWORD ARGUMENT]... COMPONENT...) +@end example + +Where each @var{component} must be a widget type. Each component widget +will be displayed in the buffer, and be editable to the user. + +@deffn Widget cons +The value of a @code{cons} widget is a cons-cell where the car is the +value of the first component and the cdr is the value of the second +component. There must be exactly two components. +@end deffn + +@deffn Widget lisp +The value of a @code{lisp} widget is a list containing the value of +each of its component. +@end deffn + +@deffn Widget vector +The value of a @code{vector} widget is a vector containing the value of +each of its component. +@end deffn + +The above suffice for specifying fixed size lists and vectors. To get +variable length lists and vectors, you can use a @code{choice}, +@code{set} or @code{repeat} widgets together with the @code{:inline} +keywords. If any component of a composite widget has the @code{:inline} +keyword set, its value must be a list which will then be spliced into +the composite. For example, to specify a list whose first element must +be a file name, and whose remaining arguments should either by the +symbol @code{t} or two files, you can use the following widget +specification: + +@example +(list file + (choice (const t) + (list :inline t + :value ("foo" "bar") + string string))) +@end example + +The value of a widget of this type will either have the form +@samp{(file t)} or @code{(file string string)}. + +This concept of inline is probably hard to understand. It was certainly +hard to implement so instead of confuse you more by trying to explain it +here, I'll just suggest you meditate over it for a while. + +@deffn Widget choice +Allows you to edit a sexp which may have one of fixed set of types. It +is currently implemented with the @code{choice-menu} basic widget, and +has a similar syntax. +@end deffn + +@deffn Widget set +Allows you to specify a type which must be a list whose elements all +belong to given set. The elements of the list is not significant. This +is implemented on top of the @code{checklist} basic widget, and has a +similar syntax. +@end deffn + +@deffn Widget repeat +Allows you to specify a variable length list whose members are all of +the same type. Implemented on top of the `editable-list' basic widget, +and has a similar syntax. +@end deffn + +@node Widget Properties, Defining New Widgets, Sexp Types, Top +@comment node-name, next, previous, up +@section Properties + +You can examine or set the value of a widget by using the widget object +that was returned by @code{widget-create}. + +@defun widget-value widget +Return the current value contained in @var{widget}. +It is an error to call this function on an uninitialized widget. +@end defun + +@defun widget-value-set widget value +Set the value contained in @var{widget} to @var{value}. +It is an error to call this function with an invalid @var{value}. +@end defun + +@strong{Important:} You @emph{must} call @code{widget-setup} after +modifying the value of a widget before the user is allowed to edit the +widget again. It is enough to call @code{widget-setup} once if you +modify multiple widgets. This is currently only necessary if the widget +contains an editing field, but may be necessary for other widgets in the +future. + +If your application needs to associate some information with the widget +objects, for example a reference to the item being edited, it can be +done with @code{widget-put} and @code{widget-get}. The property names +must begin with a @samp{:}. + +@defun widget-put widget property value +In @var{widget} set @var{property} to @var{value}. +@var{property} should be a symbol, while @var{value} can be anything. +@end defun + +@defun widget-get widget property +In @var{widget} return the value for @var{property}. +@var{property} should be a symbol, the value is what was last set by +@code{widget-put} for @var{property}. +@end defun + +@defun widget-member widget property +Non-nil if @var{widget} has a value (even nil) for property @var{property}. +@end defun + +Occasionally it can be useful to know which kind of widget you have, +i.e. the name of the widget type you gave when the widget was created. + +@defun widget-type widget +Return the name of @var{widget}, a symbol. +@end defun + +Widgets can be in two states: active, which means they are modifiable by +the user, or inactive, which means they cannot be modified by the user. +You can query or set the state with the following code: + +@lisp +;; Examine if @var{widget} is active or not. +(if (widget-apply @var{widget} :active) + (message "Widget is active.") + (message "Widget is inactive.") + +;; Make @var{widget} inactive. +(widget-apply @var{widget} :deactivate) + +;; Make @var{widget} active. +(widget-apply @var{widget} :activate) +@end lisp + +A widget is inactive if itself, or any of its ancestors (found by +following the @code{:parent} link) have been deactivated. To make sure +a widget is really active, you must therefore activate both itself, and +all its ancestors. + +@lisp +(while widget + (widget-apply widget :activate) + (setq widget (widget-get widget :parent))) +@end lisp + +You can check if a widget has been made inactive by examining the value +of @code{:inactive} keyword. If this is non-nil, the widget itself has +been deactivated. This is different from using the @code{:active} +keyword, in that the later tell you if the widget @strong{or} any of its +ancestors have been deactivated. Do not attempt to set the +@code{:inactive} keyword directly. Use the @code{:activate} +@code{:deactivated} keywords instead. + + +@node Defining New Widgets, Widget Wishlist., Widget Properties, Top +@comment node-name, next, previous, up +@section Defining New Widgets + +You can define specialized widgets with @code{define-widget}. It allows +you to create a shorthand for more complex widgets, including specifying +component widgets and default new default values for the keyword +arguments. + +@defun widget-define name class doc &rest args +Define a new widget type named @var{name} from @code{class}. + +@var{name} and class should both be symbols, @code{class} should be one +of the existing widget types. + +The third argument @var{DOC} is a documentation string for the widget. + +After the new widget has been defined, the following two calls will +create identical widgets: + +@itemize @bullet +@item +@lisp +(widget-create @var{name}) +@end lisp + +@item +@lisp +(apply widget-create @var{class} @var{args}) +@end lisp +@end itemize + +@end defun + +Using @code{widget-define} does just store the definition of the widget +type in the @code{widget-type} property of @var{name}, which is what +@code{widget-create} uses. + +If you just want to specify defaults for keywords with no complex +conversions, you can use @code{identity} as your conversion function. + +The following additional keyword arguments are useful when defining new +widgets: +@table @code +@item :convert-widget +Function to convert a widget type before creating a widget of that +type. It takes a widget type as an argument, and returns the converted +widget type. When a widget is created, this function is called for the +widget type and all the widgets parent types, most derived first. + +@item :value-to-internal +Function to convert the value to the internal format. The function +takes two arguments, a widget and an external value, and returns the +internal value. The function is called on the present @code{:value} +when the widget is created, and on any value set later with +@code{widget-value-set}. + +@item :value-to-external +Function to convert the value to the external format. The function +takes two arguments, a widget and an internal value, and returns the +internal value. The function is called on the present @code{:value} +when the widget is created, and on any value set later with +@code{widget-value-set}. + +@item :create +Function to create a widget from scratch. The function takes one +argument, a widget type, and create a widget of that type, insert it in +the buffer, and return a widget object. + +@item :delete +Function to delete a widget. The function takes one argument, a widget, +and should remove all traces of the widget from the buffer. + +@item :value-create +Function to expand the @samp{%v} escape in the format string. It will +be called with the widget as its argument. Should +insert a representation of the widgets value in the buffer. + +@item :value-delete +Should remove the representation of the widgets value from the buffer. +It will be called with the widget as its argument. It doesn't have to +remove the text, but it should release markers and delete nested widgets +if such has been used. + +@item :format-handler +Function to handle unknown @samp{%} escapes in the format string. It +will be called with the widget and the escape character as arguments. +You can set this to allow your widget to handle non-standard escapes. + +You should end up calling @code{widget-default-format-handler} to handle +unknown escape sequences, which will handle the @samp{%h} and any future +escape sequences, as well as give an error for unknown escapes. +@end table + +If you want to define a new widget from scratch, use the @code{default} +widget as its base. + +@deffn Widget default [ keyword argument ] +Widget used as a base for other widgets. + +It provides most of the functionality that is referred to as ``by +default'' in this text. +@end deffn + +@node Widget Wishlist., , Defining New Widgets, Top +@comment node-name, next, previous, up +@section Wishlist. + +@itemize @bullet +@item +It should be possible to add or remove items from a list with @kbd{C-k} +and @kbd{C-o} (suggested by @sc{rms}). + +@item +The @samp{[INS]} and @samp{[DEL]} buttons should be replaced by a single +dash (@samp{-}). The dash should be a button that, when activated, ask +whether you want to add or delete an item (@sc{rms} wanted to git rid of +the ugly buttons, the dash is my idea). + +@item +Widgets such as @code{file} and @code{symbol} should prompt with completion. + +@item +The @code{menu-choice} tag should be prettier, something like the abbreviated +menus in Open Look. + +@item +The functions used in many widgets, like +@code{widget-item-convert-widget}, should not have names that are +specific to the first widget where I happended to use them. + +@item +Flag to make @code{widget-move} skip a specified button. + +@item +Document `helper' functions for defining new widgets. + +@item +Activate the item this is below the mouse when the button is +released, not the item this is below the mouse when the button is +pressed. Dired and grep gets this right. Give feedback if possible. + +@item +Use @samp{@@deffn Widget} to document widgets. + +@item +Document global keywords in one place. + +Document keywords particular to a specific widget in the widget +definition. + +Document the `default' widget first. + +Split, when needed, keywords into those useful for normal +customization, those primarily useful when deriving, and those who +represent runtime information. + +@item +Figure out terminology and @sc{api} for the class/type/object/super +stuff. + +Perhaps the correct model is delegation? + +@item +Document @code{widget-browse}. + +@item +Make indentation work with glyphs and propertional fonts. + +@item +Add object and class hierarchies to the browser. + +@end itemize + +@contents +@bye diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el new file mode 100644 index 00000000000..0327c7aa286 --- /dev/null +++ b/lisp/cus-edit.el @@ -0,0 +1,1993 @@ +;;; cus-edit.el --- Tools for customization Emacs. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, faces +;; Version: 1.71 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `custom.el'. + +;;; Code: + +(require 'cus-face) +(require 'wid-edit) +(require 'easymenu) + +(define-widget-keywords :custom-prefixes :custom-menu :custom-show + :custom-magic :custom-state :custom-level :custom-form + :custom-set :custom-save :custom-reset-current :custom-reset-saved + :custom-reset-factory) + +;;; Customization Groups. + +(defgroup emacs nil + "Customization of the One True Editor." + :link '(custom-manual "(emacs)Top")) + +;; Most of these groups are stolen from `finder.el', +(defgroup editing nil + "Basic text editing facilities." + :group 'emacs) + +(defgroup abbrev nil + "Abbreviation handling, typing shortcuts, macros." + :tag "Abbreviations" + :group 'editing) + +(defgroup matching nil + "Various sorts of searching and matching." + :group 'editing) + +(defgroup emulations nil + "Emulations of other editors." + :group 'editing) + +(defgroup mouse nil + "Mouse support." + :group 'editing) + +(defgroup outlines nil + "Support for hierarchical outlining." + :group 'editing) + +(defgroup external nil + "Interfacing to external utilities." + :group 'emacs) + +(defgroup bib nil + "Code related to the `bib' bibliography processor." + :tag "Bibliography" + :group 'external) + +(defgroup processes nil + "Process, subshell, compilation, and job control support." + :group 'external + :group 'development) + +(defgroup programming nil + "Support for programming in other languages." + :group 'emacs) + +(defgroup languages nil + "Specialized modes for editing programming languages." + :group 'programming) + +(defgroup lisp nil + "Lisp support, including Emacs Lisp." + :group 'languages + :group 'development) + +(defgroup c nil + "Support for the C language and related languages." + :group 'languages) + +(defgroup tools nil + "Programming tools." + :group 'programming) + +(defgroup oop nil + "Support for object-oriented programming." + :group 'programming) + +(defgroup applications nil + "Applications written in Emacs." + :group 'emacs) + +(defgroup calendar nil + "Calendar and time management support." + :group 'applications) + +(defgroup mail nil + "Modes for electronic-mail handling." + :group 'applications) + +(defgroup news nil + "Support for netnews reading and posting." + :group 'applications) + +(defgroup games nil + "Games, jokes and amusements." + :group 'applications) + +(defgroup development nil + "Support for further development of Emacs." + :group 'emacs) + +(defgroup docs nil + "Support for Emacs documentation." + :group 'development) + +(defgroup extensions nil + "Emacs Lisp language extensions." + :group 'development) + +(defgroup internal nil + "Code for Emacs internals, build process, defaults." + :group 'development) + +(defgroup maint nil + "Maintenance aids for the Emacs development group." + :tag "Maintenance" + :group 'development) + +(defgroup environment nil + "Fitting Emacs with its environment." + :group 'emacs) + +(defgroup comm nil + "Communications, networking, remote access to files." + :tag "Communication" + :group 'environment) + +(defgroup hardware nil + "Support for interfacing with exotic hardware." + :group 'environment) + +(defgroup terminals nil + "Support for terminal types." + :group 'environment) + +(defgroup unix nil + "Front-ends/assistants for, or emulators of, UNIX features." + :group 'environment) + +(defgroup vms nil + "Support code for vms." + :group 'environment) + +(defgroup i18n nil + "Internationalization and alternate character-set support." + :group 'environment + :group 'editing) + +(defgroup frames nil + "Support for Emacs frames and window systems." + :group 'environment) + +(defgroup data nil + "Support editing files of data." + :group 'emacs) + +(defgroup wp nil + "Word processing." + :group 'emacs) + +(defgroup tex nil + "Code related to the TeX formatter." + :group 'wp) + +(defgroup faces nil + "Support for multiple fonts." + :group 'emacs) + +(defgroup hypermedia nil + "Support for links between text or other media types." + :group 'emacs) + +(defgroup help nil + "Support for on-line help systems." + :group 'emacs) + +(defgroup local nil + "Code local to your site." + :group 'emacs) + +(defgroup customize '((widgets custom-group)) + "Customization of the Customization support." + :link '(custom-manual "(custom)Top") + :link '(url-link :tag "Development Page" + "http://www.dina.kvl.dk/~abraham/custom/") + :prefix "custom-" + :group 'help + :group 'faces) + +;;; Utilities. + +(defun custom-quote (sexp) + "Quote SEXP iff it is not self quoting." + (if (or (memq sexp '(t nil)) + (and (symbolp sexp) + (eq (aref (symbol-name sexp) 0) ?:)) + (and (listp sexp) + (memq (car sexp) '(lambda))) + (stringp sexp) + (numberp sexp) + (and (fboundp 'characterp) + (characterp sexp))) + sexp + (list 'quote sexp))) + +(defun custom-split-regexp-maybe (regexp) + "If REGEXP is a string, split it to a list at `\\|'. +You can get the original back with from the result with: + (mapconcat 'identity result \"\\|\") + +IF REGEXP is not a string, return it unchanged." + (if (stringp regexp) + (let ((start 0) + all) + (while (string-match "\\\\|" regexp start) + (setq all (cons (substring regexp start (match-beginning 0)) all) + start (match-end 0))) + (nreverse (cons (substring regexp start) all))) + regexp)) + +(defvar custom-prefix-list nil + "List of prefixes that should be ignored by `custom-unlispify'") + +(defcustom custom-unlispify-menu-entries t + "Display menu entries as words instead of symbols if non nil." + :group 'customize + :type 'boolean) + +(defun custom-unlispify-menu-entry (symbol &optional no-suffix) + "Convert symbol into a menu entry." + (cond ((not custom-unlispify-menu-entries) + (symbol-name symbol)) + ((get symbol 'custom-tag) + (if no-suffix + (get symbol 'custom-tag) + (concat (get symbol 'custom-tag) "..."))) + (t + (save-excursion + (set-buffer (get-buffer-create " *Custom-Work*")) + (erase-buffer) + (princ symbol (current-buffer)) + (goto-char (point-min)) + (let ((prefixes custom-prefix-list) + prefix) + (while prefixes + (setq prefix (car prefixes)) + (if (search-forward prefix (+ (point) (length prefix)) t) + (progn + (setq prefixes nil) + (delete-region (point-min) (point))) + (setq prefixes (cdr prefixes))))) + (subst-char-in-region (point-min) (point-max) ?- ?\ t) + (capitalize-region (point-min) (point-max)) + (unless no-suffix + (goto-char (point-max)) + (insert "...")) + (buffer-string))))) + +(defcustom custom-unlispify-tag-names t + "Display tag names as words instead of symbols if non nil." + :group 'customize + :type 'boolean) + +(defun custom-unlispify-tag-name (symbol) + "Convert symbol into a menu entry." + (let ((custom-unlispify-menu-entries custom-unlispify-tag-names)) + (custom-unlispify-menu-entry symbol t))) + +(defun custom-prefix-add (symbol prefixes) + ;; Addd SYMBOL to list of ignored PREFIXES. + (cons (or (get symbol 'custom-prefix) + (concat (symbol-name symbol) "-")) + prefixes)) + +;;; The Custom Mode. + +(defvar custom-options nil + "Customization widgets in the current buffer.") + +(defvar custom-mode-map nil + "Keymap for `custom-mode'.") + +(unless custom-mode-map + (setq custom-mode-map (make-sparse-keymap)) + (set-keymap-parent custom-mode-map widget-keymap) + (define-key custom-mode-map "q" 'bury-buffer)) + +(easy-menu-define custom-mode-menu + custom-mode-map + "Menu used in customization buffers." + '("Custom" + ["Set" custom-set t] + ["Save" custom-save t] + ["Reset to Current" custom-reset-current t] + ["Reset to Saved" custom-reset-saved t] + ["Reset to Factory Settings" custom-reset-factory t] + ["Info" (Info-goto-node "(custom)The Customization Buffer") t])) + +(defcustom custom-mode-hook nil + "Hook called when entering custom-mode." + :type 'hook + :group 'customize) + +(defun custom-mode () + "Major mode for editing customization buffers. + +The following commands are available: + +\\[widget-forward] Move to next button or editable field. +\\[widget-backward] Move to previous button or editable field. +\\[widget-button-click] Activate button under the mouse pointer. +\\[widget-button-press] Activate button under point. +\\[custom-set] Set all modifications. +\\[custom-save] Make all modifications default. +\\[custom-reset-current] Reset all modified options. +\\[custom-reset-saved] Reset all modified or set options. +\\[custom-reset-factory] Reset all options. + +Entry to this mode calls the value of `custom-mode-hook' +if that value is non-nil." + (kill-all-local-variables) + (setq major-mode 'custom-mode + mode-name "Custom") + (use-local-map custom-mode-map) + (easy-menu-add custom-mode-menu) + (make-local-variable 'custom-options) + (run-hooks 'custom-mode-hook)) + +;;; Custom Mode Commands. + +(defun custom-set () + "Set changes in all modified options." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-set))) + children))) + +(defun custom-save () + "Set all modified group members and save them." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-save))) + children)) + (custom-save-all)) + +(defvar custom-reset-menu + '(("Current" . custom-reset-current) + ("Saved" . custom-reset-saved) + ("Factory Settings" . custom-reset-factory)) + "Alist of actions for the `Reset' button. +The key is a string containing the name of the action, the value is a +lisp function taking the widget as an element which will be called +when the action is chosen.") + +(defun custom-reset (event) + "Select item from reset menu." + (let* ((completion-ignore-case t) + (answer (widget-choose "Reset to" + custom-reset-menu + event))) + (if answer + (funcall answer)))) + +(defun custom-reset-current () + "Reset all modified group members to their current value." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children))) + +(defun custom-reset-saved () + "Reset all modified or set group members to their saved value." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children))) + +(defun custom-reset-factory () + "Reset all modified, set, or saved group members to their factory settings." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children))) + +;;; The Customize Commands + +;;;###autoload +(defun customize (symbol) + "Customize SYMBOL, which must be a customization group." + (interactive (list (completing-read "Customize group: (default emacs) " + obarray + (lambda (symbol) + (get symbol 'custom-group)) + t))) + + (when (stringp symbol) + (if (string-equal "" symbol) + (setq symbol 'emacs) + (setq symbol (intern symbol)))) + (custom-buffer-create (list (list symbol 'custom-group)))) + +;;;###autoload +(defun customize-variable (symbol) + "Customize SYMBOL, which must be a variable." + (interactive + ;; Code stolen from `help.el'. + (let ((v (variable-at-point)) + (enable-recursive-minibuffers t) + val) + (setq val (completing-read + (if v + (format "Customize variable (default %s): " v) + "Customize variable: ") + obarray 'boundp t)) + (list (if (equal val "") + v (intern val))))) + (custom-buffer-create (list (list symbol 'custom-variable)))) + +;;;###autoload +(defun customize-face (&optional symbol) + "Customize SYMBOL, which should be a face name or nil. +If SYMBOL is nil, customize all faces." + (interactive (list (completing-read "Customize face: (default all) " + obarray 'custom-facep))) + (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) + (let ((found nil)) + (message "Looking for faces...") + (mapcar (lambda (symbol) + (setq found (cons (list symbol 'custom-face) found))) + (face-list)) + (custom-buffer-create found)) + (if (stringp symbol) + (setq symbol (intern symbol))) + (unless (symbolp symbol) + (error "Should be a symbol %S" symbol)) + (custom-buffer-create (list (list symbol 'custom-face))))) + +;;;###autoload +(defun customize-customized () + "Customize all already customized user options." + (interactive) + (let ((found nil)) + (mapatoms (lambda (symbol) + (and (get symbol 'saved-face) + (custom-facep symbol) + (setq found (cons (list symbol 'custom-face) found))) + (and (get symbol 'saved-value) + (boundp symbol) + (setq found + (cons (list symbol 'custom-variable) found))))) + (if found + (custom-buffer-create found) + (error "No customized user options")))) + +;;;###autoload +(defun customize-apropos (regexp &optional all) + "Customize all user options matching REGEXP. +If ALL (e.g., started with a prefix key), include options which are not +user-settable." + (interactive "sCustomize regexp: \nP") + (let ((found nil)) + (mapatoms (lambda (symbol) + (when (string-match regexp (symbol-name symbol)) + (when (get symbol 'custom-group) + (setq found (cons (list symbol 'custom-group) found))) + (when (custom-facep symbol) + (setq found (cons (list symbol 'custom-face) found))) + (when (and (boundp symbol) + (or (get symbol 'saved-value) + (get symbol 'factory-value) + (if all + (get symbol 'variable-documentation) + (user-variable-p symbol)))) + (setq found + (cons (list symbol 'custom-variable) found)))))) + (if found + (custom-buffer-create found) + (error "No matches")))) + +;;;###autoload +(defun custom-buffer-create (options) + "Create a buffer containing OPTIONS. +OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where +SYMBOL is a customization option, and WIDGET is a widget for editing +that option." + (message "Creating customization buffer...") + (kill-buffer (get-buffer-create "*Customization*")) + (switch-to-buffer (get-buffer-create "*Customization*")) + (custom-mode) + (widget-insert "This is a customization buffer. +Push RET or click mouse-2 on the word ") + ;; (put-text-property 1 2 'start-open nil) + (widget-create 'info-link + :tag "help" + :help-echo "Read the online help." + "(custom)The Customization Buffer") + (widget-insert " for more information.\n\n") + (setq custom-options + (if (= (length options) 1) + (mapcar (lambda (entry) + (widget-create (nth 1 entry) + :custom-state 'unknown + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry))) + options) + (let ((count 0) + (length (length options))) + (mapcar (lambda (entry) + (prog2 + (message "Creating customization items %2d%%..." + (/ (* 100.0 count) length)) + (widget-create (nth 1 entry) + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry)) + (setq count (1+ count)) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\n"))) + options)))) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\n") + (message "Creating customization magic...") + (mapcar 'custom-magic-reset custom-options) + (message "Creating customization buttons...") + (widget-create 'push-button + :tag "Set" + :help-echo "Set all modifications for this session." + :action (lambda (widget &optional event) + (custom-set))) + (widget-insert " ") + (widget-create 'push-button + :tag "Save" + :help-echo "\ +Make the modifications default for future sessions." + :action (lambda (widget &optional event) + (custom-save))) + (widget-insert " ") + (widget-create 'push-button + :tag "Reset" + :help-echo "Undo all modifications." + :action (lambda (widget &optional event) + (custom-reset event))) + (widget-insert " ") + (widget-create 'push-button + :tag "Done" + :help-echo "Bury the buffer." + :action (lambda (widget &optional event) + (bury-buffer) + ;; Steal button release event. + (if (and (fboundp 'button-press-event-p) + (fboundp 'next-command-event)) + ;; XEmacs + (and event + (button-press-event-p event) + (next-command-event)) + ;; Emacs + (when (memq 'down (event-modifiers event)) + (read-event))))) + (widget-insert "\n") + (message "Creating customization setup...") + (widget-setup) + (goto-char (point-min)) + (message "Creating customization buffer...done")) + +;;; Modification of Basic Widgets. +;; +;; We add extra properties to the basic widgets needed here. This is +;; fine, as long as we are careful to stay within out own namespace. +;; +;; We want simple widgets to be displayed by default, but complex +;; widgets to be hidden. + +(widget-put (get 'item 'widget-type) :custom-show t) +(widget-put (get 'editable-field 'widget-type) + :custom-show (lambda (widget value) + (let ((pp (pp-to-string value))) + (cond ((string-match "\n" pp) + nil) + ((> (length pp) 40) + nil) + (t t))))) +(widget-put (get 'menu-choice 'widget-type) :custom-show t) + +;;; The `custom-manual' Widget. + +(define-widget 'custom-manual 'info-link + "Link to the manual entry for this customization option." + :help-echo "Read the manual entry for this option." + :tag "Manual") + +;;; The `custom-magic' Widget. + +(defface custom-invalid-face '((((class color)) + (:foreground "yellow" :background "red")) + (t + (:bold t :italic t :underline t))) + "Face used when the customize item is invalid.") + +(defface custom-rogue-face '((((class color)) + (:foreground "pink" :background "black")) + (t + (:underline t))) + "Face used when the customize item is not defined for customization.") + +(defface custom-modified-face '((((class color)) + (:foreground "white" :background "blue")) + (t + (:italic t :bold))) + "Face used when the customize item has been modified.") + +(defface custom-set-face '((((class color)) + (:foreground "blue" :background "white")) + (t + (:italic t))) + "Face used when the customize item has been set.") + +(defface custom-changed-face '((((class color)) + (:foreground "white" :background "blue")) + (t + (:italic t))) + "Face used when the customize item has been changed.") + +(defface custom-saved-face '((t (:underline t))) + "Face used when the customize item has been saved.") + +(defcustom custom-magic-alist '((nil "#" underline "\ +uninitialized, you should not see this.") + (unknown "?" italic "\ +unknown, you should not see this.") + (hidden "-" default "\ +hidden, press the state button to show.") + (invalid "x" custom-invalid-face "\ +the value displayed for this item is invalid and cannot be set.") + (modified "*" custom-modified-face "\ +you have edited the item, and can now set it.") + (set "+" custom-set-face "\ +you have set this item, but not saved it.") + (changed ":" custom-changed-face "\ +this item has been changed outside customize.") + (saved "!" custom-saved-face "\ +this item has been saved.") + (rogue "@" custom-rogue-face "\ +this item is not prepared for customization.") + (factory " " nil "\ +this item is unchanged from its factory setting.")) + "Alist of customize option states. +Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where + +STATE is one of the following symbols: + +`nil' + For internal use, should never occur. +`unknown' + For internal use, should never occur. +`hidden' + This item is not being displayed. +`invalid' + This item is modified, but has an invalid form. +`modified' + This item is modified, and has a valid form. +`set' + This item has been set but not saved. +`changed' + The current value of this item has been changed temporarily. +`saved' + This item is marked for saving. +`rogue' + This item has no customization information. +`factory' + This item is unchanged from the factory default. + +MAGIC is a string used to present that state. + +FACE is a face used to present the state. + +DESCRIPTION is a string describing the state. + +The list should be sorted most significant first." + :type '(list (checklist :inline t + (group (const nil) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const unknown) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const hidden) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const invalid) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const modified) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const set) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const changed) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const saved) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const rogue) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const factory) + (string :tag "Magic") + face + (string :tag "Description"))) + (editable-list :inline t + (group symbol + (string :tag "Magic") + face + (string :tag "Description")))) + :group 'customize) + +(defcustom custom-magic-show 'long + "Show long description of the state of each customization option." + :type '(choice (const :tag "no" nil) + (const short) + (const long)) + :group 'customize) + +(defcustom custom-magic-show-button t + "Show a magic button indicating the state of each customization option." + :type 'boolean + :group 'customize) + +(define-widget 'custom-magic 'default + "Show and manipulate state for a customization option." + :format "%v" + :action 'widget-choice-item-action + :value-get 'ignore + :value-create 'custom-magic-value-create + :value-delete 'widget-children-value-delete) + +(defun custom-magic-value-create (widget) + ;; Create compact status report for WIDGET. + (let* ((parent (widget-get widget :parent)) + (state (widget-get parent :custom-state)) + (entry (assq state custom-magic-alist)) + (magic (nth 1 entry)) + (face (nth 2 entry)) + (text (nth 3 entry)) + (lisp (eq (widget-get parent :custom-form) 'lisp)) + children) + (when custom-magic-show + (push (widget-create-child-and-convert widget 'choice-item + :help-echo "\ +Change the state of this item." + :format "%[%t%]" + :tag "State") + children) + (insert ": ") + (if (eq custom-magic-show 'long) + (insert text) + (insert (symbol-name state))) + (when lisp + (insert " (lisp)")) + (insert "\n")) + (when custom-magic-show-button + (when custom-magic-show + (let ((indent (widget-get parent :indent))) + (when indent + (insert-char ? indent)))) + (push (widget-create-child-and-convert widget 'choice-item + :button-face face + :help-echo "Change the state." + :format "%[%t%]" + :tag (if lisp + (concat "(" magic ")") + (concat "[" magic "]"))) + children) + (insert " ")) + (widget-put widget :children children))) + +(defun custom-magic-reset (widget) + "Redraw the :custom-magic property of WIDGET." + (let ((magic (widget-get widget :custom-magic))) + (widget-value-set magic (widget-value magic)))) + +;;; The `custom-level' Widget. + +(define-widget 'custom-level 'item + "The custom level buttons." + :format "%[%t%]" + :help-echo "Expand or collapse this item." + :action 'custom-level-action) + +(defun custom-level-action (widget &optional event) + "Toggle visibility for parent to WIDGET." + (let* ((parent (widget-get widget :parent)) + (state (widget-get parent :custom-state))) + (cond ((memq state '(invalid modified)) + (error "There are unset changes")) + ((eq state 'hidden) + (widget-put parent :custom-state 'unknown)) + (t + (widget-put parent :custom-state 'hidden))) + (custom-redraw parent))) + +;;; The `custom' Widget. + +(define-widget 'custom 'default + "Customize a user option." + :convert-widget 'custom-convert-widget + :format "%l%[%t%]: %v%m%h%a" + :format-handler 'custom-format-handler + :notify 'custom-notify + :custom-level 1 + :custom-state 'hidden + :documentation-property 'widget-subclass-responsibility + :value-create 'widget-subclass-responsibility + :value-delete 'widget-children-value-delete + :value-get 'widget-item-value-get + :validate 'widget-editable-list-validate + :match (lambda (widget value) (symbolp value))) + +(defun custom-convert-widget (widget) + ;; Initialize :value and :tag from :args in WIDGET. + (let ((args (widget-get widget :args))) + (when args + (widget-put widget :value (widget-apply widget + :value-to-internal (car args))) + (widget-put widget :tag (custom-unlispify-tag-name (car args))) + (widget-put widget :args nil))) + widget) + +(defun custom-format-handler (widget escape) + ;; We recognize extra escape sequences. + (let* ((buttons (widget-get widget :buttons)) + (state (widget-get widget :custom-state)) + (level (widget-get widget :custom-level))) + (cond ((eq escape ?l) + (when level + (push (widget-create-child-and-convert + widget 'custom-level (make-string level ?*)) + buttons) + (widget-insert " ") + (widget-put widget :buttons buttons))) + ((eq escape ?L) + (when (eq state 'hidden) + (widget-insert " ..."))) + ((eq escape ?m) + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons) + (widget-put widget :buttons buttons))) + ((eq escape ?a) + (let* ((symbol (widget-get widget :value)) + (links (get symbol 'custom-links)) + (many (> (length links) 2))) + (when links + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (insert "See also ") + (while links + (push (widget-create-child-and-convert widget (car links)) + buttons) + (setq links (cdr links)) + (cond ((null links) + (insert ".\n")) + ((null (cdr links)) + (if many + (insert ", and ") + (insert " and "))) + (t + (insert ", ")))) + (widget-put widget :buttons buttons)))) + (t + (widget-default-format-handler widget escape))))) + +(defun custom-notify (widget &rest args) + "Keep track of changes." + (unless (memq (widget-get widget :custom-state) '(nil unknown hidden)) + (widget-put widget :custom-state 'modified)) + (let ((buffer-undo-list t)) + (custom-magic-reset widget)) + (apply 'widget-default-notify widget args)) + +(defun custom-redraw (widget) + "Redraw WIDGET with current settings." + (let ((pos (point)) + (from (marker-position (widget-get widget :from))) + (to (marker-position (widget-get widget :to)))) + (save-excursion + (widget-value-set widget (widget-value widget)) + (custom-redraw-magic widget)) + (when (and (>= pos from) (<= pos to)) + (goto-char pos)))) + +(defun custom-redraw-magic (widget) + "Redraw WIDGET state with current settings." + (while widget + (let ((magic (widget-get widget :custom-magic))) + (unless magic + (debug)) + (widget-value-set magic (widget-value magic)) + (when (setq widget (widget-get widget :group)) + (custom-group-state-update widget)))) + (widget-setup)) + +(defun custom-show (widget value) + "Non-nil if WIDGET should be shown with VALUE by default." + (let ((show (widget-get widget :custom-show))) + (cond ((null show) + nil) + ((eq t show) + t) + (t + (funcall show widget value))))) + +(defun custom-load-symbol (symbol) + "Load all dependencies for SYMBOL." + (let ((loads (get symbol 'custom-loads)) + load) + (while loads + (setq load (car loads) + loads (cdr loads)) + (cond ((symbolp load) + (condition-case nil + (require load) + (error nil))) + ((assoc load load-history)) + (t + (condition-case nil + (load-library load) + (error nil))))))) + +(defun custom-load-widget (widget) + "Load all dependencies for WIDGET." + (custom-load-symbol (widget-value widget))) + +;;; The `custom-variable' Widget. + +(defface custom-variable-sample-face '((t (:underline t))) + "Face used for unpushable variable tags." + :group 'customize) + +(defface custom-variable-button-face '((t (:underline t :bold t))) + "Face used for pushable variable tags." + :group 'customize) + +(define-widget 'custom-variable 'custom + "Customize variable." + :format "%l%v%m%h%a" + :help-echo "Set or reset this variable." + :documentation-property 'variable-documentation + :custom-state nil + :custom-menu 'custom-variable-menu-create + :custom-form 'edit + :value-create 'custom-variable-value-create + :action 'custom-variable-action + :custom-set 'custom-variable-set + :custom-save 'custom-variable-save + :custom-reset-current 'custom-redraw + :custom-reset-saved 'custom-variable-reset-saved + :custom-reset-factory 'custom-variable-reset-factory) + +(defun custom-variable-value-create (widget) + "Here is where you edit the variables value." + (custom-load-widget widget) + (let* ((buttons (widget-get widget :buttons)) + (children (widget-get widget :children)) + (form (widget-get widget :custom-form)) + (state (widget-get widget :custom-state)) + (symbol (widget-get widget :value)) + (options (get symbol 'custom-options)) + (child-type (or (get symbol 'custom-type) 'sexp)) + (tag (widget-get widget :tag)) + (type (let ((tmp (if (listp child-type) + (copy-list child-type) + (list child-type)))) + (when options + (widget-put tmp :options options)) + tmp)) + (conv (widget-convert type)) + (value (if (default-boundp symbol) + (default-value symbol) + (widget-get conv :value)))) + ;; If the widget is new, the child determine whether it is hidden. + (cond (state) + ((custom-show type value) + (setq state 'unknown)) + (t + (setq state 'hidden))) + ;; If we don't know the state, see if we need to edit it in lisp form. + (when (eq state 'unknown) + (unless (widget-apply conv :match value) + ;; (widget-apply (widget-convert type) :match value) + (setq form 'lisp))) + ;; Now we can create the child widget. + (cond ((eq state 'hidden) + ;; Indicate hidden value. + (push (widget-create-child-and-convert + widget 'item + :format "%{%t%}: ..." + :sample-face 'custom-variable-sample-face + :tag tag + :parent widget) + children)) + ((eq form 'lisp) + ;; In lisp mode edit the saved value when possible. + (let* ((value (cond ((get symbol 'saved-value) + (car (get symbol 'saved-value))) + ((get symbol 'factory-value) + (car (get symbol 'factory-value))) + ((default-boundp symbol) + (custom-quote (default-value symbol))) + (t + (custom-quote (widget-get conv :value)))))) + (push (widget-create-child-and-convert + widget 'sexp + :button-face 'custom-variable-button-face + :tag (symbol-name symbol) + :parent widget + :value value) + children))) + (t + ;; Edit mode. + (push (widget-create-child-and-convert + widget type + :tag tag + :button-face 'custom-variable-button-face + :sample-face 'custom-variable-sample-face + :value value) + children))) + ;; Now update the state. + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (if (eq state 'hidden) + (widget-put widget :custom-state state) + (custom-variable-state-set widget)) + (widget-put widget :custom-form form) + (widget-put widget :buttons buttons) + (widget-put widget :children children))) + +(defun custom-variable-state-set (widget) + "Set the state of WIDGET." + (let* ((symbol (widget-value widget)) + (value (if (default-boundp symbol) + (default-value symbol) + (widget-get widget :value))) + tmp + (state (cond ((setq tmp (get symbol 'customized-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'set + 'changed)) + ((setq tmp (get symbol 'saved-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'saved + 'changed)) + ((setq tmp (get symbol 'factory-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'factory + 'changed)) + (t 'rogue)))) + (widget-put widget :custom-state state))) + +(defvar custom-variable-menu + '(("Edit" . custom-variable-edit) + ("Edit Lisp" . custom-variable-edit-lisp) + ("Set" . custom-variable-set) + ("Save" . custom-variable-save) + ("Reset to Current" . custom-redraw) + ("Reset to Saved" . custom-variable-reset-saved) + ("Reset to Factory Settings" . custom-variable-reset-factory)) + "Alist of actions for the `custom-variable' widget. +The key is a string containing the name of the action, the value is a +lisp function taking the widget as an element which will be called +when the action is chosen.") + +(defun custom-variable-action (widget &optional event) + "Show the menu for `custom-variable' WIDGET. +Optional EVENT is the location for the menu." + (if (eq (widget-get widget :custom-state) 'hidden) + (progn + (widget-put widget :custom-state 'unknown) + (custom-redraw widget)) + (let* ((completion-ignore-case t) + (answer (widget-choose (custom-unlispify-tag-name + (widget-get widget :value)) + custom-variable-menu + event))) + (if answer + (funcall answer widget))))) + +(defun custom-variable-edit (widget) + "Edit value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'edit) + (custom-redraw widget)) + +(defun custom-variable-edit-lisp (widget) + "Edit the lisp representation of the value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'lisp) + (custom-redraw widget)) + +(defun custom-variable-set (widget) + "Set the current value for the variable being edited by WIDGET." + (let ((form (widget-get widget :custom-form)) + (state (widget-get widget :custom-state)) + (child (car (widget-get widget :children))) + (symbol (widget-value widget)) + val) + (cond ((eq state 'hidden) + (error "Cannot set hidden variable.")) + ((setq val (widget-apply child :validate)) + (goto-char (widget-get val :from)) + (error "%s" (widget-get val :error))) + ((eq form 'lisp) + (set symbol (eval (setq val (widget-value child)))) + (put symbol 'customized-value (list val))) + (t + (set symbol (setq val (widget-value child))) + (put symbol 'customized-value (list (custom-quote val))))) + (custom-variable-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-variable-save (widget) + "Set the default value for the variable being edited by WIDGET." + (let ((form (widget-get widget :custom-form)) + (state (widget-get widget :custom-state)) + (child (car (widget-get widget :children))) + (symbol (widget-value widget)) + val) + (cond ((eq state 'hidden) + (error "Cannot set hidden variable.")) + ((setq val (widget-apply child :validate)) + (goto-char (widget-get val :from)) + (error "%s" (widget-get val :error))) + ((eq form 'lisp) + (put symbol 'saved-value (list (widget-value child))) + (set symbol (eval (widget-value child)))) + (t + (put symbol + 'saved-value (list (custom-quote (widget-value + child)))) + (set symbol (widget-value child)))) + (put symbol 'customized-value nil) + (custom-save-all) + (custom-variable-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-variable-reset-saved (widget) + "Restore the saved value for the variable being edited by WIDGET." + (let ((symbol (widget-value widget))) + (if (get symbol 'saved-value) + (condition-case nil + (set symbol (eval (car (get symbol 'saved-value)))) + (error nil)) + (error "No saved value for %s" symbol)) + (put symbol 'customized-value nil) + (widget-put widget :custom-state 'unknown) + (custom-redraw widget))) + +(defun custom-variable-reset-factory (widget) + "Restore the factory setting for the variable being edited by WIDGET." + (let ((symbol (widget-value widget))) + (if (get symbol 'factory-value) + (set symbol (eval (car (get symbol 'factory-value)))) + (error "No factory default for %S" symbol)) + (put symbol 'customized-value nil) + (when (get symbol 'saved-value) + (put symbol 'saved-value nil) + (custom-save-all)) + (widget-put widget :custom-state 'unknown) + (custom-redraw widget))) + +;;; The `custom-face-edit' Widget. + +(define-widget 'custom-face-edit 'checklist + "Edit face attributes." + :format "%t: %v" + :tag "Attributes" + :extra-offset 12 + :button-args '(:help-echo "Control whether this attribute have any effect.") + :args (mapcar (lambda (att) + (list 'group + :inline t + :sibling-args (widget-get (nth 1 att) :sibling-args) + (list 'const :format "" :value (nth 0 att)) + (nth 1 att))) + custom-face-attributes)) + +;;; The `custom-display' Widget. + +(define-widget 'custom-display 'menu-choice + "Select a display type." + :tag "Display" + :value t + :help-echo "Specify frames where the face attributes should be used." + :args '((const :tag "all" t) + (checklist + :offset 0 + :extra-offset 9 + :args ((group :sibling-args (:help-echo "\ +Only match the specified window systems.") + (const :format "Type: " + type) + (checklist :inline t + :offset 0 + (const :format "X " + :sibling-args (:help-echo "\ +The X11 Window System.") + x) + (const :format "PM " + :sibling-args (:help-echo "\ +OS/2 Presentation Manager.") + pm) + (const :format "Win32 " + :sibling-args (:help-echo "\ +Windows NT/95/97.") + win32) + (const :format "DOS " + :sibling-args (:help-echo "\ +Plain MS-DOS.") + pc) + (const :format "TTY%n" + :sibling-args (:help-echo "\ +Plain text terminals.") + tty))) + (group :sibling-args (:help-echo "\ +Only match the frames with the specified color support.") + (const :format "Class: " + class) + (checklist :inline t + :offset 0 + (const :format "Color " + :sibling-args (:help-echo "\ +Match color frames.") + color) + (const :format "Grayscale " + :sibling-args (:help-echo "\ +Match grayscale frames.") + grayscale) + (const :format "Monochrome%n" + :sibling-args (:help-echo "\ +Match frames with no color support.") + mono))) + (group :sibling-args (:help-echo "\ +Only match frames with the specified intensity.") + (const :format "\ +Background brightness: " + background) + (checklist :inline t + :offset 0 + (const :format "Light " + :sibling-args (:help-echo "\ +Match frames with light backgrounds.") + light) + (const :format "Dark\n" + :sibling-args (:help-echo "\ +Match frames with dark backgrounds.") + dark))))))) + +;;; The `custom-face' Widget. + +(defface custom-face-tag-face '((t (:underline t))) + "Face used for face tags." + :group 'customize) + +(define-widget 'custom-face 'custom + "Customize face." + :format "%l%{%t%}: %s%m%h%a%v" + :format-handler 'custom-face-format-handler + :sample-face 'custom-face-tag-face + :help-echo "Set or reset this face." + :documentation-property '(lambda (face) + (face-doc-string face)) + :value-create 'custom-face-value-create + :action 'custom-face-action + :custom-form 'selected + :custom-set 'custom-face-set + :custom-save 'custom-face-save + :custom-reset-current 'custom-redraw + :custom-reset-saved 'custom-face-reset-saved + :custom-reset-factory 'custom-face-reset-factory + :custom-menu 'custom-face-menu-create) + +(defun custom-face-format-handler (widget escape) + ;; We recognize extra escape sequences. + (let (child + (symbol (widget-get widget :value))) + (cond ((eq escape ?s) + (and (string-match "XEmacs" emacs-version) + ;; XEmacs cannot display initialized faces. + (not (custom-facep symbol)) + (copy-face 'custom-face-empty symbol)) + (setq child (widget-create-child-and-convert + widget 'item + :format "(%{%t%})\n" + :sample-face symbol + :tag "sample"))) + (t + (custom-format-handler widget escape))) + (when child + (widget-put widget + :buttons (cons child (widget-get widget :buttons)))))) + +(define-widget 'custom-face-all 'editable-list + "An editable list of display specifications and attributes." + :entry-format "%i %d %v" + :insert-button-args '(:help-echo "Insert new display specification here.") + :append-button-args '(:help-echo "Append new display specification here.") + :delete-button-args '(:help-echo "Delete this display specification.") + :args '((group :format "%v" custom-display custom-face-edit))) + +(defconst custom-face-all (widget-convert 'custom-face-all) + "Converted version of the `custom-face-all' widget.") + +(define-widget 'custom-display-unselected 'item + "A display specification that doesn't match the selected display." + :match 'custom-display-unselected-match) + +(defun custom-display-unselected-match (widget value) + "Non-nil if VALUE is an unselected display specification." + (and (listp value) + (eq (length value) 2) + (not (custom-display-match-frame value (selected-frame))))) + +(define-widget 'custom-face-selected 'group + "Edit the attributes of the selected display in a face specification." + :args '((repeat :format "" + :inline t + (group custom-display-unselected sexp)) + (group (sexp :format "") custom-face-edit) + (repeat :format "" + :inline t + sexp))) + +(defconst custom-face-selected (widget-convert 'custom-face-selected) + "Converted version of the `custom-face-selected' widget.") + +(defun custom-face-value-create (widget) + ;; Create a list of the display specifications. + (unless (eq (preceding-char) ?\n) + (insert "\n")) + (when (not (eq (widget-get widget :custom-state) 'hidden)) + (message "Creating face editor...") + (custom-load-widget widget) + (let* ((symbol (widget-value widget)) + (spec (or (get symbol 'saved-face) + (get symbol 'factory-face) + ;; Attempt to construct it. + (list (list t (custom-face-attributes-get + symbol (selected-frame)))))) + (form (widget-get widget :custom-form)) + (indent (widget-get widget :indent)) + (edit (widget-create-child-and-convert + widget + (cond ((and (eq form 'selected) + (widget-apply custom-face-selected :match spec)) + (when indent (insert-char ?\ indent)) + 'custom-face-selected) + ((and (not (eq form 'lisp)) + (widget-apply custom-face-all :match spec)) + 'custom-face-all) + (t + (when indent (insert-char ?\ indent)) + 'sexp)) + :value spec))) + (custom-face-state-set widget) + (widget-put widget :children (list edit))) + (message "Creating face editor...done"))) + +(defvar custom-face-menu + '(("Edit Selected" . custom-face-edit-selected) + ("Edit All" . custom-face-edit-all) + ("Edit Lisp" . custom-face-edit-lisp) + ("Set" . custom-face-set) + ("Save" . custom-face-save) + ("Reset to Saved" . custom-face-reset-saved) + ("Reset to Factory Setting" . custom-face-reset-factory)) + "Alist of actions for the `custom-face' widget. +The key is a string containing the name of the action, the value is a +lisp function taking the widget as an element which will be called +when the action is chosen.") + +(defun custom-face-edit-selected (widget) + "Edit selected attributes of the value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'selected) + (custom-redraw widget)) + +(defun custom-face-edit-all (widget) + "Edit all attributes of the value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'all) + (custom-redraw widget)) + +(defun custom-face-edit-lisp (widget) + "Edit the lisp representation of the value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'lisp) + (custom-redraw widget)) + +(defun custom-face-state-set (widget) + "Set the state of WIDGET." + (let ((symbol (widget-value widget))) + (widget-put widget :custom-state (cond ((get symbol 'customized-face) + 'set) + ((get symbol 'saved-face) + 'saved) + ((get symbol 'factory-face) + 'factory) + (t + 'rogue))))) + +(defun custom-face-action (widget &optional event) + "Show the menu for `custom-face' WIDGET. +Optional EVENT is the location for the menu." + (if (eq (widget-get widget :custom-state) 'hidden) + (progn + (widget-put widget :custom-state 'unknown) + (custom-redraw widget)) + (let* ((completion-ignore-case t) + (symbol (widget-get widget :value)) + (answer (widget-choose (custom-unlispify-tag-name symbol) + custom-face-menu event))) + (if answer + (funcall answer widget))))) + +(defun custom-face-set (widget) + "Make the face attributes in WIDGET take effect." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (widget-value child))) + (put symbol 'customized-face value) + (when (fboundp 'copy-face) + (copy-face 'custom-face-empty symbol)) + (custom-face-display-set symbol value) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-face-save (widget) + "Make the face attributes in WIDGET default." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (widget-value child))) + (when (fboundp 'copy-face) + (copy-face 'custom-face-empty symbol)) + (custom-face-display-set symbol value) + (put symbol 'saved-face value) + (put symbol 'customized-face nil) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-face-reset-saved (widget) + "Restore WIDGET to the face's default attributes." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (get symbol 'saved-face))) + (unless value + (error "No saved value for this face")) + (put symbol 'customized-face nil) + (when (fboundp 'copy-face) + (copy-face 'custom-face-empty symbol)) + (custom-face-display-set symbol value) + (widget-value-set child value) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-face-reset-factory (widget) + "Restore WIDGET to the face's factory settings." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (get symbol 'factory-face))) + (unless value + (error "No factory default for this face")) + (put symbol 'customized-face nil) + (when (get symbol 'saved-face) + (put symbol 'saved-face nil) + (custom-save-all)) + (when (fboundp 'copy-face) + (copy-face 'custom-face-empty symbol)) + (custom-face-display-set symbol value) + (widget-value-set child value) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +;;; The `face' Widget. + +(define-widget 'face 'default + "Select and customize a face." + :convert-widget 'widget-item-convert-widget + :format "%[%t%]: %v" + :tag "Face" + :value 'default + :value-create 'widget-face-value-create + :value-delete 'widget-face-value-delete + :value-get 'widget-item-value-get + :validate 'widget-editable-list-validate + :action 'widget-face-action + :match '(lambda (widget value) (symbolp value))) + +(defun widget-face-value-create (widget) + ;; Create a `custom-face' child. + (let* ((symbol (widget-value widget)) + (child (widget-create-child-and-convert + widget 'custom-face + :format "%t %s%m%h%v" + :custom-level nil + :value symbol))) + (custom-magic-reset child) + (setq custom-options (cons child custom-options)) + (widget-put widget :children (list child)))) + +(defun widget-face-value-delete (widget) + ;; Remove the child from the options. + (let ((child (car (widget-get widget :children)))) + (setq custom-options (delq child custom-options)) + (widget-children-value-delete widget))) + +(defvar face-history nil + "History of entered face names.") + +(defun widget-face-action (widget &optional event) + "Prompt for a face." + (let ((answer (completing-read "Face: " + (mapcar (lambda (face) + (list (symbol-name face))) + (face-list)) + nil nil nil + 'face-history))) + (unless (zerop (length answer)) + (widget-value-set widget (intern answer)) + (widget-apply widget :notify widget event) + (widget-setup)))) + +;;; The `hook' Widget. + +(define-widget 'hook 'list + "A emacs lisp hook" + :convert-widget 'custom-hook-convert-widget + :tag "Hook") + +(defun custom-hook-convert-widget (widget) + ;; Handle `:custom-options'. + (let* ((options (widget-get widget :options)) + (other `(editable-list :inline t + :entry-format "%i %d%v" + (function :format " %v"))) + (args (if options + (list `(checklist :inline t + ,@(mapcar (lambda (entry) + `(function-item ,entry)) + options)) + other) + (list other)))) + (widget-put widget :args args) + widget)) + +;;; The `custom-group' Widget. + +(defcustom custom-group-tag-faces '(custom-group-tag-face-1) + ;; In XEmacs, this ought to play games with font size. + "Face used for group tags. +The first member is used for level 1 groups, the second for level 2, +and so forth. The remaining group tags are shown with +`custom-group-tag-face'." + :type '(repeat face) + :group 'customize) + +(defface custom-group-tag-face-1 '((((class color) + (background dark)) + (:foreground "pink" :underline t)) + (((class color) + (background light)) + (:foreground "red" :underline t)) + (t (:underline t))) + "Face used for group tags.") + +(defface custom-group-tag-face '((((class color) + (background dark)) + (:foreground "light blue" :underline t)) + (((class color) + (background light)) + (:foreground "blue" :underline t)) + (t (:underline t))) + "Face used for low level group tags." + :group 'customize) + +(define-widget 'custom-group 'custom + "Customize group." + :format "%l%{%t%}:%L\n%m%h%a%v" + :sample-face-get 'custom-group-sample-face-get + :documentation-property 'group-documentation + :help-echo "Set or reset all members of this group." + :value-create 'custom-group-value-create + :action 'custom-group-action + :custom-set 'custom-group-set + :custom-save 'custom-group-save + :custom-reset-current 'custom-group-reset-current + :custom-reset-saved 'custom-group-reset-saved + :custom-reset-factory 'custom-group-reset-factory + :custom-menu 'custom-group-menu-create) + +(defun custom-group-sample-face-get (widget) + ;; Use :sample-face. + (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces) + 'custom-group-tag-face)) + +(defun custom-group-value-create (widget) + (let ((state (widget-get widget :custom-state))) + (unless (eq state 'hidden) + (message "Creating group...") + (custom-load-widget widget) + (let* ((level (widget-get widget :custom-level)) + (symbol (widget-value widget)) + (members (get symbol 'custom-group)) + (prefixes (widget-get widget :custom-prefixes)) + (custom-prefix-list (custom-prefix-add symbol prefixes)) + (length (length members)) + (count 0) + (children (mapcar (lambda (entry) + (widget-insert "\n") + (message "Creating group members... %2d%%" + (/ (* 100.0 count) length)) + (setq count (1+ count)) + (prog1 + (widget-create-child-and-convert + widget (nth 1 entry) + :group widget + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :custom-prefixes custom-prefix-list + :custom-level (1+ level) + :value (nth 0 entry)) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")))) + members))) + (message "Creating group magic...") + (mapcar 'custom-magic-reset children) + (message "Creating group state...") + (widget-put widget :children children) + (custom-group-state-update widget) + (message "Creating group... done"))))) + +(defvar custom-group-menu + '(("Set" . custom-group-set) + ("Save" . custom-group-save) + ("Reset to Current" . custom-group-reset-current) + ("Reset to Saved" . custom-group-reset-saved) + ("Reset to Factory" . custom-group-reset-factory)) + "Alist of actions for the `custom-group' widget. +The key is a string containing the name of the action, the value is a +lisp function taking the widget as an element which will be called +when the action is chosen.") + +(defun custom-group-action (widget &optional event) + "Show the menu for `custom-group' WIDGET. +Optional EVENT is the location for the menu." + (if (eq (widget-get widget :custom-state) 'hidden) + (progn + (widget-put widget :custom-state 'unknown) + (custom-redraw widget)) + (let* ((completion-ignore-case t) + (answer (widget-choose (custom-unlispify-tag-name + (widget-get widget :value)) + custom-group-menu + event))) + (if answer + (funcall answer widget))))) + +(defun custom-group-set (widget) + "Set changes in all modified group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-set))) + children ))) + +(defun custom-group-save (widget) + "Save all modified group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-save))) + children ))) + +(defun custom-group-reset-current (widget) + "Reset all modified group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children ))) + +(defun custom-group-reset-saved (widget) + "Reset all modified or set group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-reset-saved))) + children ))) + +(defun custom-group-reset-factory (widget) + "Reset all modified, set, or saved group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (memq (widget-get child :custom-state) + '(modified set saved)) + (widget-apply child :custom-reset-factory))) + children ))) + +(defun custom-group-state-update (widget) + "Update magic." + (unless (eq (widget-get widget :custom-state) 'hidden) + (let* ((children (widget-get widget :children)) + (states (mapcar (lambda (child) + (widget-get child :custom-state)) + children)) + (magics custom-magic-alist) + (found 'factory)) + (while magics + (let ((magic (car (car magics)))) + (if (and (not (eq magic 'hidden)) + (memq magic states)) + (setq found magic + magics nil) + (setq magics (cdr magics))))) + (widget-put widget :custom-state found))) + (custom-magic-reset widget)) + +;;; The `custom-save-all' Function. + +(defcustom custom-file "~/.emacs" + "File used for storing customization information. +If you change this from the default \"~/.emacs\" you need to +explicitly load that file for the settings to take effect." + :type 'file + :group 'customize) + +(defun custom-save-delete (symbol) + "Delete the call to SYMBOL form `custom-file'. +Leave point at the location of the call, or after the last expression." + (set-buffer (find-file-noselect custom-file)) + (goto-char (point-min)) + (catch 'found + (while t + (let ((sexp (condition-case nil + (read (current-buffer)) + (end-of-file (throw 'found nil))))) + (when (and (listp sexp) + (eq (car sexp) symbol)) + (delete-region (save-excursion + (backward-sexp) + (point)) + (point)) + (throw 'found nil)))))) + +(defun custom-save-variables () + "Save all customized variables in `custom-file'." + (save-excursion + (custom-save-delete 'custom-set-variables) + (let ((standard-output (current-buffer))) + (unless (bolp) + (princ "\n")) + (princ "(custom-set-variables") + (mapatoms (lambda (symbol) + (let ((value (get symbol 'saved-value))) + (when value + (princ "\n '(") + (princ symbol) + (princ " ") + (prin1 (car value)) + (if (or (get symbol 'factory-value) + (and (not (boundp symbol)) + (not (get symbol 'force-value)))) + (princ ")") + (princ " t)")))))) + (princ ")") + (unless (looking-at "\n") + (princ "\n"))))) + +(defun custom-save-faces () + "Save all customized faces in `custom-file'." + (save-excursion + (custom-save-delete 'custom-set-faces) + (let ((standard-output (current-buffer))) + (unless (bolp) + (princ "\n")) + (princ "(custom-set-faces") + (mapatoms (lambda (symbol) + (let ((value (get symbol 'saved-face))) + (when value + (princ "\n '(") + (princ symbol) + (princ " ") + (prin1 value) + (if (or (get symbol 'factory-face) + (and (not (custom-facep symbol)) + (not (get symbol 'force-face)))) + (princ ")") + (princ " t)")))))) + (princ ")") + (unless (looking-at "\n") + (princ "\n"))))) + +;;;###autoload +(defun custom-save-all () + "Save all customizations in `custom-file'." + (custom-save-variables) + (custom-save-faces) + (save-excursion + (set-buffer (find-file-noselect custom-file)) + (save-buffer))) + +;;; The Customize Menu. + +(defcustom custom-menu-nesting 2 + "Maximum nesting in custom menus." + :type 'integer + :group 'customize) + +(defun custom-face-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization face SYMBOL." + (vector (custom-unlispify-menu-entry symbol) + `(custom-buffer-create '((,symbol custom-face))) + t)) + +(defun custom-variable-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization variable SYMBOL." + (let ((type (get symbol 'custom-type))) + (unless (listp type) + (setq type (list type))) + (if (and type (widget-get type :custom-menu)) + (widget-apply type :custom-menu symbol) + (vector (custom-unlispify-menu-entry symbol) + `(custom-buffer-create '((,symbol custom-variable))) + t)))) + +(widget-put (get 'boolean 'widget-type) + :custom-menu (lambda (widget symbol) + (vector (custom-unlispify-menu-entry symbol) + `(custom-buffer-create + '((,symbol custom-variable))) + ':style 'toggle + ':selected symbol))) + +(if (string-match "XEmacs" emacs-version) + ;; XEmacs can create menus dynamically. + (defun custom-group-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization group SYMBOL." + `( ,(custom-unlispify-menu-entry symbol t) + :filter (lambda (&rest junk) + (cdr (custom-menu-create ',symbol))))) + ;; But emacs can't. + (defun custom-group-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization group SYMBOL." + ;; Limit the nesting. + (let ((custom-menu-nesting (1- custom-menu-nesting))) + (custom-menu-create symbol)))) + +(defun custom-menu-create (symbol &optional name) + "Create menu for customization group SYMBOL. +If optional NAME is given, use that as the name of the menu. +Otherwise make up a name from SYMBOL. +The menu is in a format applicable to `easy-menu-define'." + (unless name + (setq name (custom-unlispify-menu-entry symbol))) + (let ((item (vector name + `(custom-buffer-create '((,symbol custom-group))) + t))) + (if (and (>= custom-menu-nesting 0) + (< (length (get symbol 'custom-group)) widget-menu-max-size)) + (let ((custom-prefix-list (custom-prefix-add symbol + custom-prefix-list))) + (custom-load-symbol symbol) + `(,(custom-unlispify-menu-entry symbol t) + ,item + "--" + ,@(mapcar (lambda (entry) + (widget-apply (if (listp (nth 1 entry)) + (nth 1 entry) + (list (nth 1 entry))) + :custom-menu (nth 0 entry))) + (get symbol 'custom-group)))) + item))) + +;;;###autoload +(defun custom-menu-update (event) + "Update customize menu." + (interactive "e") + (add-hook 'custom-define-hook 'custom-menu-reset) + (let* ((emacs (widget-apply '(custom-group) :custom-menu 'emacs)) + (menu `(,(car custom-help-menu) + ,emacs + ,@(cdr (cdr custom-help-menu))))) + (let ((map (easy-menu-create-keymaps (car menu) (cdr menu)))) + (define-key global-map [menu-bar help-menu customize-menu] + (cons (car menu) map))))) + +;;; Dependencies. + +;;;###autoload +(defun custom-make-dependencies () + "Batch function to extract custom dependencies from .el files. +Usage: emacs -batch *.el -f custom-make-dependencies > deps.el" + (let ((buffers (buffer-list))) + (while buffers + (set-buffer (car buffers)) + (setq buffers (cdr buffers)) + (let ((file (buffer-file-name))) + (when (and file (string-match "\\`\\(.*\\)\\.el\\'" file)) + (goto-char (point-min)) + (condition-case nil + (let ((name (file-name-nondirectory (match-string 1 file)))) + (while t + (let ((expr (read (current-buffer)))) + (when (and (listp expr) + (memq (car expr) '(defcustom defface defgroup))) + (eval expr) + (put (nth 1 expr) 'custom-where name))))) + (error nil)))))) + (mapatoms (lambda (symbol) + (let ((members (get symbol 'custom-group)) + item where found) + (when members + (princ "(put '") + (princ symbol) + (princ " 'custom-loads '(") + (while members + (setq item (car (car members)) + members (cdr members) + where (get item 'custom-where)) + (unless (or (null where) + (member where found)) + (when found + (princ " ")) + (prin1 where) + (push where found))) + (princ "))\n")))))) + +;;; The End. + +(provide 'cus-edit) + +;; cus-edit.el ends here diff --git a/lisp/cus-face.el b/lisp/cus-face.el new file mode 100644 index 00000000000..ae8e60b499f --- /dev/null +++ b/lisp/cus-face.el @@ -0,0 +1,590 @@ +;;; cus-face.el -- XEmacs specific custom support. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, faces +;; Version: 1.71 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `custom.el'. + +;;; Code: + +(require 'custom) + +(eval-and-compile (require 'cl)) + +;;; Compatibility. + +(if (string-match "XEmacs" emacs-version) + (defun custom-face-background (face &optional frame) + ;; Specifiers suck! + "Return the background color name of face FACE, or nil if unspecified." + (color-instance-name (specifier-instance (face-background face) frame))) + (defalias 'custom-face-background 'face-background)) + +(if (string-match "XEmacs" emacs-version) + (defun custom-face-foreground (face &optional frame) + ;; Specifiers suck! + "Return the background color name of face FACE, or nil if unspecified." + (color-instance-name (specifier-instance (face-foreground face) frame))) + (defalias 'custom-face-foreground 'face-foreground)) + +(defalias 'custom-face-font-name (if (string-match "XEmacs" emacs-version) + 'face-font-name + 'face-font)) + +(eval-and-compile + (unless (fboundp 'frame-property) + ;; XEmacs function missing in Emacs 19.34. + (defun frame-property (frame property &optional default) + "Return FRAME's value for property PROPERTY." + (or (cdr (assq property (frame-parameters frame))) + default))) + + (unless (fboundp 'face-doc-string) + ;; XEmacs function missing in Emacs. + (defun face-doc-string (face) + "Get the documentation string for FACE." + (get face 'face-doc-string))) + + (unless (fboundp 'set-face-doc-string) + ;; XEmacs function missing in Emacs. + (defun set-face-doc-string (face string) + "Set the documentation string for FACE to STRING." + (put face 'face-doc-string string))) + + (when (and (not (fboundp 'set-face-stipple)) + (fboundp 'set-face-background-pixmap)) + ;; Emacs function missing in XEmacs 19.15. + (defun set-face-stipple (face pixmap &optional frame) + ;; Written by Kyle Jones. + "Change the stipple pixmap of face FACE to PIXMAP. +PIXMAP should be a string, the name of a file of pixmap data. +The directories listed in the `x-bitmap-file-path' variable are searched. + +Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT DATA) +where WIDTH and HEIGHT are the size in pixels, +and DATA is a string, containing the raw bits of the bitmap. + +If the optional FRAME argument is provided, change only +in that frame; otherwise change each frame." + (while (not (find-face face)) + (setq face (signal 'wrong-type-argument (list 'facep face)))) + (while (cond ((stringp pixmap) + (unless (file-readable-p pixmap) + (setq pixmap (vector 'xbm ':file pixmap))) + nil) + ((and (consp pixmap) (= (length pixmap) 3)) + (setq pixmap (vector 'xbm ':data pixmap)) + nil) + (t t)) + (setq pixmap (signal 'wrong-type-argument + (list 'stipple-pixmap-p pixmap)))) + (while (and frame (not (framep frame))) + (setq frame (signal 'wrong-type-argument (list 'framep frame)))) + (set-face-background-pixmap face pixmap frame)))) + +(unless (fboundp 'x-color-values) + ;; Emacs function missing in XEmacs 19.14. + (defun x-color-values (color &optional frame) + "Return a description of the color named COLOR on frame FRAME. +The value is a list of integer RGB values--(RED GREEN BLUE). +These values appear to range from 0 to 65280 or 65535, depending +on the system; white is (65280 65280 65280) or (65535 65535 65535). +If FRAME is omitted or nil, use the selected frame." + (color-instance-rgb-components (make-color-instance color)))) + +;; XEmacs and Emacs have different definitions of `facep'. +;; The Emacs definition is the useful one, so emulate that. +(cond ((not (fboundp 'facep)) + (defun custom-facep (face) + "No faces" + nil)) + ((string-match "XEmacs" emacs-version) + (defalias 'custom-facep 'find-face)) + (t + (defalias 'custom-facep 'facep))) + +(unless (fboundp 'make-empty-face) + ;; This should be moved to `faces.el'. + (if (string-match "XEmacs" emacs-version) + ;; Give up for old XEmacs pre 19.15/20.1. + (defalias 'make-empty-face 'make-face) + ;; Define for Emacs pre 19.35. + (defun make-empty-face (name) + "Define a new FACE on all frames, ignoring X resources." + (interactive "SMake face: ") + (or (internal-find-face name) + (let ((face (make-vector 8 nil))) + (aset face 0 'face) + (aset face 1 name) + (let* ((frames (frame-list)) + (inhibit-quit t) + (id (internal-next-face-id))) + (make-face-internal id) + (aset face 2 id) + (while frames + (set-frame-face-alist (car frames) + (cons (cons name (copy-sequence face)) + (frame-face-alist (car frames)))) + (setq frames (cdr frames))) + (setq global-face-data (cons (cons name face) global-face-data))) + ;; add to menu + (if (fboundp 'facemenu-add-new-face) + (facemenu-add-new-face name)) + face)) + name))) + +(defcustom initialize-face-resources t + "If non nil, allow X resources to initialize face properties. +This only affects faces declared with `defface', and only NT or X11 frames." + :group 'customize + :type 'boolean) + +(cond ((fboundp 'initialize-face-resources) + ;; Already bound, do nothing. + ) + ((fboundp 'make-face-x-resource-internal) + ;; Emacs or new XEmacs. + (defun initialize-face-resources (face &optional frame) + "Initialize face according to the X11 resources. +This might overwrite existing face properties. +Does nothing when the variable initialize-face-resources is nil." + (when initialize-face-resources + (make-face-x-resource-internal face frame t)))) + (t + ;; Too hard to do right on XEmacs. + (defalias 'initialize-face-resources 'ignore))) + +;;(if (string-match "XEmacs" emacs-version) +;; ;; Xemacs. +;; (defun custom-invert-face (face &optional frame) +;; "Swap the foreground and background colors of face FACE. +;;If the colors are not specified in the face, use the default colors." +;; (interactive (list (read-face-name "Reverse face: "))) +;; (let ((fg (color-name (face-foreground face frame) frame)) +;; (bg (color-name (face-background face frame) frame))) +;; (set-face-foreground face bg frame) +;; (set-face-background face fg frame))) +;; ;; Emacs. +;; (defun custom-invert-face (face &optional frame) +;; "Swap the foreground and background colors of face FACE. +;;If the colors are not specified in the face, use the default colors." +;; (interactive (list (read-face-name "Reverse face: "))) +;; (let ((fg (or (face-foreground face frame) +;; (face-foreground 'default frame) +;; (frame-property (or frame (selected-frame)) +;; 'foreground-color) +;; "black")) +;; (bg (or (face-background face frame) +;; (face-background 'default frame) +;; (frame-property (or frame (selected-frame)) +;; 'background-color) +;; "white"))) +;; (set-face-foreground face bg frame) +;; (set-face-background face fg frame)))) + +(defcustom custom-background-mode nil + "The brightness of the background. +Set this to the symbol dark if your background color is dark, light if +your background is light, or nil (default) if you want Emacs to +examine the brightness for you." + :group 'customize + :type '(choice (choice-item dark) + (choice-item light) + (choice-item :tag "default" nil))) + +(defun custom-background-mode (frame) + "Kludge to detect background mode for FRAME." + (let* ((bg-resource + (condition-case () + (x-get-resource ".backgroundMode" "BackgroundMode" 'string) + (error nil))) + color + (mode (cond (bg-resource + (intern (downcase bg-resource))) + ((and (setq color (condition-case () + (or (frame-property + frame + 'background-color) + (custom-face-background + 'default)) + (error nil))) + (or (string-match "XEmacs" emacs-version) + window-system) + (< (apply '+ (x-color-values color)) + (/ (apply '+ (x-color-values "white")) + 3))) + 'dark) + (t 'light)))) + (modify-frame-parameters frame (list (cons 'background-mode mode))) + mode)) + +(eval-and-compile + (if (string-match "XEmacs" emacs-version) + ;; XEmacs. + (defun custom-extract-frame-properties (frame) + "Return a plist with the frame properties of FRAME used by custom." + (list 'type (device-type (frame-device frame)) + 'class (device-class (frame-device frame)) + 'background (or custom-background-mode + (frame-property frame + 'background-mode) + (custom-background-mode frame)))) + ;; Emacs. + (defun custom-extract-frame-properties (frame) + "Return a plist with the frame properties of FRAME used by custom." + (list 'type window-system + 'class (frame-property frame 'display-type) + 'background (or custom-background-mode + (frame-property frame 'background-mode) + (custom-background-mode frame)))))) + +;;; Declaring a face. + +;;;###autoload +(defun custom-declare-face (face spec doc &rest args) + "Like `defface', but FACE is evaluated as a normal argument." + (when (fboundp 'load-gc) + ;; This should be allowed, somehow. + (error "Attempt to declare a face during dump")) + (unless (get face 'factory-face) + (put face 'factory-face spec) + (when (fboundp 'facep) + (unless (custom-facep face) + ;; If the user has already created the face, respect that. + (let ((value (or (get face 'saved-face) spec)) + (frames (custom-relevant-frames)) + frame) + ;; Create global face. + (make-empty-face face) + (custom-face-display-set face value) + ;; Create frame local faces + (while frames + (setq frame (car frames) + frames (cdr frames)) + (custom-face-display-set face value frame)) + (initialize-face-resources face)))) + (when (and doc (null (face-doc-string face))) + (set-face-doc-string face doc)) + (custom-handle-all-keywords face args 'custom-face) + (run-hooks 'custom-define-hook)) + face) + +;;; Font Attributes. + +(defconst custom-face-attributes + '((:bold (toggle :format "Bold: %[%v%]\n" + :help-echo "Control whether a bold font should be used.") + custom-set-face-bold + custom-face-bold) + (:italic (toggle :format "Italic: %[%v%]\n" + :help-echo "\ +Control whether an italic font should be used.") + custom-set-face-italic + custom-face-italic) + (:underline (toggle :format "Underline: %[%v%]\n" + :help-echo "\ +Control whether the text should be underlined.") + set-face-underline-p + face-underline-p) + (:foreground (color :tag "Foreground" + :value "black" + :help-echo "Set foreground color.") + set-face-foreground + custom-face-foreground) + (:background (color :tag "Background" + :value "white" + :help-echo "Set background color.") + set-face-background + custom-face-background) + ;; (:invert (const :format "Invert Face\n" + ;; :sibling-args (:help-echo " + ;;Reverse the foreground and background color. + ;;If you haven't specified them for the face, the default colors will be used.") + ;; t) + ;; (lambda (face value &optional frame) + ;; ;; We don't use VALUE. + ;; (custom-invert-face face frame))) + (:stipple (editable-field :format "Stipple: %v" + :help-echo "Name of background bitmap file.") + set-face-stipple custom-face-stipple)) + "Alist of face attributes. + +The elements are of the form (KEY TYPE SET GET) where KEY is a symbol +identifying the attribute, TYPE is a widget type for editing the +attibute, SET is a function for setting the attribute value, and GET is a function for getiing the attribute value. + +The SET function should take three arguments, the face to modify, the +value of the attribute, and optionally the frame where the face should +be changed. + +The GET function should take two arguments, the face to examine, and +optonally the frame where the face should be examined.") + +(defun custom-face-attributes-set (face frame &rest atts) + "For FACE on FRAME set the attributes [KEYWORD VALUE].... +Each keyword should be listed in `custom-face-attributes'. + +If FRAME is nil, set the default face." + (while atts + (let* ((name (nth 0 atts)) + (value (nth 1 atts)) + (fun (nth 2 (assq name custom-face-attributes)))) + (setq atts (cdr (cdr atts))) + (condition-case nil + (funcall fun face value frame) + (error nil))))) + +(defun custom-face-attributes-get (face frame) + "For FACE on FRAME get the attributes [KEYWORD VALUE].... +Each keyword should be listed in `custom-face-attributes'. + +If FRAME is nil, use the default face." + (condition-case nil + ;; Attempt to get `font.el' from w3. + (require 'font) + (error nil)) + (let ((atts custom-face-attributes) + att result get) + (while atts + (setq att (car atts) + atts (cdr atts) + get (nth 3 att)) + (when get + (let ((answer (funcall get face frame))) + (unless (equal answer (funcall get 'default frame)) + (when (widget-apply (nth 1 att) :match answer) + (setq result (cons (nth 0 att) (cons answer result)))))))) + result)) + +(defun custom-set-face-bold (face value &optional frame) + "Set the bold property of FACE to VALUE." + (if value + (make-face-bold face frame) + (make-face-unbold face frame))) + +(defun custom-face-bold (face &rest args) + "Return non-nil if the font of FACE is bold." + (let* ((font (apply 'custom-face-font-name face args)) + (fontobj (font-create-object font))) + (font-bold-p fontobj))) + +(defun custom-set-face-italic (face value &optional frame) + "Set the italic property of FACE to VALUE." + (if value + (make-face-italic face frame) + (make-face-unitalic face frame))) + +(defun custom-face-italic (face &rest args) + "Return non-nil if the font of FACE is italic." + (let* ((font (apply 'custom-face-font-name face args)) + (fontobj (font-create-object font))) + (font-italic-p fontobj))) + +(defun custom-face-stipple (face &rest args) + "Return the name of the stipple file used for FACE." + (if (string-match "XEmacs" emacs-version) + (let ((image (apply 'specifier-instance + (face-background-pixmap face) args))) + (when image + (image-instance-file-name image))) + (apply 'face-stipple face args))) + +(when (string-match "XEmacs" emacs-version) + ;; Support for special XEmacs font attributes. + (autoload 'font-create-object "font" nil) + + (defun custom-set-face-font-size (face size &rest args) + "Set the font of FACE to SIZE" + (let* ((font (apply 'custom-face-font-name face args)) + (fontobj (font-create-object font))) + (set-font-size fontobj size) + (apply 'font-set-face-font face fontobj args))) + + (defun custom-face-font-size (face &rest args) + "Return the size of the font of FACE as a string." + (let* ((font (apply 'custom-face-font-name face args)) + (fontobj (font-create-object font))) + (format "%d" (font-size fontobj)))) + + (defun custom-set-face-font-family (face family &rest args) + "Set the font of FACE to FAMILY." + (let* ((font (apply 'custom-face-font-name face args)) + (fontobj (font-create-object font))) + (set-font-family fontobj family) + (apply 'font-set-face-font face fontobj args))) + + (defun custom-face-font-family (face &rest args) + "Return the name of the font family of FACE." + (let* ((font (apply 'custom-face-font-name face args)) + (fontobj (font-create-object font))) + (font-family fontobj))) + + (nconc custom-face-attributes + '((:family (editable-field :format "Font Family: %v" + :help-echo "\ +Name of font family to use (e.g. times).") + custom-set-face-font-family + custom-face-font-family) + (:size (editable-field :format "Size: %v" + :help-echo "\ +Text size (e.g. 9pt or 2mm).") + custom-set-face-font-size + custom-face-font-size)))) + +;;; Frames. + +(defun custom-face-display-set (face spec &optional frame) + "Set FACE to the attributes to the first matching entry in SPEC. +Iff optional FRAME is non-nil, set it for that frame only. +See `defface' for information about SPEC." + (when (fboundp 'make-face) + (while spec + (let* ((entry (car spec)) + (display (nth 0 entry)) + (atts (nth 1 entry))) + (setq spec (cdr spec)) + (when (custom-display-match-frame display frame) + ;; Avoid creating frame local duplicates of the global face. + (unless (and frame (eq display (get face 'custom-face-display))) + (apply 'custom-face-attributes-set face frame atts)) + (unless frame + (put face 'custom-face-display display)) + (setq spec nil)))))) + +(defvar custom-default-frame-properties nil + "The frame properties used for the global faces. +Frames who doesn't match these propertiess should have frame local faces. +The value should be nil, if uninitialized, or a plist otherwise. +See `defface' for a list of valid keys and values for the plist.") + +(defun custom-get-frame-properties (&optional frame) + "Return a plist with the frame properties of FRAME used by custom. +If FRAME is nil, return the default frame properties." + (cond (frame + ;; Try to get from cache. + (let ((cache (frame-property frame 'custom-properties))) + (unless cache + ;; Oh well, get it then. + (setq cache (custom-extract-frame-properties frame)) + ;; and cache it... + (modify-frame-parameters frame + (list (cons 'custom-properties cache)))) + cache)) + (custom-default-frame-properties) + (t + (setq custom-default-frame-properties + (custom-extract-frame-properties (selected-frame)))))) + +(defun custom-display-match-frame (display frame) + "Non-nil iff DISPLAY matches FRAME. +If FRAME is nil, the current FRAME is used." + ;; This is a kludge to get started, we really should use specifiers! + (if (eq display t) + t + (let* ((props (custom-get-frame-properties frame)) + (type (plist-get props 'type)) + (class (plist-get props 'class)) + (background (plist-get props 'background)) + (match t) + (entries display) + entry req options) + (while (and entries match) + (setq entry (car entries) + entries (cdr entries) + req (car entry) + options (cdr entry) + match (cond ((eq req 'type) + (memq type options)) + ((eq req 'class) + (memq class options)) + ((eq req 'background) + (memq background options)) + (t + (error "Unknown req `%S' with options `%S'" + req options))))) + match))) + +(defun custom-relevant-frames () + "List of frames whose custom properties differ from the default." + (let ((relevant nil) + (default (custom-get-frame-properties)) + (frames (frame-list)) + frame) + (while frames + (setq frame (car frames) + frames (cdr frames)) + (unless (equal default (custom-get-frame-properties frame)) + (push frame relevant))) + relevant)) + +(defun custom-initialize-faces (&optional frame) + "Initialize all custom faces for FRAME. +If FRAME is nil or omitted, initialize them for all frames." + (mapcar (lambda (symbol) + (let ((spec (or (get symbol 'saved-face) + (get symbol 'factory-face)))) + (when spec + (custom-face-display-set symbol spec frame) + (initialize-face-resources symbol frame)))) + (face-list))) + +(defun custom-initialize-frame (&optional frame) + "Initialize local faces for FRAME if necessary. +If FRAME is missing or nil, the first member of (frame-list) is used." + (unless frame + (setq frame (car (frame-list)))) + (unless (equal (custom-get-frame-properties) + (custom-get-frame-properties frame)) + (custom-initialize-faces frame))) + +;; Enable. This should go away when bundled with Emacs. +(unless (string-match "XEmacs" emacs-version) + (add-hook 'after-make-frame-hook 'custom-initialize-frame)) + +;;; Initializing. + +(and (fboundp 'make-face) + (make-face 'custom-face-empty)) + +;;;###autoload +(defun custom-set-faces (&rest args) + "Initialize faces according to user preferences. +The arguments should be a list where each entry has the form: + + (FACE SPEC [NOW]) + +SPEC will be stored as the saved value for FACE. If NOW is present +and non-nil, FACE will also be created according to SPEC. + +See `defface' for the format of SPEC." + (while args + (let ((entry (car args))) + (if (listp entry) + (let ((face (nth 0 entry)) + (spec (nth 1 entry)) + (now (nth 2 entry))) + (put face 'saved-face spec) + (when now + (put face 'force-face t)) + (when (or now (custom-facep face)) + (when (fboundp 'copy-face) + (copy-face 'custom-face-empty face)) + (custom-face-display-set face spec)) + (setq args (cdr args))) + ;; Old format, a plist of FACE SPEC pairs. + (let ((face (nth 0 args)) + (spec (nth 1 args))) + (put face 'saved-face spec)) + (setq args (cdr (cdr args))))))) + +;;; The End. + +(provide 'cus-face) + +;; cus-face.el ends here diff --git a/lisp/custom.el b/lisp/custom.el new file mode 100644 index 00000000000..6d247ebb379 --- /dev/null +++ b/lisp/custom.el @@ -0,0 +1,332 @@ +;;; custom.el -- Tools for declaring and initializing options. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, faces +;; Version: 1.71 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; If you want to use this code, please visit the URL above. +;; +;; This file only contain the code needed to declare and initialize +;; user options. The code to customize options is autoloaded from +;; `cus-edit.el'. + +;; The code implementing face declarations is in `cus-face.el' + +;;; Code: + +(require 'widget) + +(define-widget-keywords :prefix :tag :load :link :options :type :group) + +;; These autoloads should be deleted when the file is added to Emacs + +(unless (fboundp 'load-gc) + ;; From cus-edit.el + (autoload 'customize "cus-edit" nil t) + (autoload 'customize-variable "cus-edit" nil t) + (autoload 'customize-face "cus-edit" nil t) + (autoload 'customize-apropos "cus-edit" nil t) + (autoload 'customize-customized "cus-edit" nil t) + (autoload 'custom-buffer-create "cus-edit") + (autoload 'custom-menu-update "cus-edit") + (autoload 'custom-make-dependencies "cus-edit") + ;; From cus-face.el + (autoload 'custom-declare-face "cus-face") + (autoload 'custom-set-faces "cus-face")) + +;;; The `defcustom' Macro. + +(defun custom-declare-variable (symbol value doc &rest args) + "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." + (unless (and (default-boundp symbol) + (not (get symbol 'saved-value))) + (set-default symbol (if (get symbol 'saved-value) + (eval (car (get symbol 'saved-value))) + (eval value)))) + (put symbol 'factory-value (list value)) + (when doc + (put symbol 'variable-documentation doc)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :type) + (put symbol 'custom-type value)) + ((eq keyword :options) + (if (get symbol 'custom-options) + ;; Slow safe code to avoid duplicates. + (mapcar (lambda (option) + (custom-add-option symbol option)) + value) + ;; Fast code for the common case. + (put symbol 'custom-options (copy-list value)))) + (t + (custom-handle-keyword symbol keyword value + 'custom-variable)))))) + (run-hooks 'custom-define-hook) + symbol) + +(defmacro defcustom (symbol value doc &rest args) + "Declare SYMBOL as a customizable variable that defaults to VALUE. +DOC is the variable documentation. + +Neither SYMBOL nor VALUE needs to be quoted. +If SYMBOL is not already bound, initialize it to VALUE. +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:type VALUE should be a widget type. +:options VALUE should be a list of valid members of the widget type. +:group VALUE should be a customization group. + Add SYMBOL to that group. + +Read the section about customization in the emacs lisp manual for more +information." + `(eval-and-compile + (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))) + +;;; The `defface' Macro. + +(defmacro defface (face spec doc &rest args) + "Declare FACE as a customizable face that defaults to SPEC. +FACE does not need to be quoted. + +Third argument DOC is the face documentation. + +If FACE has been set with `custom-set-face', set the face attributes +as specified by that function, otherwise set the face attributes +according to SPEC. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:group VALUE should be a customization group. + Add FACE to that group. + +SPEC should be an alist of the form ((DISPLAY ATTS)...). + +ATTS is a list of face attributes and their values. The possible +attributes are defined in the variable `custom-face-attributes'. +Alternatively, ATTS can be a face in which case the attributes of that +face is used. + +The ATTS of the first entry in SPEC where the DISPLAY matches the +frame should take effect in that frame. DISPLAY can either be the +symbol t, which will match all frames, or an alist of the form +\((REQ ITEM...)...) + +For the DISPLAY to match a FRAME, the REQ property of the frame must +match one of the ITEM. The following REQ are defined: + +`type' (the value of `window-system') + Should be one of `x' or `tty'. + +`class' (the frame's color support) + Should be one of `color', `grayscale', or `mono'. + +`background' (what color is used for the background text) + Should be one of `light' or `dark'. + +Read the section about customization in the emacs lisp manual for more +information." + `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) + +;;; The `defgroup' Macro. + +(defun custom-declare-group (symbol members doc &rest args) + "Like `defgroup', but SYMBOL is evaluated as a normal argument." + (put symbol 'custom-group (nconc members (get symbol 'custom-group))) + (when doc + (put symbol 'group-documentation doc)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :prefix) + (put symbol 'custom-prefix value)) + (t + (custom-handle-keyword symbol keyword value + 'custom-group)))))) + (run-hooks 'custom-define-hook) + symbol) + +(defmacro defgroup (symbol members doc &rest args) + "Declare SYMBOL as a customization group containing MEMBERS. +SYMBOL does not need to be quoted. + +Third arg DOC is the group documentation. + +MEMBERS should be an alist of the form ((NAME WIDGET)...) where +NAME is a symbol and WIDGET is a widget is a widget for editing that +symbol. Useful widgets are `custom-variable' for editing variables, +`custom-face' for edit faces, and `custom-group' for editing groups. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:group VALUE should be a customization group. + Add SYMBOL to that group. + +Read the section about customization in the emacs lisp manual for more +information." + `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) + +(defun custom-add-to-group (group option widget) + "To existing GROUP add a new OPTION of type WIDGET. +If there already is an entry for that option, overwrite it." + (let* ((members (get group 'custom-group)) + (old (assq option members))) + (if old + (setcar (cdr old) widget) + (put group 'custom-group (nconc members (list (list option widget))))))) + +;;; Properties. + +(defun custom-handle-all-keywords (symbol args type) + "For customization option SYMBOL, handle keyword arguments ARGS. +Third argument TYPE is the custom option type." + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (custom-handle-keyword symbol keyword value type))))) + +(defun custom-handle-keyword (symbol keyword value type) + "For customization option SYMBOL, handle KEYWORD with VALUE. +Fourth argument TYPE is the custom option type." + (cond ((eq keyword :group) + (custom-add-to-group value symbol type)) + ((eq keyword :link) + (custom-add-link symbol value)) + ((eq keyword :load) + (custom-add-load symbol value)) + ((eq keyword :tag) + (put symbol 'custom-tag value)) + (t + (error "Unknown keyword %s" symbol)))) + +(defun custom-add-option (symbol option) + "To the variable SYMBOL add OPTION. + +If SYMBOL is a hook variable, OPTION should be a hook member. +For other types variables, the effect is undefined." + (let ((options (get symbol 'custom-options))) + (unless (member option options) + (put symbol 'custom-options (cons option options))))) + +(defun custom-add-link (symbol widget) + "To the custom option SYMBOL add the link WIDGET." + (let ((links (get symbol 'custom-links))) + (unless (member widget links) + (put symbol 'custom-links (cons widget links))))) + +(defun custom-add-load (symbol load) + "To the custom option SYMBOL add the dependency LOAD. +LOAD should be either a library file name, or a feature name." + (let ((loads (get symbol 'custom-loads))) + (unless (member load loads) + (put symbol 'custom-loads (cons load loads))))) + +;;; Initializing. + +(defun custom-set-variables (&rest args) + "Initialize variables according to user preferences. + +The arguments should be a list where each entry has the form: + + (SYMBOL VALUE [NOW]) + +The unevaluated VALUE is stored as the saved value for SYMBOL. +If NOW is present and non-nil, VALUE is also evaluated and bound as +the default value for the SYMBOL." + (while args + (let ((entry (car args))) + (if (listp entry) + (let ((symbol (nth 0 entry)) + (value (nth 1 entry)) + (now (nth 2 entry))) + (put symbol 'saved-value (list value)) + (when now + (put symbol 'force-value t) + (set-default symbol (eval value))) + (setq args (cdr args))) + ;; Old format, a plist of SYMBOL VALUE pairs. + (let ((symbol (nth 0 args)) + (value (nth 1 args))) + (put symbol 'saved-value (list value))) + (setq args (cdr (cdr args))))))) + +;;; Meta Customization + +(defcustom custom-define-hook nil + "Hook called after defining each customize option." + :group 'customize + :type 'hook) + +;;; Menu support + +(defconst custom-help-menu + `("Customize" + ,(if (string-match "XEmacs" emacs-version) + '("Emacs" :filter (lambda (&rest junk) + (cdr (custom-menu-create 'emacs)))) + ["Update menu..." custom-menu-update t]) + ["Group..." customize t] + ["Variable..." customize-variable t] + ["Face..." customize-face t] + ["Saved..." customize-customized t] + ["Apropos..." customize-apropos t]) + "Customize menu") + +(defun custom-menu-reset () + "Reset customize menu." + (remove-hook 'custom-define-hook 'custom-menu-reset) + (if (string-match "XEmacs" emacs-version) + (when (fboundp 'add-submenu) + (add-submenu '("Options") custom-help-menu)) + (define-key global-map [menu-bar help-menu customize-menu] + (cons (car custom-help-menu) + (easy-menu-create-keymaps (car custom-help-menu) + (cdr custom-help-menu)))))) + +(if (string-match "XEmacs" emacs-version) + (autoload 'custom-menu-create "cus-edit") + (custom-menu-reset)) + +;;; The End. + +(provide 'custom) + +;; custom.el ends here diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el new file mode 100644 index 00000000000..d90836c05c4 --- /dev/null +++ b/lisp/wid-browse.el @@ -0,0 +1,232 @@ +;;; wid-browse.el --- Functions for browsing widgets. +;; +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: extensions +;; Version: 1.71 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; Widget browser. See `widget.el'. + +;;; Code: + +(require 'easymenu) +(require 'custom) +(require 'wid-edit) +(require 'cl) + +(defgroup widget-browse nil + "Customization support for browsing widgets." + :group 'widgets) + +;;; The Mode. + +(defvar widget-browse-mode-map nil + "Keymap for `widget-browse-mode'.") + +(unless widget-browse-mode-map + (setq widget-browse-mode-map (make-sparse-keymap)) + (set-keymap-parent widget-browse-mode-map widget-keymap)) + +(easy-menu-define widget-browse-mode-menu + widget-browse-mode-map + "Menu used in widget browser buffers." + '("Widget" + ["Browse" widget-browse t] + ["Browse At" widget-browse-at t])) + +(defcustom widget-browse-mode-hook nil + "Hook called when entering widget-browse-mode." + :type 'hook + :group 'widget-browse) + +(defun widget-browse-mode () + "Major mode for widget browser buffers. + +The following commands are available: + +\\[widget-forward] Move to next button or editable field. +\\[widget-backward] Move to previous button or editable field. +\\[widget-button-click] Activate button under the mouse pointer. +\\[widget-button-press] Activate button under point. + +Entry to this mode calls the value of `widget-browse-mode-hook' +if that value is non-nil." + (kill-all-local-variables) + (setq major-mode 'widget-browse-mode + mode-name "Widget") + (use-local-map widget-browse-mode-map) + (easy-menu-add widget-browse-mode-menu) + (run-hooks 'widget-browse-mode-hook)) + +;;; Commands. + +;;;###autoload +(defun widget-browse-at (pos) + "Browse the widget under point." + (interactive "d") + (let* ((field (get-text-property pos 'field)) + (button (get-text-property pos 'button)) + (doc (get-text-property pos 'widget-doc)) + (text (cond (field "This is an editable text area.") + (button "This is an active area.") + (doc "This is documentation text.") + (t "This is unidentified text."))) + (widget (or field button doc))) + (when widget + (widget-browse widget)) + (message text))) + +(defvar widget-browse-history nil) + +(defun widget-browse (widget) + "Create a widget browser for WIDGET." + (interactive (list (completing-read "Widget: " + obarray + (lambda (symbol) + (get symbol 'widget-type)) + t nil 'widget-browse-history))) + (if (stringp widget) + (setq widget (intern widget))) + (unless (if (symbolp widget) + (get widget 'widget-type) + (and (consp widget) + (get (widget-type widget) 'widget-type))) + (error "Not a widget.")) + ;; Create the buffer. + (if (symbolp widget) + (let ((buffer (format "*Browse %s Widget*" widget))) + (kill-buffer (get-buffer-create buffer)) + (switch-to-buffer (get-buffer-create buffer))) + (kill-buffer (get-buffer-create "*Browse Widget*")) + (switch-to-buffer (get-buffer-create "*Browse Widget*"))) + (widget-browse-mode) + + ;; Quick way to get out. + (widget-create 'push-button + :action (lambda (widget &optional event) + (bury-buffer)) + "Quit") + (widget-insert "\n") + + ;; Top text indicating whether it is a class or object browser. + (if (listp widget) + (widget-insert "Widget object browser.\n\nClass: ") + (widget-insert "Widget class browser.\n\n") + (widget-create 'widget-browse + :format "%[%v%]\n%d" + :doc (get widget 'widget-documentation) + widget) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\nSuper: ") + (setq widget (get widget 'widget-type))) + + ;; Now show the attributes. + (let ((name (car widget)) + (items (cdr widget)) + key value printer) + (widget-create 'widget-browse + :format "%[%v%]" + name) + (widget-insert "\n") + (while items + (setq key (nth 0 items) + value (nth 1 items) + printer (or (get key 'widget-keyword-printer) + 'widget-browse-sexp) + items (cdr (cdr items))) + (widget-insert "\n" (symbol-name key) "\n\t") + (funcall printer widget key value) + (widget-insert "\n"))) + (widget-setup) + (goto-char (point-min))) + +;;; The `widget-browse' Widget. + +(define-widget 'widget-browse 'push-button + "Button for creating a widget browser. +The :value of the widget shuld be the widget to be browsed." + :format "%[[%v]%]" + :value-create 'widget-browse-value-create + :action 'widget-browse-action) + +(defun widget-browse-action (widget &optional event) + ;; Create widget browser for WIDGET's :value. + (widget-browse (widget-get widget :value))) + +(defun widget-browse-value-create (widget) + ;; Insert type name. + (let ((value (widget-get widget :value))) + (cond ((symbolp value) + (insert (symbol-name value))) + ((consp value) + (insert (symbol-name (widget-type value)))) + (t + (insert "strange"))))) + +;;; Keyword Printer Functions. + +(defun widget-browse-widget (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a widget." + (widget-create 'widget-browse value)) + +(defun widget-browse-widgets (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a list of widgets." + (while value + (widget-create 'widget-browse + (car value)) + (setq value (cdr value)) + (when value + (widget-insert " ")))) + +(defun widget-browse-sexp (widget key value) + "Insert description of WIDGET's KEY VALUE. +Nothing is assumed about value." + (let ((pp (condition-case signal + (pp-to-string value) + (error (prin1-to-string signal))))) + (when (string-match "\n\\'" pp) + (setq pp (substring pp 0 (1- (length pp))))) + (if (cond ((string-match "\n" pp) + nil) + ((> (length pp) (- (window-width) (current-column))) + nil) + (t t)) + (widget-insert pp) + (widget-create 'push-button + :tag "show" + :action (lambda (widget &optional event) + (with-output-to-temp-buffer + "*Pp Eval Output*" + (princ (widget-get widget :value)))) + pp)))) + +(defun widget-browse-sexps (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a list of widgets." + (let ((target (current-column))) + (while value + (widget-browse-sexp widget key (car value)) + (setq value (cdr value)) + (when value + (widget-insert "\n" (make-string target ?\ )))))) + +;;; Keyword Printers. + +(put :parent 'widget-keyword-printer 'widget-browse-widget) +(put :children 'widget-keyword-printer 'widget-browse-widgets) +(put :buttons 'widget-keyword-printer 'widget-browse-widgets) +(put :button 'widget-keyword-printer 'widget-browse-widget) +(put :args 'widget-keyword-printer 'widget-browse-sexps) + +;;; The End: + +(provide 'wid-browse) + +;; wid-browse.el ends here diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el new file mode 100644 index 00000000000..283981d42f4 --- /dev/null +++ b/lisp/wid-edit.el @@ -0,0 +1,2542 @@ +;;; wid-edit.el --- Functions for creating and using widgets. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: extensions +;; Version: 1.71 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `widget.el'. + +;;; Code: + +(require 'widget) + +(eval-and-compile + (require 'cl)) + +;;; Compatibility. + +(eval-and-compile + (autoload 'pp-to-string "pp") + (autoload 'Info-goto-node "info") + + (when (string-match "XEmacs" emacs-version) + (condition-case nil + (require 'overlay) + (error (load-library "x-overlay")))) + + (if (string-match "XEmacs" emacs-version) + ;; XEmacs spell `intangible' as `atomic'. + (defun widget-make-intangible (from to side) + "Make text between FROM and TO atomic with regard to movement. +Third argument should be `start-open' if it should be sticky to the rear, +and `end-open' if it should sticky to the front." + (require 'atomic-extents) + (let ((ext (make-extent from to))) + ;; XEmacs doesn't understant different kinds of read-only, so + ;; we have to use extents instead. + (put-text-property from to 'read-only nil) + (set-extent-property ext 'read-only t) + (set-extent-property ext 'start-open nil) + (set-extent-property ext 'end-open nil) + (set-extent-property ext side t) + (set-extent-property ext 'atomic t))) + (defun widget-make-intangible (from to size) + "Make text between FROM and TO intangible." + (put-text-property from to 'intangible 'front))) + +;; The following should go away when bundled with Emacs. + (condition-case () + (require 'custom) + (error nil)) + + (unless (and (featurep 'custom) (fboundp 'custom-declare-variable)) + ;; We have the old custom-library, hack around it! + (defmacro defgroup (&rest args) nil) + (defmacro defcustom (var value doc &rest args) + `(defvar ,var ,value ,doc)) + (defmacro defface (&rest args) nil) + (define-widget-keywords :prefix :tag :load :link :options :type :group) + (when (fboundp 'copy-face) + (copy-face 'default 'widget-documentation-face) + (copy-face 'bold 'widget-button-face) + (copy-face 'italic 'widget-field-face))) + + (unless (fboundp 'event-point) + ;; XEmacs function missing in Emacs. + (defun event-point (event) + "Return the character position of the given mouse-motion, button-press, +or button-release event. If the event did not occur over a window, or did +not occur over text, then this returns nil. Otherwise, it returns an index +into the buffer visible in the event's window." + (posn-point (event-start event)))) + + (unless (fboundp 'error-message-string) + ;; Emacs function missing in XEmacs. + (defun error-message-string (obj) + "Convert an error value to an error message." + (let ((buf (get-buffer-create " *error-message*"))) + (erase-buffer buf) + (display-error obj buf) + (buffer-string buf))))) + +;;; Customization. + +(defgroup widgets nil + "Customization support for the Widget Library." + :link '(custom-manual "(widget)Top") + :link '(url-link :tag "Development Page" + "http://www.dina.kvl.dk/~abraham/custom/") + :prefix "widget-" + :group 'extensions + :group 'faces + :group 'hypermedia) + +(defface widget-documentation-face '((((class color) + (background dark)) + (:foreground "lime green")) + (((class color) + (background light)) + (:foreground "dark green")) + (t nil)) + "Face used for documentation text." + :group 'widgets) + +(defface widget-button-face '((t (:bold t))) + "Face used for widget buttons." + :group 'widgets) + +(defcustom widget-mouse-face 'highlight + "Face used for widget buttons when the mouse is above them." + :type 'face + :group 'widgets) + +(defface widget-field-face '((((class grayscale color) + (background light)) + (:background "light gray")) + (((class grayscale color) + (background dark)) + (:background "dark gray")) + (t + (:italic t))) + "Face used for editable fields." + :group 'widgets) + +(defcustom widget-menu-max-size 40 + "Largest number of items allowed in a popup-menu. +Larger menus are read through the minibuffer." + :group 'widgets + :type 'integer) + +;;; Utility functions. +;; +;; These are not really widget specific. + +(defsubst widget-plist-member (plist prop) + ;; Return non-nil if PLIST has the property PROP. + ;; PLIST is a property list, which is a list of the form + ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. + ;; Unlike `plist-get', this allows you to distinguish between a missing + ;; property and a property with the value nil. + ;; The value is actually the tail of PLIST whose car is PROP. + (while (and plist (not (eq (car plist) prop))) + (setq plist (cdr (cdr plist)))) + plist) + +(defun 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. + (save-excursion + (set-buffer (get-buffer-create " *widget-tmp*")) + (erase-buffer) + (let ((standard-output (current-buffer))) + (princ object)) + (buffer-string))) + +(defun widget-clear-undo () + "Clear all undo information." + (buffer-disable-undo (current-buffer)) + (buffer-enable-undo)) + +(defun widget-choose (title items &optional event) + "Choose an item from a list. + +First argument TITLE is the name of the list. +Second argument ITEMS is an alist (NAME . VALUE). +Optional third argument EVENT is an input event. + +The user is asked to choose between each NAME from the items alist, +and the VALUE of the chosen element will be returned. If EVENT is a +mouse event, and the number of elements in items is less than +`widget-menu-max-size', a popup menu will be used, otherwise the +minibuffer." + (cond ((and (< (length items) widget-menu-max-size) + event (fboundp 'x-popup-menu) window-system) + ;; We are in Emacs-19, pressed by the mouse + (x-popup-menu event + (list title (cons "" items)))) + ((and (< (length items) widget-menu-max-size) + event (fboundp 'popup-menu) window-system) + ;; We are in XEmacs, pressed by the mouse + (let ((val (get-popup-menu-response + (cons title + (mapcar + (function + (lambda (x) + (vector (car x) (list (car x)) t))) + items))))) + (setq val (and val + (listp (event-object val)) + (stringp (car-safe (event-object val))) + (car (event-object val)))) + (cdr (assoc val items)))) + (t + (let ((val (completing-read (concat title ": ") items nil t))) + (if (stringp val) + (let ((try (try-completion val items))) + (when (stringp try) + (setq val try)) + (cdr (assoc val items))) + nil))))) + +(defun widget-get-sibling (widget) + "Get the item WIDGET is assumed to toggle. +This is only meaningful for radio buttons or checkboxes in a list." + (let* ((parent (widget-get widget :parent)) + (children (widget-get parent :children)) + child) + (catch 'child + (while children + (setq child (car children) + children (cdr children)) + (when (eq (widget-get child :button) widget) + (throw 'child child))) + nil))) + +;;; Widget text specifications. +;; +;; These functions are for specifying text properties. + +(defun widget-specify-none (from to) + ;; Clear all text properties between FROM and TO. + (set-text-properties from to nil)) + +(defun widget-specify-text (from to) + ;; Default properties. + (add-text-properties from to (list 'read-only t + 'front-sticky t + 'start-open t + 'end-open t + 'rear-nonsticky nil))) + +(defun widget-specify-field (widget from to) + ;; Specify editable button for WIDGET between FROM and TO. + (widget-specify-field-update widget from to) + + ;; Make it possible to edit the front end of the field. + (add-text-properties (1- from) from (list 'rear-nonsticky t + 'end-open t + 'invisible t)) + (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format)) + (widget-get widget :hide-front-space)) + ;; WARNING: This is going to lose horrible if the character just + ;; before the field can be modified (e.g. if it belongs to a + ;; choice widget). We try to compensate by checking the format + ;; string, and hope the user hasn't changed the :create method. + (widget-make-intangible (- from 2) from 'end-open)) + + ;; Make it possible to edit back end of the field. + (add-text-properties to (1+ to) (list 'front-sticky nil + 'read-only t + 'start-open t)) + + (cond ((widget-get widget :size) + (put-text-property to (1+ to) 'invisible t) + (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format)) + (widget-get widget :hide-rear-space)) + ;; WARNING: This is going to lose horrible if the character just + ;; after the field can be modified (e.g. if it belongs to a + ;; choice widget). We try to compensate by checking the format + ;; string, and hope the user hasn't changed the :create method. + (widget-make-intangible to (+ to 2) 'start-open))) + ((string-match "XEmacs" emacs-version) + ;; XEmacs does not allow you to insert before a read-only + ;; character, even if it is start.open. + ;; XEmacs does allow you to delete an read-only extent, so + ;; making the terminating newline read only doesn't help. + ;; I tried putting an invisible intangible read-only space + ;; before the newline, which gave really weird effects. + ;; So for now, we just have trust the user not to delete the + ;; newline. + (put-text-property to (1+ to) 'read-only nil)))) + +(defun widget-specify-field-update (widget from to) + ;; Specify editable button for WIDGET between FROM and TO. + (let ((map (widget-get widget :keymap)) + (secret (widget-get widget :secret)) + (secret-to to) + (size (widget-get widget :size)) + (face (or (widget-get widget :value-face) + 'widget-field-face)) + (help-echo (widget-get widget :help-echo)) + (help-property (if (featurep 'balloon-help) + 'balloon-help + 'help-echo))) + (unless (or (stringp help-echo) (null help-echo)) + (setq help-echo 'widget-mouse-help)) + + (when secret + (while (and size + (not (zerop size)) + (> secret-to from) + (eq (char-after (1- secret-to)) ?\ )) + (setq secret-to (1- secret-to))) + + (save-excursion + (goto-char from) + (while (< (point) secret-to) + (let ((old (get-text-property (point) 'secret))) + (when old + (subst-char-in-region (point) (1+ (point)) secret old))) + (forward-char)))) + + (set-text-properties from to (list 'field widget + 'read-only nil + 'keymap map + 'local-map map + help-property help-echo + 'face face)) + + (when secret + (save-excursion + (goto-char from) + (while (< (point) secret-to) + (let ((old (following-char))) + (subst-char-in-region (point) (1+ (point)) old secret) + (put-text-property (point) (1+ (point)) 'secret old)) + (forward-char)))) + + (unless (widget-get widget :size) + (add-text-properties to (1+ to) (list 'field widget + help-property help-echo + 'face face))) + (add-text-properties to (1+ to) (list 'local-map map + 'keymap map)))) + +(defun widget-specify-button (widget from to) + ;; Specify button for WIDGET between FROM and TO. + (let ((face (widget-apply widget :button-face-get)) + (help-echo (widget-get widget :help-echo)) + (help-property (if (featurep 'balloon-help) + 'balloon-help + 'help-echo))) + (unless (or (null help-echo) (stringp help-echo)) + (setq help-echo 'widget-mouse-help)) + (add-text-properties from to (list 'button widget + 'mouse-face widget-mouse-face + 'start-open t + 'end-open t + help-property help-echo + 'face face)))) + +(defun widget-mouse-help (extent) + "Find mouse help string for button in extent." + (let* ((widget (widget-at (extent-start-position extent))) + (help-echo (and widget (widget-get widget :help-echo)))) + (cond ((stringp help-echo) + help-echo) + ((and (symbolp help-echo) (fboundp help-echo) + (stringp (setq help-echo (funcall help-echo widget)))) + help-echo) + (t + (format "(widget %S :help-echo %S)" widget help-echo))))) + +(defun widget-specify-sample (widget from to) + ;; Specify sample for WIDGET between FROM and TO. + (let ((face (widget-apply widget :sample-face-get))) + (when face + (add-text-properties from to (list 'start-open t + 'end-open t + 'face face))))) + +(defun widget-specify-doc (widget from to) + ;; Specify documentation for WIDGET between FROM and TO. + (add-text-properties from to (list 'widget-doc widget + 'face 'widget-documentation-face))) + +(defmacro widget-specify-insert (&rest form) + ;; Execute FORM without inheriting any text properties. + `(save-restriction + (let ((inhibit-read-only t) + result + after-change-functions) + (insert "<>") + (narrow-to-region (- (point) 2) (point)) + (widget-specify-none (point-min) (point-max)) + (goto-char (1+ (point-min))) + (setq result (progn ,@form)) + (delete-region (point-min) (1+ (point-min))) + (delete-region (1- (point-max)) (point-max)) + (goto-char (point-max)) + result))) + +(defface widget-inactive-face '((((class grayscale color) + (background dark)) + (:foreground "light gray")) + (((class grayscale color) + (background light)) + (:foreground "dark gray")) + (t + (:italic t))) + "Face used for inactive widgets." + :group 'widgets) + +(defun widget-specify-inactive (widget from to) + "Make WIDGET inactive for user modifications." + (unless (widget-get widget :inactive) + (let ((overlay (make-overlay from to nil t nil))) + (overlay-put overlay 'face 'widget-inactive-face) + (overlay-put overlay 'evaporate 't) + (overlay-put overlay (if (string-match "XEmacs" emacs-version) + 'read-only + 'modification-hooks) '(widget-overlay-inactive)) + (widget-put widget :inactive overlay)))) + +(defun widget-overlay-inactive (&rest junk) + "Ignoring the arguments, signal an error." + (unless inhibit-read-only + (error "Attempt to modify inactive widget"))) + + +(defun widget-specify-active (widget) + "Make WIDGET active for user modifications." + (let ((inactive (widget-get widget :inactive))) + (when inactive + (delete-overlay inactive) + (widget-put widget :inactive nil)))) + +;;; Widget Properties. + +(defsubst widget-type (widget) + "Return the type of WIDGET, a symbol." + (car widget)) + +(defun widget-put (widget property value) + "In WIDGET set PROPERTY to VALUE. +The value can later be retrived with `widget-get'." + (setcdr widget (plist-put (cdr widget) property value))) + +(defun widget-get (widget property) + "In WIDGET, get the value of PROPERTY. +The value could either be specified when the widget was created, or +later with `widget-put'." + (let ((missing t) + value tmp) + (while missing + (cond ((setq tmp (widget-plist-member (cdr widget) property)) + (setq value (car (cdr tmp)) + missing nil)) + ((setq tmp (car widget)) + (setq widget (get tmp 'widget-type))) + (t + (setq missing nil)))) + value)) + +(defun widget-member (widget property) + "Non-nil iff there is a definition in WIDGET for PROPERTY." + (cond ((widget-plist-member (cdr widget) property) + t) + ((car widget) + (widget-member (get (car widget) 'widget-type) property)) + (t nil))) + +;;;###autoload +(defun widget-apply (widget property &rest args) + "Apply the value of WIDGET's PROPERTY to the widget itself. +ARGS are passed as extra arguments to the function." + (apply (widget-get widget property) widget args)) + +(defun widget-value (widget) + "Extract the current value of WIDGET." + (widget-apply widget + :value-to-external (widget-apply widget :value-get))) + +(defun widget-value-set (widget value) + "Set the current value of WIDGET to VALUE." + (widget-apply widget + :value-set (widget-apply widget + :value-to-internal value))) + +(defun widget-match-inline (widget vals) + ;; In WIDGET, match the start of VALS. + (cond ((widget-get widget :inline) + (widget-apply widget :match-inline vals)) + ((and vals + (widget-apply widget :match (car vals))) + (cons (list (car vals)) (cdr vals))) + (t nil))) + +(defun widget-apply-action (widget &optional event) + "Apply :action in WIDGET in response to EVENT." + (if (widget-apply widget :active) + (widget-apply widget :action event) + (error "Attempt to perform action on inactive widget"))) + +;;; 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) + "In WIDGET, with alternative text TAG, insert GLYPH." + (set-glyph-image glyph (cons 'tty tag)) + (set-glyph-property glyph 'widget widget) + (insert "*") + (add-text-properties (1- (point)) (point) + (list 'invisible t + 'end-glyph glyph)) + (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)))))) + +;;; Creating Widgets. + +;;;###autoload +(defun widget-create (type &rest args) + "Create widget of TYPE. +The optional ARGS are additional keyword arguments." + (let ((widget (apply 'widget-convert type args))) + (widget-apply widget :create) + widget)) + +(defun widget-create-child-and-convert (parent type &rest args) + "As part of the widget PARENT, create a child widget TYPE. +The child is converted, 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-get parent :offset)))) + (widget-apply widget :create) + widget)) + +(defun widget-create-child (parent type) + "Create widget of TYPE." + (let ((widget (copy-list 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." + (let ((widget (copy-list 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) + (or (widget-get widget :extra-offset) 0) + (widget-get parent :offset)))) + (widget-apply widget :create) + widget)) + +;;;###autoload +(defun widget-delete (widget) + "Delete WIDGET." + (widget-apply widget :delete)) + +(defun widget-convert (type &rest args) + "Convert TYPE to a widget without inserting it in the buffer. +The optional ARGS are additional keyword arguments." + ;; Don't touch the type. + (let* ((widget (if (symbolp type) + (list type) + (copy-list type))) + (current widget) + (keys args)) + ;; First set the :args keyword. + (while (cdr current) ;Look in the type. + (let ((next (car (cdr current)))) + (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) + (setq current (cdr (cdr current))) + (setcdr current (list :args (cdr current))) + (setq current nil)))) + (while args ;Look in the args. + (let ((next (nth 0 args))) + (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) + (setq args (nthcdr 2 args)) + (widget-put widget :args args) + (setq args nil)))) + ;; Then Convert the widget. + (setq type widget) + (while type + (let ((convert-widget (plist-get (cdr type) :convert-widget))) + (if convert-widget + (setq widget (funcall convert-widget widget)))) + (setq type (get (car type) 'widget-type))) + ;; Finally set the keyword args. + (while keys + (let ((next (nth 0 keys))) + (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) + (progn + (widget-put widget next (nth 1 keys)) + (setq keys (nthcdr 2 keys))) + (setq keys nil)))) + ;; Convert the :value to internal format. + (if (widget-member widget :value) + (let ((value (widget-get widget :value))) + (widget-put widget + :value (widget-apply widget :value-to-internal value)))) + ;; Return the newly create widget. + widget)) + +(defun widget-insert (&rest args) + "Call `insert' with ARGS and make the text read only." + (let ((inhibit-read-only t) + after-change-functions + (from (point))) + (apply 'insert args) + (widget-specify-text from (point)))) + +;;; Keymap and Commands. + +(defvar widget-keymap nil + "Keymap containing useful binding for buffers containing widgets. +Recommended as a parent keymap for modes using widgets.") + +(unless widget-keymap + (setq widget-keymap (make-sparse-keymap)) + (define-key widget-keymap "\C-k" 'widget-kill-line) + (define-key widget-keymap "\t" 'widget-forward) + (define-key widget-keymap "\M-\t" 'widget-backward) + (define-key widget-keymap [(shift tab)] 'widget-backward) + (define-key widget-keymap [backtab] 'widget-backward) + (if (string-match "XEmacs" (emacs-version)) + (progn + (define-key widget-keymap [button2] 'widget-button-click) + (define-key widget-keymap [button1] 'widget-button1-click)) + (define-key widget-keymap [mouse-2] 'ignore) + (define-key widget-keymap [down-mouse-2] 'widget-button-click)) + (define-key widget-keymap "\C-m" 'widget-button-press)) + +(defvar widget-global-map global-map + "Keymap used for events the widget does not handle themselves.") +(make-variable-buffer-local 'widget-global-map) + +(defvar widget-field-keymap nil + "Keymap used inside an editable field.") + +(unless widget-field-keymap + (setq widget-field-keymap (copy-keymap widget-keymap)) + (unless (string-match "XEmacs" (emacs-version)) + (define-key widget-field-keymap [menu-bar] 'nil)) + (define-key widget-field-keymap "\C-m" 'widget-field-activate) + (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line) + (define-key widget-field-keymap "\C-e" 'widget-end-of-line) + (set-keymap-parent widget-field-keymap global-map)) + +(defvar widget-text-keymap nil + "Keymap used inside a text field.") + +(unless widget-text-keymap + (setq widget-text-keymap (copy-keymap widget-keymap)) + (unless (string-match "XEmacs" (emacs-version)) + (define-key widget-text-keymap [menu-bar] 'nil)) + (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 + (lookup-key widget-global-map (this-command-keys)))))) + +(defun widget-button-click (event) + "Activate button below mouse pointer." + (interactive "@e") + (cond ((and (fboundp 'event-glyph) + (event-glyph event)) + (let ((widget (glyph-property (event-glyph event) 'widget))) + (if widget + (widget-apply-action widget event) + (message "You clicked on a glyph.")))) + ((event-point event) + (let ((button (get-text-property (event-point event) 'button))) + (if button + (widget-apply-action button event) + (call-interactively + (or (lookup-key widget-global-map [ button2 ]) + (lookup-key widget-global-map [ down-mouse-2 ]) + (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)) + (let ((widget (glyph-property (event-glyph event) 'widget))) + (if widget + (widget-apply-action widget event) + (message "You clicked on a glyph."))) + (call-interactively (lookup-key widget-global-map (this-command-keys))))) + +(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)))) + (when (commandp command) + (call-interactively command)))))) + +(defun widget-move (arg) + "Move point to the ARG next field or button. +ARG may be negative to move backward." + (while (> arg 0) + (setq arg (1- arg)) + (let ((next (cond ((get-text-property (point) 'button) + (next-single-property-change (point) 'button)) + ((get-text-property (point) 'field) + (next-single-property-change (point) 'field)) + (t + (point))))) + (if (null next) ; Widget extends to end. of buffer + (setq next (point-min))) + (let ((button (next-single-property-change next 'button)) + (field (next-single-property-change next 'field))) + (cond ((or (get-text-property next 'button) + (get-text-property next 'field)) + (goto-char next)) + ((and button field) + (goto-char (min button field))) + (button (goto-char button)) + (field (goto-char field)) + (t + (let ((button (next-single-property-change (point-min) 'button)) + (field (next-single-property-change (point-min) 'field))) + (cond ((and button field) (goto-char (min button field))) + (button (goto-char button)) + (field (goto-char field)) + (t + (error "No buttons or fields found")))))) + (setq button (widget-at (point))) + (if (and button (widget-get button :tab-order) + (< (widget-get button :tab-order) 0)) + (setq arg (1+ arg)))))) + (while (< arg 0) + (if (= (point-min) (point)) + (forward-char 1)) + (setq arg (1+ arg)) + (let ((previous (cond ((get-text-property (1- (point)) 'button) + (previous-single-property-change (point) 'button)) + ((get-text-property (1- (point)) 'field) + (previous-single-property-change (point) 'field)) + (t + (point))))) + (if (null previous) ; Widget extends to beg. of buffer + (setq previous (point-max))) + (let ((button (previous-single-property-change previous 'button)) + (field (previous-single-property-change previous 'field))) + (cond ((and button field) + (goto-char (max button field))) + (button (goto-char button)) + (field (goto-char field)) + (t + (let ((button (previous-single-property-change + (point-max) 'button)) + (field (previous-single-property-change + (point-max) 'field))) + (cond ((and button field) (goto-char (max button field))) + (button (goto-char button)) + (field (goto-char field)) + (t + (error "No buttons or fields found")))))))) + (let ((button (previous-single-property-change (point) 'button)) + (field (previous-single-property-change (point) 'field))) + (cond ((and button field) + (goto-char (max button field))) + (button (goto-char button)) + (field (goto-char field))) + (setq button (widget-at (point))) + (if (and button (widget-get button :tab-order) + (< (widget-get button :tab-order) 0)) + (setq arg (1- arg))))) + (widget-echo-help (point)) + (run-hooks 'widget-move-hook)) + +(defun widget-forward (arg) + "Move point to the next field or button. +With optional ARG, move across that many fields." + (interactive "p") + (run-hooks 'widget-forward-hook) + (widget-move arg)) + +(defun widget-backward (arg) + "Move point to the previous field or button. +With optional ARG, move across that many fields." + (interactive "p") + (run-hooks 'widget-backward-hook) + (widget-move (- arg))) + +(defun widget-beginning-of-line () + "Go to beginning of field or beginning of line, whichever is first." + (interactive) + (let ((bol (save-excursion (beginning-of-line) (point))) + (prev (previous-single-property-change (point) 'field))) + (goto-char (max bol (or prev bol))))) + +(defun widget-end-of-line () + "Go to end of field or end of line, whichever is first." + (interactive) + (let ((bol (save-excursion (end-of-line) (point))) + (prev (next-single-property-change (point) 'field))) + (goto-char (min bol (or prev bol))))) + +(defun widget-kill-line () + "Kill to end of field or end of line, whichever is first." + (interactive) + (let ((field (get-text-property (point) 'field)) + (newline (save-excursion (search-forward "\n"))) + (next (next-single-property-change (point) 'field))) + (if (and field (> newline next)) + (kill-region (point) next) + (call-interactively 'kill-line)))) + +;;; Setting up the buffer. + +(defvar widget-field-new nil) +;; List of all newly created editable fields in the buffer. +(make-variable-buffer-local 'widget-field-new) + +(defvar widget-field-list nil) +;; List of all editable fields in the buffer. +(make-variable-buffer-local 'widget-field-list) + +(defun widget-setup () + "Setup current buffer so editing string widgets works." + (let ((inhibit-read-only t) + (after-change-functions nil) + field) + (while widget-field-new + (setq field (car widget-field-new) + widget-field-new (cdr widget-field-new) + widget-field-list (cons field widget-field-list)) + (let ((from (widget-get field :value-from)) + (to (widget-get field :value-to))) + (widget-specify-field field from to) + (move-marker from (1- from)) + (move-marker to (1+ to))))) + (widget-clear-undo) + ;; We need to maintain text properties and size of the editing fields. + (make-local-variable 'after-change-functions) + (if widget-field-list + (setq after-change-functions '(widget-after-change)) + (setq after-change-functions nil))) + +(defvar widget-field-last nil) +;; Last field containing point. +(make-variable-buffer-local 'widget-field-last) + +(defvar widget-field-was nil) +;; The widget data before the change. +(make-variable-buffer-local 'widget-field-was) + +(defun widget-field-find (pos) + ;; Find widget whose editing field is located at POS. + ;; Return nil if POS is not inside and editing field. + ;; + ;; This is only used in `widget-field-modified', since ordinarily + ;; you would just test the field property. + (let ((fields widget-field-list) + field found) + (while fields + (setq field (car fields) + fields (cdr fields)) + (let ((from (widget-get field :value-from)) + (to (widget-get field :value-to))) + (if (and from to (< from pos) (> to pos)) + (setq fields nil + found field)))) + found)) + +(defun widget-after-change (from to old) + ;; Adjust field size and text properties. + (condition-case nil + (let ((field (widget-field-find from)) + (inhibit-read-only t)) + (cond ((null field)) + ((not (eq field (widget-field-find to))) + (debug) + (message "Error: `widget-after-change' called on two fields")) + (t + (let ((size (widget-get field :size))) + (if size + (let ((begin (1+ (widget-get field :value-from))) + (end (1- (widget-get field :value-to)))) + (widget-specify-field-update field begin end) + (cond ((< (- end begin) size) + ;; Field too small. + (save-excursion + (goto-char end) + (insert-char ?\ (- (+ begin size) end)) + (widget-specify-field-update field + begin + (+ begin size)))) + ((> (- end begin) size) + ;; Field too large and + (if (or (< (point) (+ begin size)) + (> (point) end)) + ;; Point is outside extra space. + (setq begin (+ begin size)) + ;; Point is within the extra space. + (setq begin (point))) + (save-excursion + (goto-char end) + (while (and (eq (preceding-char) ?\ ) + (> (point) begin)) + (delete-backward-char 1)))))) + (widget-specify-field-update field from to))) + (widget-apply field :notify field)))) + (error (debug)))) + +;;; Widget Functions +;; +;; These functions are used in the definition of multiple widgets. + +(defun widget-children-value-delete (widget) + "Delete all :children and :buttons in WIDGET." + (mapcar 'widget-delete (widget-get widget :children)) + (widget-put widget :children nil) + (mapcar 'widget-delete (widget-get widget :buttons)) + (widget-put widget :buttons nil)) + +(defun widget-types-convert-widget (widget) + "Convert :args as widget types in WIDGET." + (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) + widget) + +;;; The `default' Widget. + +(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 + :sample-face-get 'widget-default-sample-face-get + :delete 'widget-default-delete + :value-set 'widget-default-value-set + :value-inline 'widget-default-value-inline + :menu-tag-get 'widget-default-menu-tag-get + :validate (lambda (widget) nil) + :active 'widget-default-active + :activate 'widget-specify-active + :deactivate 'widget-default-deactivate + :action 'widget-default-action + :notify 'widget-default-notify) + +(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)) + (goto-char from) + ;; Parse escapes in format. + (while (re-search-forward "%\\(.\\)" nil t) + (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 + (widget-apply widget :format-handler escape))))) + ;; Specify button, sample, and doc, and insert value. + (and button-begin button-end + (widget-specify-button widget button-begin button-end)) + (and sample-begin sample-end + (widget-specify-sample widget sample-begin sample-end)) + (and doc-begin doc-end + (widget-specify-doc widget doc-begin doc-end)) + (when value-pos + (goto-char value-pos) + (widget-apply widget :value-create))) + (let ((from (copy-marker (point-min))) + (to (copy-marker (point-max)))) + (widget-specify-text from to) + (set-marker-insertion-type from t) + (set-marker-insertion-type to nil) + (widget-put widget :from from) + (widget-put widget :to to)))) + +(defun widget-default-format-handler (widget escape) + ;; We recognize the %h escape by default. + (let* ((buttons (widget-get widget :buttons)) + (doc-property (widget-get widget :documentation-property)) + (doc-try (cond ((widget-get widget :doc)) + ((symbolp doc-property) + (documentation-property (widget-get widget :value) + doc-property)) + (t + (funcall doc-property (widget-get widget :value))))) + (doc-text (and (stringp doc-try) + (> (length doc-try) 1) + doc-try))) + (cond ((eq escape ?h) + (when doc-text + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + ;; The `*' in the beginning is redundant. + (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 (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) + ;; Use :button-face or widget-button-face + (or (widget-get widget :button-face) 'widget-button-face)) + +(defun widget-default-sample-face-get (widget) + ;; Use :sample-face. + (widget-get widget :sample-face)) + +(defun widget-default-delete (widget) + ;; Remove widget from the buffer. + (let ((from (widget-get widget :from)) + (to (widget-get widget :to)) + (inhibit-read-only t) + after-change-functions) + (widget-apply widget :value-delete) + (when (< from to) + ;; Kludge: this doesn't need to be true for empty formats. + (delete-region from to)) + (set-marker from nil) + (set-marker to nil))) + +(defun widget-default-value-set (widget value) + ;; Recreate widget with new value. + (save-excursion + (goto-char (widget-get widget :from)) + (widget-apply widget :delete) + (widget-put widget :value value) + (widget-apply widget :create))) + +(defun widget-default-value-inline (widget) + ;; Wrap value in a list unless it is inline. + (if (widget-get widget :inline) + (widget-value widget) + (list (widget-value widget)))) + +(defun widget-default-menu-tag-get (widget) + ;; Use tag or value for menus. + (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)." + (and (not (widget-get widget :inactive)) + (let ((parent (widget-get widget :parent))) + (or (null parent) + (widget-apply parent :active))))) + +(defun widget-default-deactivate (widget) + "Make WIDGET inactive for user modifications." + (widget-specify-inactive widget + (widget-get widget :from) + (widget-get widget :to))) + +(defun widget-default-action (widget &optional event) + ;; Notify the parent when a widget change + (let ((parent (widget-get widget :parent))) + (when parent + (widget-apply parent :notify widget event)))) + +(defun widget-default-notify (widget child &optional event) + ;; Pass notification to parent. + (widget-default-action widget event)) + +;;; The `item' Widget. + +(define-widget 'item 'default + "Constant items for inclusion in other widgets." + :convert-widget 'widget-item-convert-widget + :value-create 'widget-item-value-create + :value-delete 'ignore + :value-get 'widget-item-value-get + :match 'widget-item-match + :match-inline 'widget-item-match-inline + :action 'widget-item-action + :format "%t\n") + +(defun widget-item-convert-widget (widget) + ;; Initialize :value from :args in WIDGET. + (let ((args (widget-get widget :args))) + (when args + (widget-put widget :value (widget-apply widget + :value-to-internal (car args))) + (widget-put widget :args nil))) + widget) + +(defun widget-item-value-create (widget) + ;; Insert the printed representation of the value. + (let ((standard-output (current-buffer))) + (princ (widget-get widget :value)))) + +(defun widget-item-match (widget value) + ;; Match if the value is the same. + (equal (widget-get widget :value) value)) + +(defun widget-item-match-inline (widget values) + ;; Match if the value is the same. + (let ((value (widget-get widget :value))) + (and (listp value) + (<= (length value) (length values)) + (let ((head (subseq values 0 (length value)))) + (and (equal head value) + (cons head (subseq values (length value)))))))) + +(defun widget-item-action (widget &optional event) + ;; Just notify itself. + (widget-apply widget :notify widget event)) + +(defun widget-item-value-get (widget) + ;; Items are simple. + (widget-get widget :value)) + +;;; The `push-button' Widget. + +(defcustom widget-push-button-gui t + "If non nil, use GUI push buttons when available." + :group 'widgets + :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 + :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 "[" 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) + (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 (car (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." + :action 'widget-info-link-action) + +(defun widget-info-link-action (widget &optional event) + "Open the info node specified by WIDGET." + (Info-goto-node (widget-value widget))) + +;;; The `url-link' Widget. + +(define-widget 'url-link 'link + "A link to an www page." + :action 'widget-url-link-action) + +(defun widget-url-link-action (widget &optional event) + "Open the url specified by WIDGET." + (require 'browse-url) + (funcall browse-url-browser-function (widget-value widget))) + +;;; The `editable-field' Widget. + +(define-widget 'editable-field 'default + "An editable text field." + :convert-widget 'widget-item-convert-widget + :keymap widget-field-keymap + :format "%v" + :value "" + :action 'widget-field-action + :validate 'widget-field-validate + :valid-regexp "" + :error "No match" + :value-create 'widget-field-value-create + :value-delete 'widget-field-value-delete + :value-get 'widget-field-value-get + :match 'widget-field-match) + +;; History of field minibuffer edits. +(defvar widget-field-history nil) + +(defun widget-field-action (widget &optional event) + ;; Edit the value in the minibuffer. + (let ((tag (widget-apply widget :menu-tag-get)) + (invalid (widget-apply widget :validate))) + (when invalid + (error (widget-get invalid :error))) + (widget-value-set widget + (widget-apply widget + :value-to-external + (read-string (concat tag ": ") + (widget-apply + widget + :value-to-internal + (widget-value widget)) + 'widget-field-history))) + (widget-apply widget :notify widget event) + (widget-setup))) + +(defun widget-field-validate (widget) + ;; Valid if the content matches `:valid-regexp'. + (save-excursion + (let ((value (widget-apply widget :value-get)) + (regexp (widget-get widget :valid-regexp))) + (if (string-match regexp value) + nil + widget)))) + +(defun widget-field-value-create (widget) + ;; Create an editable text field. + (insert " ") + (let ((size (widget-get widget :size)) + (value (widget-get widget :value)) + (from (point))) + (insert value) + (and size + (< (length value) size) + (insert-char ?\ (- size (length value)))) + (unless (memq widget widget-field-list) + (setq widget-field-new (cons widget widget-field-new))) + (widget-put widget :value-to (copy-marker (point))) + (set-marker-insertion-type (widget-get widget :value-to) nil) + (if (null size) + (insert ?\n) + (insert ?\ )) + (widget-put widget :value-from (copy-marker from)) + (set-marker-insertion-type (widget-get widget :value-from) t))) + +(defun widget-field-value-delete (widget) + ;; Remove the widget from the list of active editing fields. + (setq widget-field-list (delq widget widget-field-list)) + ;; These are nil if the :format string doesn't contain `%v'. + (when (widget-get widget :value-from) + (set-marker (widget-get widget :value-from) nil)) + (when (widget-get widget :value-from) + (set-marker (widget-get widget :value-to) nil))) + +(defun widget-field-value-get (widget) + ;; Return current text in editing field. + (let ((from (widget-get widget :value-from)) + (to (widget-get widget :value-to)) + (size (widget-get widget :size)) + (secret (widget-get widget :secret)) + (old (current-buffer))) + (if (and from to) + (progn + (set-buffer (marker-buffer from)) + (setq from (1+ from) + to (1- to)) + (while (and size + (not (zerop size)) + (> to from) + (eq (char-after (1- to)) ?\ )) + (setq to (1- to))) + (let ((result (buffer-substring-no-properties from to))) + (when secret + (let ((index 0)) + (while (< (+ from index) to) + (aset result index + (get-text-property (+ from index) 'secret)) + (setq index (1+ index))))) + (set-buffer old) + result)) + (widget-get widget :value)))) + +(defun widget-field-match (widget value) + ;; Match any string. + (stringp value)) + +;;; The `text' Widget. + +(define-widget 'text 'editable-field + :keymap widget-text-keymap + "A multiline text area.") + +;;; The `menu-choice' Widget. + +(define-widget 'menu-choice 'default + "A menu of options." + :convert-widget 'widget-types-convert-widget + :format "%[%t%]: %v" + :case-fold t + :tag "choice" + :void '(item :format "invalid (%t)\n") + :value-create 'widget-choice-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-choice-value-get + :value-inline 'widget-choice-value-inline + :action 'widget-choice-action + :error "Make a choice" + :validate 'widget-choice-validate + :match 'widget-choice-match + :match-inline 'widget-choice-match-inline) + +(defun widget-choice-value-create (widget) + ;; Insert the first choice that matches the value. + (let ((value (widget-get widget :value)) + (args (widget-get widget :args)) + current) + (while args + (setq current (car args) + args (cdr args)) + (when (widget-apply current :match value) + (widget-put widget :children (list (widget-create-child-value + widget current value))) + (widget-put widget :choice current) + (setq args nil + current nil))) + (when current + (let ((void (widget-get widget :void))) + (widget-put widget :children (list (widget-create-child-and-convert + widget void :value value))) + (widget-put widget :choice void))))) + +(defun widget-choice-value-get (widget) + ;; Get value of the child widget. + (widget-value (car (widget-get widget :children)))) + +(defun widget-choice-value-inline (widget) + ;; Get value of the child widget. + (widget-apply (car (widget-get widget :children)) :value-inline)) + +(defun widget-choice-action (widget &optional event) + ;; Make a choice. + (let ((args (widget-get widget :args)) + (old (widget-get widget :choice)) + (tag (widget-apply widget :menu-tag-get)) + (completion-ignore-case (widget-get widget :case-fold)) + current choices) + ;; Remember old value. + (if (and old (not (widget-apply widget :validate))) + (let* ((external (widget-value widget)) + (internal (widget-apply old :value-to-internal external))) + (widget-put old :value internal))) + ;; Find new choice. + (setq current + (cond ((= (length args) 0) + nil) + ((= (length args) 1) + (nth 0 args)) + ((and (= (length args) 2) + (memq old args)) + (if (eq old (nth 0 args)) + (nth 1 args) + (nth 0 args))) + (t + (while args + (setq current (car args) + args (cdr args)) + (setq choices + (cons (cons (widget-apply current :menu-tag-get) + current) + choices))) + (widget-choose tag (reverse choices) event)))) + (when current + (widget-value-set widget + (widget-apply current :value-to-external + (widget-get current :value))) + (widget-apply widget :notify widget event) + (widget-setup))) + ;; Notify parent. + (widget-apply widget :notify widget event) + (widget-clear-undo)) + +(defun widget-choice-validate (widget) + ;; Valid if we have made a valid choice. + (let ((void (widget-get widget :void)) + (choice (widget-get widget :choice)) + (child (car (widget-get widget :children)))) + (if (eq void choice) + widget + (widget-apply child :validate)))) + +(defun widget-choice-match (widget value) + ;; Matches if one of the choices matches. + (let ((args (widget-get widget :args)) + current found) + (while (and args (not found)) + (setq current (car args) + args (cdr args) + found (widget-apply current :match value))) + found)) + +(defun widget-choice-match-inline (widget values) + ;; Matches if one of the choices matches. + (let ((args (widget-get widget :args)) + current found) + (while (and args (null found)) + (setq current (car args) + args (cdr args) + found (widget-match-inline current values))) + found)) + +;;; The `toggle' Widget. + +(define-widget 'toggle 'item + "Toggle between two states." + :format "%[%v%]\n" + :value-create 'widget-toggle-value-create + :action 'widget-toggle-action + :match (lambda (widget value) t) + :on "on" + :off "off") + +(defun widget-toggle-value-create (widget) + ;; Insert text representing the `on' and `off' states. + (if (widget-value widget) + (widget-glyph-insert widget + (widget-get widget :on) + (widget-get widget :on-glyph)) + (widget-glyph-insert widget + (widget-get widget :off) + (widget-get widget :off-glyph)))) + +(defun widget-toggle-action (widget &optional event) + ;; Toggle value. + (widget-value-set widget (not (widget-value widget))) + (widget-apply widget :notify widget event)) + +;;; The `checkbox' Widget. + +(define-widget 'checkbox 'toggle + "A checkbox toggle." + :format "%[%v%]" + :on "[X]" + :on-glyph "check1" + :off "[ ]" + :off-glyph "check0" + :action 'widget-checkbox-action) + +(defun widget-checkbox-action (widget &optional event) + "Toggle checkbox, notify parent, and set active state of sibling." + (widget-toggle-action widget event) + (let ((sibling (widget-get-sibling widget))) + (when sibling + (if (widget-value widget) + (widget-apply sibling :activate) + (widget-apply sibling :deactivate))))) + +;;; The `checklist' Widget. + +(define-widget 'checklist 'default + "A multiple choice widget." + :convert-widget 'widget-types-convert-widget + :format "%v" + :offset 4 + :entry-format "%b %v" + :menu-tag "checklist" + :greedy nil + :value-create 'widget-checklist-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-checklist-value-get + :validate 'widget-checklist-validate + :match 'widget-checklist-match + :match-inline 'widget-checklist-match-inline) + +(defun widget-checklist-value-create (widget) + ;; Insert all values + (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) + (args (widget-get widget :args))) + (while args + (widget-checklist-add-item widget (car args) (assq (car args) alist)) + (setq args (cdr args))) + (widget-put widget :children (nreverse (widget-get widget :children))))) + +(defun widget-checklist-add-item (widget type chosen) + ;; Create checklist item in WIDGET of type TYPE. + ;; If the item is checked, CHOSEN is a cons whose cdr is the value. + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (widget-specify-insert + (let* ((children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + (button-args (or (widget-get type :sibling-args) + (widget-get widget :button-args))) + (from (point)) + child button) + (insert (widget-get widget :entry-format)) + (goto-char from) + ;; Parse % escapes in format. + (while (re-search-forward "%\\([bv%]\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?b) + (setq button (apply 'widget-create-child-and-convert + widget 'checkbox + :value (not (null chosen)) + button-args))) + ((eq escape ?v) + (setq child + (cond ((not chosen) + (let ((child (widget-create-child widget type))) + (widget-apply child :deactivate) + child)) + ((widget-get type :inline) + (widget-create-child-value + widget type (cdr chosen))) + (t + (widget-create-child-value + widget type (car (cdr chosen))))))) + (t + (error "Unknown escape `%c'" escape))))) + ;; Update properties. + (and button child (widget-put child :button button)) + (and button (widget-put widget :buttons (cons button buttons))) + (and child (widget-put widget :children (cons child children)))))) + +(defun widget-checklist-match (widget values) + ;; All values must match a type in the checklist. + (and (listp values) + (null (cdr (widget-checklist-match-inline widget values))))) + +(defun widget-checklist-match-inline (widget values) + ;; Find the values which match a type in the checklist. + (let ((greedy (widget-get widget :greedy)) + (args (copy-list (widget-get widget :args))) + found rest) + (while values + (let ((answer (widget-checklist-match-up args values))) + (cond (answer + (let ((vals (widget-match-inline answer values))) + (setq found (append found (car vals)) + values (cdr vals) + args (delq answer args)))) + (greedy + (setq rest (append rest (list (car values))) + values (cdr values))) + (t + (setq rest (append rest values) + values nil))))) + (cons found rest))) + +(defun widget-checklist-match-find (widget vals) + ;; Find the vals which match a type in the checklist. + ;; Return an alist of (TYPE MATCH). + (let ((greedy (widget-get widget :greedy)) + (args (copy-list (widget-get widget :args))) + found) + (while vals + (let ((answer (widget-checklist-match-up args vals))) + (cond (answer + (let ((match (widget-match-inline answer vals))) + (setq found (cons (cons answer (car match)) found) + vals (cdr match) + args (delq answer args)))) + (greedy + (setq vals (cdr vals))) + (t + (setq vals nil))))) + found)) + +(defun widget-checklist-match-up (args vals) + ;; Rerturn the first type from ARGS that matches VALS. + (let (current found) + (while (and args (null found)) + (setq current (car args) + args (cdr args) + found (widget-match-inline current vals))) + (if found + current + nil))) + +(defun widget-checklist-value-get (widget) + ;; The values of all selected items. + (let ((children (widget-get widget :children)) + child result) + (while children + (setq child (car children) + children (cdr children)) + (if (widget-value (widget-get child :button)) + (setq result (append result (widget-apply child :value-inline))))) + result)) + +(defun widget-checklist-validate (widget) + ;; Ticked chilren must be valid. + (let ((children (widget-get widget :children)) + child button found) + (while (and children (not found)) + (setq child (car children) + children (cdr children) + button (widget-get child :button) + found (and (widget-value button) + (widget-apply child :validate)))) + found)) + +;;; The `option' Widget + +(define-widget 'option 'checklist + "An widget with an optional item." + :inline t) + +;;; The `choice-item' Widget. + +(define-widget 'choice-item 'item + "Button items that delegate action events to their parents." + :action 'widget-choice-item-action + :format "%[%t%] \n") + +(defun widget-choice-item-action (widget &optional event) + ;; Tell parent what happened. + (widget-apply (widget-get widget :parent) :action event)) + +;;; The `radio-button' Widget. + +(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") + +(defun widget-radio-button-notify (widget child &optional event) + ;; Tell daddy. + (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." + :convert-widget 'widget-types-convert-widget + :offset 4 + :format "%v" + :entry-format "%b %v" + :menu-tag "radio" + :value-create 'widget-radio-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-radio-value-get + :value-inline 'widget-radio-value-inline + :value-set 'widget-radio-value-set + :error "You must push one of the buttons" + :validate 'widget-radio-validate + :match 'widget-choice-match + :match-inline 'widget-choice-match-inline + :action 'widget-radio-action) + +(defun widget-radio-value-create (widget) + ;; Insert all values + (let ((args (widget-get widget :args)) + arg) + (while args + (setq arg (car args) + args (cdr args)) + (widget-radio-add-item widget arg)))) + +(defun widget-radio-add-item (widget type) + "Add to radio widget WIDGET a new radio button item of type TYPE." + ;; (setq type (widget-convert type)) + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (widget-specify-insert + (let* ((value (widget-get widget :value)) + (children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + (button-args (or (widget-get type :sibling-args) + (widget-get widget :button-args))) + (from (point)) + (chosen (and (null (widget-get widget :choice)) + (widget-apply type :match value))) + child button) + (insert (widget-get widget :entry-format)) + (goto-char from) + ;; Parse % escapes in format. + (while (re-search-forward "%\\([bv%]\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?b) + (setq button (apply 'widget-create-child-and-convert + widget 'radio-button + :value (not (null chosen)) + button-args))) + ((eq escape ?v) + (setq child (if chosen + (widget-create-child-value + widget type value) + (widget-create-child widget type))) + (unless chosen + (widget-apply child :deactivate))) + (t + (error "Unknown escape `%c'" escape))))) + ;; Update properties. + (when chosen + (widget-put widget :choice type)) + (when button + (widget-put child :button button) + (widget-put widget :buttons (nconc buttons (list button)))) + (when child + (widget-put widget :children (nconc children (list child)))) + child))) + +(defun widget-radio-value-get (widget) + ;; Get value of the child widget. + (let ((chosen (widget-radio-chosen widget))) + (and chosen (widget-value chosen)))) + +(defun widget-radio-chosen (widget) + "Return the widget representing the chosen radio button." + (let ((children (widget-get widget :children)) + current found) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button)) + (value (widget-apply button :value-get))) + (when value + (setq found current + children nil)))) + found)) + +(defun widget-radio-value-inline (widget) + ;; Get value of the child widget. + (let ((children (widget-get widget :children)) + current found) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button)) + (value (widget-apply button :value-get))) + (when value + (setq found (widget-apply current :value-inline) + children nil)))) + found)) + +(defun widget-radio-value-set (widget value) + ;; We can't just delete and recreate a radio widget, since children + ;; can be added after the original creation and won't be recreated + ;; by `:create'. + (let ((children (widget-get widget :children)) + current found) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button)) + (match (and (not found) + (widget-apply current :match value)))) + (widget-value-set button match) + (if match + (progn + (widget-value-set current value) + (widget-apply current :activate)) + (widget-apply current :deactivate)) + (setq found (or found match)))))) + +(defun widget-radio-validate (widget) + ;; Valid if we have made a valid choice. + (let ((children (widget-get widget :children)) + current found button) + (while (and children (not found)) + (setq current (car children) + children (cdr children) + button (widget-get current :button) + found (widget-apply button :value-get))) + (if found + (widget-apply current :validate) + widget))) + +(defun widget-radio-action (widget child event) + ;; Check if a radio button was pressed. + (let ((children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + current) + (when (memq child buttons) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button))) + (cond ((eq child button) + (widget-value-set button t) + (widget-apply current :activate)) + ((widget-value button) + (widget-value-set button nil) + (widget-apply current :deactivate))))))) + ;; Pass notification to parent. + (widget-apply widget :notify child event)) + +;;; The `insert-button' Widget. + +(define-widget 'insert-button 'push-button + "An insert button for the `editable-list' widget." + :tag "INS" + :help-echo "Insert a new item into the list at this position." + :action 'widget-insert-button-action) + +(defun widget-insert-button-action (widget &optional event) + ;; Ask the parent to insert a new item. + (widget-apply (widget-get widget :parent) + :insert-before (widget-get widget :widget))) + +;;; The `delete-button' Widget. + +(define-widget 'delete-button 'push-button + "A delete button for the `editable-list' widget." + :tag "DEL" + :help-echo "Delete this item from the list." + :action 'widget-delete-button-action) + +(defun widget-delete-button-action (widget &optional event) + ;; Ask the parent to insert a new item. + (widget-apply (widget-get widget :parent) + :delete-at (widget-get widget :widget))) + +;;; The `editable-list' Widget. + +(defcustom widget-editable-list-gui nil + "If non nil, use GUI push-buttons in editable list when available." + :type 'boolean + :group 'widgets) + +(define-widget 'editable-list 'default + "A variable list of widgets of the same type." + :convert-widget 'widget-types-convert-widget + :offset 12 + :format "%v%i\n" + :format-handler 'widget-editable-list-format-handler + :entry-format "%i %d %v" + :menu-tag "editable-list" + :value-create 'widget-editable-list-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-editable-list-value-get + :validate 'widget-editable-list-validate + :match 'widget-editable-list-match + :match-inline 'widget-editable-list-match-inline + :insert-before 'widget-editable-list-insert-before + :delete-at 'widget-editable-list-delete-at) + +(defun widget-editable-list-format-handler (widget escape) + ;; We recognize the insert button. + (let ((widget-push-button-gui widget-editable-list-gui)) + (cond ((eq escape ?i) + (and (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (apply 'widget-create-child-and-convert + widget 'insert-button + (widget-get widget :append-button-args))) + (t + (widget-default-format-handler widget escape))))) + +(defun widget-editable-list-value-create (widget) + ;; Insert all values + (let* ((value (widget-get widget :value)) + (type (nth 0 (widget-get widget :args))) + (inlinep (widget-get type :inline)) + children) + (widget-put widget :value-pos (copy-marker (point))) + (set-marker-insertion-type (widget-get widget :value-pos) t) + (while value + (let ((answer (widget-match-inline type value))) + (if answer + (setq children (cons (widget-editable-list-entry-create + widget + (if inlinep + (car answer) + (car (car answer))) + t) + children) + value (cdr answer)) + (setq value nil)))) + (widget-put widget :children (nreverse children)))) + +(defun widget-editable-list-value-get (widget) + ;; Get value of the child widget. + (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) + (widget-get widget :children)))) + +(defun widget-editable-list-validate (widget) + ;; All the chilren must be valid. + (let ((children (widget-get widget :children)) + child found) + (while (and children (not found)) + (setq child (car children) + children (cdr children) + found (widget-apply child :validate))) + found)) + +(defun widget-editable-list-match (widget value) + ;; Value must be a list and all the members must match the type. + (and (listp value) + (null (cdr (widget-editable-list-match-inline widget value))))) + +(defun widget-editable-list-match-inline (widget value) + (let ((type (nth 0 (widget-get widget :args))) + (ok t) + found) + (while (and value ok) + (let ((answer (widget-match-inline type value))) + (if answer + (setq found (append found (car answer)) + value (cdr answer)) + (setq ok nil)))) + (cons found value))) + +(defun widget-editable-list-insert-before (widget before) + ;; Insert a new child in the list of children. + (save-excursion + (let ((children (widget-get widget :children)) + (inhibit-read-only t) + after-change-functions) + (cond (before + (goto-char (widget-get before :entry-from))) + (t + (goto-char (widget-get widget :value-pos)))) + (let ((child (widget-editable-list-entry-create + widget nil nil))) + (when (< (widget-get child :entry-from) (widget-get widget :from)) + (set-marker (widget-get widget :from) + (widget-get child :entry-from))) + (widget-specify-text (widget-get child :entry-from) + (widget-get child :entry-to)) + (if (eq (car children) before) + (widget-put widget :children (cons child children)) + (while (not (eq (car (cdr children)) before)) + (setq children (cdr children))) + (setcdr children (cons child (cdr children))))))) + (widget-setup) + widget (widget-apply widget :notify widget)) + +(defun widget-editable-list-delete-at (widget child) + ;; Delete child from list of children. + (save-excursion + (let ((buttons (copy-list (widget-get widget :buttons))) + button + (inhibit-read-only t) + after-change-functions) + (while buttons + (setq button (car buttons) + buttons (cdr buttons)) + (when (eq (widget-get button :widget) child) + (widget-put widget + :buttons (delq button (widget-get widget :buttons))) + (widget-delete button)))) + (let ((entry-from (widget-get child :entry-from)) + (entry-to (widget-get child :entry-to)) + (inhibit-read-only t) + after-change-functions) + (widget-delete child) + (delete-region entry-from entry-to) + (set-marker entry-from nil) + (set-marker entry-to nil)) + (widget-put widget :children (delq child (widget-get widget :children)))) + (widget-setup) + (widget-apply widget :notify widget)) + +(defun widget-editable-list-entry-create (widget value conv) + ;; Create a new entry to the list. + (let ((type (nth 0 (widget-get widget :args))) + (widget-push-button-gui widget-editable-list-gui) + child delete insert) + (widget-specify-insert + (save-excursion + (and (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (insert (widget-get widget :entry-format))) + ;; Parse % escapes in format. + (while (re-search-forward "%\\(.\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?i) + (setq insert (apply 'widget-create-child-and-convert + widget 'insert-button + (widget-get widget :insert-button-args)))) + ((eq escape ?d) + (setq delete (apply 'widget-create-child-and-convert + widget 'delete-button + (widget-get widget :delete-button-args)))) + ((eq escape ?v) + (if conv + (setq child (widget-create-child-value + widget type value)) + (setq child (widget-create-child widget type)))) + (t + (error "Unknown escape `%c'" escape))))) + (widget-put widget + :buttons (cons delete + (cons insert + (widget-get widget :buttons)))) + (let ((entry-from (copy-marker (point-min))) + (entry-to (copy-marker (point-max)))) + (widget-specify-text entry-from entry-to) + (set-marker-insertion-type entry-from t) + (set-marker-insertion-type entry-to nil) + (widget-put child :entry-from entry-from) + (widget-put child :entry-to entry-to))) + (widget-put insert :widget child) + (widget-put delete :widget child) + child)) + +;;; The `group' Widget. + +(define-widget 'group 'default + "A widget which group other widgets inside." + :convert-widget 'widget-types-convert-widget + :format "%v" + :value-create 'widget-group-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-editable-list-value-get + :validate 'widget-editable-list-validate + :match 'widget-group-match + :match-inline 'widget-group-match-inline) + +(defun widget-group-value-create (widget) + ;; Create each component. + (let ((args (widget-get widget :args)) + (value (widget-get widget :value)) + arg answer children) + (while args + (setq arg (car args) + args (cdr args) + 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) + (let ((match (widget-group-match-inline widget values))) + (and match (null (cdr match)))))) + +(defun widget-group-match-inline (widget vals) + ;; Match if the components match. + (let ((args (widget-get widget :args)) + argument answer found) + (while args + (setq argument (car args) + args (cdr args) + answer (widget-match-inline argument vals)) + (if answer + (setq vals (cdr answer) + found (append found (car answer))) + (setq vals nil + args nil))) + (if answer + (cons found vals) + nil))) + +;;; 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." + (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 + "An immutable sexp." + :format "%t\n%d") + +(define-widget 'function-item 'item + "An immutable function name." + :format "%v\n%h" + :documentation-property (lambda (symbol) + (condition-case nil + (documentation symbol t) + (error nil)))) + +(define-widget 'variable-item 'item + "An immutable variable name." + :format "%v\n%h" + :documentation-property 'variable-documentation) + +(define-widget 'string 'editable-field + "A string" + :tag "String" + :format "%[%t%]: %v") + +(define-widget 'regexp 'string + "A regular expression." + ;; Should do validation. + :tag "Regexp") + +(define-widget 'file 'string + "A file widget. +It will read a file name from the minibuffer when activated." + :format "%[%t%]: %v" + :tag "File" + :action 'widget-file-action) + +(defun widget-file-action (widget &optional event) + ;; Read a file name from the minibuffer. + (let* ((value (widget-value widget)) + (dir (file-name-directory value)) + (file (file-name-nondirectory value)) + (menu-tag (widget-apply widget :menu-tag-get)) + (must-match (widget-get widget :must-match)) + (answer (read-file-name (concat menu-tag ": (default `" value "') ") + dir nil must-match file))) + (widget-value-set widget (abbreviate-file-name answer)) + (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") + +(define-widget 'symbol 'string + "A lisp symbol." + :value nil + :tag "Symbol" + :match (lambda (widget value) (symbolp value)) + :value-to-internal (lambda (widget value) + (if (symbolp value) + (symbol-name value) + value)) + :value-to-external (lambda (widget value) + (if (stringp value) + (intern value) + value))) + +(define-widget 'function 'sexp + ;; Should complete on functions. + "A lisp function." + :tag "Function") + +(define-widget 'variable 'symbol + ;; Should complete on variables. + "A lisp variable." + :tag "Variable") + +(define-widget 'sexp 'string + "An arbitrary lisp expression." + :tag "Lisp expression" + :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))) + +(defun widget-sexp-value-to-internal (widget value) + ;; Use pp for printer representation. + (let ((pp (pp-to-string value))) + (while (string-match "\n\\'" pp) + (setq pp (substring pp 0 -1))) + (if (or (string-match "\n\\'" pp) + (> (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))))) + +(define-widget 'integer 'sexp + "An integer." + :tag "Integer" + :value 0 + :type-error "This field should contain an integer" + :value-to-internal (lambda (widget value) + (if (integerp value) + (prin1-to-string value) + value)) + :match (lambda (widget value) (integerp value))) + +(define-widget 'character 'string + "An character." + :tag "Character" + :value 0 + :size 1 + :format "%{%t%}: %v\n" + :type-error "This field should contain a character" + :value-to-internal (lambda (widget value) + (if (integerp value) + (char-to-string value) + value)) + :value-to-external (lambda (widget value) + (if (stringp value) + (aref value 0) + value)) + :match (lambda (widget value) (integerp value))) + +(define-widget 'number 'sexp + "A floating point number." + :tag "Number" + :value 0.0 + :type-error "This field should contain a number" + :value-to-internal (lambda (widget value) + (if (numberp value) + (prin1-to-string value) + value)) + :match (lambda (widget value) (numberp value))) + +(define-widget 'list 'group + "A lisp list." + :tag "List" + :format "%{%t%}:\n%v") + +(define-widget 'vector 'group + "A lisp vector." + :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) (apply 'vector value))) + +(defun widget-vector-match (widget value) + (and (vectorp value) + (widget-group-match widget + (widget-apply :value-to-internal widget value)))) + +(define-widget 'cons 'group + "A cons-cell." + :tag "Cons-cell" + :format "%{%t%}:\n%v" + :match 'widget-cons-match + :value-to-internal (lambda (widget value) + (list (car value) (cdr value))) + :value-to-external (lambda (widget value) + (cons (nth 0 value) (nth 1 value)))) + +(defun widget-cons-match (widget value) + (and (consp value) + (widget-group-match widget + (widget-apply widget :value-to-internal value)))) + +(define-widget 'choice 'menu-choice + "A union of several sexp types." + :tag "Choice" + :format "%[%t%]: %v") + +(define-widget 'radio 'radio-button-choice + "A union of several sexp types." + :tag "Choice" + :format "%{%t%}:\n%v") + +(define-widget 'repeat 'editable-list + "A variable length homogeneous list." + :tag "Repeat" + :format "%{%t%}:\n%v%i\n") + +(define-widget 'set 'checklist + "A list of members from a fixed set." + :tag "Set" + :format "%{%t%}:\n%v") + +(define-widget 'boolean 'toggle + "To be nil or non-nil, that is the question." + :tag "Boolean" + :format "%{%t%}: %[%v%]\n") + +;;; The `color' Widget. + +(define-widget 'color-item 'choice-item + "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" + :value "black" + :value-create 'widget-color-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-color-value-get + :value-set 'widget-color-value-set + :action 'widget-color-action + :match 'widget-field-match + :tag "Color") + +(defvar widget-color-choice-list nil) +;; Variable holding the possible colors. + +(defun widget-color-choice-list () + (unless widget-color-choice-list + (setq widget-color-choice-list + (mapcar '(lambda (color) (list color)) + (x-defined-colors)))) + widget-color-choice-list) + +(defun widget-color-value-create (widget) + (let ((child (widget-create-child-and-convert + widget 'color-item (widget-get widget :value)))) + (widget-put widget :children (list child)))) + +(defun widget-color-value-get (widget) + ;; Pass command to first child. + (widget-apply (car (widget-get widget :children)) :value-get)) + +(defun widget-color-value-set (widget value) + ;; Pass command to first child. + (widget-apply (car (widget-get widget :children)) :value-set value)) + +(defvar widget-color-history nil + "History of entered colors") + +(defun widget-color-action (widget &optional event) + ;; Prompt for a color. + (let* ((tag (widget-apply widget :menu-tag-get)) + (prompt (concat tag ": ")) + (answer (cond ((string-match "XEmacs" emacs-version) + (read-color prompt)) + ((fboundp 'x-defined-colors) + (completing-read (concat tag ": ") + (widget-color-choice-list) + nil nil nil 'widget-color-history)) + (t + (read-string prompt (widget-value widget)))))) + (unless (zerop (length answer)) + (widget-value-set widget answer) + (widget-apply widget :notify widget event) + (widget-setup)))) + +;;; The Help Echo + +(defun widget-echo-help-mouse () + "Display the help message for the widget under the mouse. +Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)" + (let* ((pos (mouse-position)) + (frame (car pos)) + (x (car (cdr pos))) + (y (cdr (cdr pos))) + (win (window-at x y frame)) + (where (coordinates-in-window-p (cons x y) win))) + (when (consp where) + (save-window-excursion + (progn ; save-excursion + (select-window win) + (let* ((result (compute-motion (window-start win) + '(0 . 0) + (window-end win) + where + (window-width win) + (cons (window-hscroll) 0) + win))) + (when (and (eq (nth 1 result) x) + (eq (nth 2 result) y)) + (widget-echo-help (nth 0 result)))))))) + (unless track-mouse + (setq track-mouse t) + (add-hook 'post-command-hook 'widget-stop-mouse-tracking))) + +(defun widget-stop-mouse-tracking (&rest args) + "Stop the mouse tracking done while idle." + (remove-hook 'post-command-hook 'widget-stop-mouse-tracking) + (setq track-mouse nil)) + +(defun widget-at (pos) + "The button or field at POS." + (or (get-text-property pos 'button) + (get-text-property pos 'field))) + +(defun widget-echo-help (pos) + "Display the help echo for widget at POS." + (let* ((widget (widget-at pos)) + (help-echo (and widget (widget-get widget :help-echo)))) + (cond ((stringp help-echo) + (message "%s" help-echo)) + ((and (symbolp help-echo) (fboundp help-echo) + (stringp (setq help-echo (funcall help-echo widget)))) + (message "%s" help-echo))))) + +;;; The End: + +(provide 'wid-edit) + +;; wid-edit.el ends here diff --git a/lisp/widget.el b/lisp/widget.el new file mode 100644 index 00000000000..4e1f2ca804c --- /dev/null +++ b/lisp/widget.el @@ -0,0 +1,76 @@ +;;; widget.el --- a library of user interface components. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, extensions, faces, hypermedia +;; Version: 1.71 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; If you want to use this code, please visit the URL above. +;; +;; This file only contain the code needed to define new widget types. +;; Everything else is autoloaded from `wid-edit.el'. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defmacro define-widget-keywords (&rest keys) + (` + (eval-and-compile + (let ((keywords (quote (, keys)))) + (while keywords + (or (boundp (car keywords)) + (set (car keywords) (car keywords))) + (setq keywords (cdr keywords))))))) + +(define-widget-keywords :deactivate :active :inactive :activate + :sibling-args :delete-button-args + :insert-button-args :append-button-args :button-args + :tag-glyph :off-glyph :on-glyph :valid-regexp + :secret :sample-face :sample-face-get :case-fold :widget-doc + :create :convert-widget :format :value-create :offset :extra-offset + :tag :doc :from :to :args :value :value-from :value-to :action + :value-set :value-delete :match :parent :delete :menu-tag-get + :value-get :choice :void :menu-tag :on :off :on-type :off-type + :notify :entry-format :button :children :buttons :insert-before + :delete-at :format-handler :widget :value-pos :value-to-internal + :indent :size :value-to-external :validate :error :directory + :must-match :type-error :value-inline :inline :match-inline :greedy + :button-face-get :button-face :value-face :keymap :entry-from + :entry-to :help-echo :documentation-property :hide-front-space + :hide-rear-space :tab-order) + +;; These autoloads should be deleted when the file is added to Emacs. +(unless (fboundp 'load-gc) + (autoload 'widget-apply "wid-edit") + (autoload 'widget-create "wid-edit") + (autoload 'widget-insert "wid-edit") + (autoload 'widget-browse "wid-browse" nil t) + (autoload 'widget-browse-at "wid-browse" nil t)) + +(defun define-widget (name class doc &rest args) + "Define a new widget type named NAME from CLASS. + +NAME and CLASS should both be symbols, CLASS should be one of the +existing widget types, or nil to create the widget from scratch. + +After the new widget has been defined, the following two calls will +create identical widgets: + +* (widget-create NAME) + +* (apply 'widget-create CLASS ARGS) + +The third argument DOC is a documentation string for the widget." + (put name 'widget-type (cons class args)) + (put name 'widget-documentation doc)) + +;;; The End. + +(provide 'widget) + +;; widget.el ends here |