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 | 2726 | ||||
| -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, 7148 insertions, 2433 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 index e747264583c..6d247ebb379 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -1,2472 +1,332 @@ -;;; custom.el --- User friendly customization support. - -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. - -;; Author: Per Abrahamsen <abraham@iesd.auc.dk> -;; Keywords: help -;; Version: 0.5 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; WARNING: This package is still under construction and not all of -;; the features below are implemented. +;;; custom.el -- Tools for declaring and initializing options. ;; -;; This package provides a framework for adding user friendly -;; customization support to Emacs. Having to do customization by -;; editing a text file in some arcane syntax is user hostile in the -;; extreme, and to most users emacs lisp definitely count as arcane. +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. ;; -;; The intent is that authors of emacs lisp packages declare the -;; variables intended for user customization with `custom-declare'. -;; Custom can then automatically generate a customization buffer with -;; `custom-buffer-create' where the user can edit the package -;; variables in a simple and intuitive way, as well as a menu with -;; `custom-menu-create' where he can set the more commonly used -;; variables interactively. +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, faces +;; Version: 1.71 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: ;; -;; It is also possible to use custom for modifying the properties of -;; other objects than the package itself, by specifying extra optional -;; arguments to `custom-buffer-create'. +;; If you want to use this code, please visit the URL above. ;; -;; Custom is inspired by OPEN LOOK property windows. +;; This file only contain the code needed to declare and initialize +;; user options. The code to customize options is autoloaded from +;; `cus-edit.el'. -;;; Todo: -;; -;; - Toggle documentation in three states `none', `one-line', `full'. -;; - Function to generate an XEmacs menu from a CUSTOM. -;; - Write TeXinfo documentation. -;; - Make it possible to hide sections by clicking at the level. -;; - Declare AUC TeX variables. -;; - Declare (ding) Gnus variables. -;; - Declare Emacs variables. -;; - Implement remaining types. -;; - XEmacs port. -;; - Allow `URL', `info', and internal hypertext buttons. -;; - Support meta-variables and goal directed customization. -;; - Make it easy to declare custom types independently. -;; - Make it possible to declare default value and type for a single -;; variable, storing the data in a symbol property. -;; - Syntactic sugar for CUSTOM declarations. -;; - Use W3 for variable documentation. +;; The code implementing face declarations is in `cus-face.el' ;;; Code: -(eval-when-compile - (require 'cl)) - -;;; Compatibility: - -(defun custom-xmas-add-text-properties (start end props &optional object) - (add-text-properties start end props object) - (put-text-property start end 'start-open t object) - (put-text-property start end 'end-open t object)) - -(defun custom-xmas-put-text-property (start end prop value &optional object) - (put-text-property start end prop value object) - (put-text-property start end 'start-open t object) - (put-text-property start end 'end-open t object)) - -(defun custom-xmas-extent-start-open () - (map-extents (lambda (extent arg) - (set-extent-property extent 'start-open t)) - nil (point) (min (1+ (point)) (point-max)))) - -(if (string-match "XEmacs\\|Lucid" emacs-version) - (progn - (fset 'custom-add-text-properties 'custom-xmas-add-text-properties) - (fset 'custom-put-text-property 'custom-xmas-put-text-property) - (fset 'custom-extent-start-open 'custom-xmas-extent-start-open) - (fset 'custom-set-text-properties - (if (fboundp 'set-text-properties) - 'set-text-properties)) - (fset 'custom-buffer-substring-no-properties - (if (fboundp 'buffer-substring-no-properties) - 'buffer-substring-no-properties - 'custom-xmas-buffer-substring-no-properties))) - (fset 'custom-add-text-properties 'add-text-properties) - (fset 'custom-put-text-property 'put-text-property) - (fset 'custom-extent-start-open 'ignore) - (fset 'custom-set-text-properties 'set-text-properties) - (fset 'custom-buffer-substring-no-properties - 'buffer-substring-no-properties)) - -(defun custom-xmas-buffer-substring-no-properties (beg end) - "Return the text from BEG to END, without text properties, as a string." - (let ((string (buffer-substring beg end))) - (custom-set-text-properties 0 (length string) nil string) - string)) - -(or (fboundp 'add-to-list) - ;; Introduced in Emacs 19.29. - (defun add-to-list (list-var element) - "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. -If you want to use `add-to-list' on a variable that is not defined -until a certain package is loaded, you should put the call to `add-to-list' -into a hook function that will be run only after loading the package. -`eval-after-load' provides one way to do this. In some cases -other hooks, such as major mode hooks, can do the job." - (or (member element (symbol-value list-var)) - (set list-var (cons element (symbol-value list-var)))))) - -(or (fboundp 'plist-get) - ;; Introduced in Emacs 19.29. - (defun plist-get (plist prop) - "Extract a value from a property list. -PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value -corresponding to the given PROP, or nil if PROP is not -one of the properties on the list." - (let (result) - (while plist - (if (eq (car plist) prop) - (setq result (car (cdr plist)) - plist nil) - (set plist (cdr (cdr plist))))) - result))) - -(or (fboundp 'plist-put) - ;; Introduced in Emacs 19.29. - (defun plist-put (plist prop val) - "Change value in PLIST of PROP to VAL. -PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object. -If PROP is already a property on the list, its value is set to VAL, -otherwise the new PROP VAL pair is added. The new plist is returned; -use `(setq x (plist-put x prop val))' to be sure to use the new value. -The PLIST is modified by side effects." - (if (null plist) - (list prop val) - (let ((current plist)) - (while current - (cond ((eq (car current) prop) - (setcar (cdr current) val) - (setq current nil)) - ((null (cdr (cdr current))) - (setcdr (cdr current) (list prop val)) - (setq current nil)) - (t - (setq current (cdr (cdr current))))))) - plist))) - -(or (fboundp 'match-string) - ;; Introduced in Emacs 19.29. - (defun match-string (num &optional string) - "Return string of text matched by last search. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING." - (if (match-beginning num) - (if string - (substring string (match-beginning num) (match-end num)) - (buffer-substring (match-beginning num) (match-end num)))))) - -(or (fboundp 'facep) - ;; Introduced in Emacs 19.29. - (defun facep (x) - "Return t if X is a face name or an internal face vector." - (and (or (and (fboundp 'internal-facep) (internal-facep x)) - (and - (symbolp x) - (assq x (and (boundp 'global-face-data) global-face-data)))) - t))) - -;; XEmacs and Emacs 19.29 facep does different things. -(if (fboundp 'find-face) - (fset 'custom-facep 'find-face) - (fset 'custom-facep 'facep)) - -(if (custom-facep 'underline) - () - ;; No underline face in XEmacs 19.12. - (and (fboundp 'make-face) - (funcall (intern "make-face") 'underline)) - ;; Must avoid calling set-face-underline-p directly, because it - ;; is a defsubst in emacs19, and will make the .elc files non - ;; portable! - (or (and (fboundp 'face-differs-from-default-p) - (face-differs-from-default-p 'underline)) - (and (fboundp 'set-face-underline-p) - (funcall 'set-face-underline-p 'underline t)))) - -(defun custom-xmas-set-text-properties (start end props &optional buffer) - (if (null buffer) - (if props - (while props - (custom-put-text-property - start end (car props) (nth 1 props) buffer) - (setq props (nthcdr 2 props))) - (remove-text-properties start end ())))) - -(or (fboundp 'event-point) - ;; Missing in Emacs 19.29. - (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)))) - -(eval-when-compile - (defvar x-colors nil) - (defvar custom-button-face nil) - (defvar custom-field-uninitialized-face nil) - (defvar custom-field-invalid-face nil) - (defvar custom-field-modified-face nil) - (defvar custom-field-face nil) - (defvar custom-mouse-face nil) - (defvar custom-field-active-face nil)) - -;; We can't easily check for a working intangible. -(defconst intangible (if (and (boundp 'emacs-minor-version) - (or (> emacs-major-version 19) - (and (> emacs-major-version 18) - (> emacs-minor-version 28)))) - (setq intangible 'intangible) - (setq intangible 'intangible-if-it-had-been-working)) - "The symbol making text intangible.") - -(defconst rear-nonsticky (if (string-match "XEmacs" emacs-version) - 'end-open - 'rear-nonsticky) - "The symbol making text properties non-sticky in the rear end.") - -(defconst front-sticky (if (string-match "XEmacs" emacs-version) - 'front-closed - 'front-sticky) - "The symbol making text properties sticky in the front.") - -(defconst mouse-face (if (string-match "XEmacs" emacs-version) - 'highlight - 'mouse-face) - "Symbol used for highlighting text under mouse.") - -;; Put it in the Help menu, if possible. -(if (string-match "XEmacs" emacs-version) - (if (featurep 'menubar) - ;; XEmacs (disabled because it doesn't work) - (and current-menubar - (add-menu-item '("Help") "Customize..." 'customize t))) - ;; Emacs 19.28 and earlier - (global-set-key [ menu-bar help customize ] - '("Customize..." . customize)) - ;; Emacs 19.29 and later - (global-set-key [ menu-bar help-menu customize ] - '("Customize..." . customize))) - -;; XEmacs popup-menu stolen from w3.el. -(defun custom-x-really-popup-menu (pos title menudesc) - "My hacked up function to do a blocking popup menu..." - (let ((echo-keystrokes 0) - event menu) - (while menudesc - (setq menu (cons (vector (car (car menudesc)) - (list (car (car menudesc))) t) menu) - menudesc (cdr menudesc))) - (setq menu (cons title menu)) - (popup-menu menu) - (catch 'popup-done - (while t - (setq event (next-command-event event)) - (cond ((and (misc-user-event-p event) (stringp (car-safe (event-object event)))) - (throw 'popup-done (event-object event))) - ((and (misc-user-event-p event) - (or (eq (event-object event) 'abort) - (eq (event-object event) 'menu-no-selection-hook))) - nil) - ((not (popup-menu-up-p)) - (throw 'popup-done nil)) - ((button-release-event-p event);; don't beep twice - nil) +(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 - (beep) - (message "please make a choice from the menu."))))))) - -;;; Categories: -;; -;; XEmacs use inheritable extents for the same purpose as Emacs uses -;; the category text property. - -(if (string-match "XEmacs" emacs-version) - (progn - ;; XEmacs categories. - (defun custom-category-create (name) - (set name (make-extent nil nil)) - "Create a text property category named NAME.") - - (defun custom-category-put (name property value) - "In CATEGORY set PROPERTY to VALUE." - (set-extent-property (symbol-value name) property value)) - - (defun custom-category-get (name property) - "In CATEGORY get PROPERTY." - (extent-property (symbol-value name) property)) - - (defun custom-category-set (from to category) - "Make text between FROM and TWO have category CATEGORY." - (let ((extent (make-extent from to))) - (set-extent-parent extent (symbol-value category))))) - - ;; Emacs categories. - (defun custom-category-create (name) - "Create a text property category named NAME." - (set name name)) - - (defun custom-category-put (name property value) - "In CATEGORY set PROPERTY to VALUE." - (put name property value)) - - (defun custom-category-get (name property) - "In CATEGORY get PROPERTY." - (get name property)) - - (defun custom-category-set (from to category) - "Make text between FROM and TWO have category CATEGORY." - (custom-put-text-property from to 'category category))) - -;;; External Data: -;; -;; The following functions and variables defines the interface for -;; connecting a CUSTOM with an external entity, by default an emacs -;; lisp variable. - -(defvar custom-external 'default-value - "Function returning the external value of NAME.") - -(defvar custom-external-set 'set-default - "Function setting the external value of NAME to VALUE.") - -(defun custom-external (name) - "Get the external value associated with NAME." - (funcall custom-external name)) - -(defun custom-external-set (name value) - "Set the external value associated with NAME to VALUE." - (funcall custom-external-set name value)) - -(defvar custom-name-fields nil - "Alist of custom names and their associated editing field.") -(make-variable-buffer-local 'custom-name-fields) - -(defun custom-name-enter (name field) - "Associate NAME with FIELD." - (if (null name) - () - (custom-assert 'field) - (setq custom-name-fields (cons (cons name field) custom-name-fields)))) - -(defun custom-name-field (name) - "The editing field associated with NAME." - (cdr (assq name custom-name-fields))) - -(defun custom-name-value (name) - "The value currently displayed for NAME in the customization buffer." - (let* ((field (custom-name-field name)) - (custom (custom-field-custom field))) - (custom-field-parse field) - (funcall (custom-property custom 'export) custom - (car (custom-field-extract custom field))))) - -(defvar custom-save 'custom-save - "Function that will save current customization buffer.") - -;;; Custom Functions: -;; -;; The following functions are part of the public interface to the -;; CUSTOM datastructure. Each CUSTOM describes a group of variables, -;; a single variable, or a component of a structured variable. The -;; CUSTOM instances are part of two hierarchies, the first is the -;; `part-of' hierarchy in which each CUSTOM is a component of another -;; CUSTOM, except for the top level CUSTOM which is contained in -;; `custom-data'. The second hierarchy is a `is-a' type hierarchy -;; where each CUSTOM is a leaf in the hierarchy defined by the `type' -;; property and `custom-type-properties'. - -(defvar custom-file "~/.custom.el" - "Name of file with customization information.") - -(defconst custom-data - '((tag . "Emacs") - (doc . "The extensible self-documenting text editor.") - (type . group) - (data "\n" - ((header . nil) - (compact . t) - (type . group) - (doc . "\ -Press [Save] to save any changes permanently after you are done editing. -You can load customization information from other files by editing the -`File' field and pressing the [Load] button. When you press [Save] the -customization information of all files you have loaded, plus any -changes you might have made manually, will be stored in the file -specified by the `File' field.") - (data ((tag . "Load") - (type . button) - (query . custom-load)) - ((tag . "Save") - (type . button) - (query . custom-save)) - ((name . custom-file) - (default . "~/.custom.el") - (doc . "Name of file with customization information.\n") - (tag . "File") - (type . file)))))) - "The global customization information. -A custom association list.") - -(defun custom-declare (path custom) - "Declare variables for customization. -PATH is a list of tags leading to the place in the customization -hierarchy the new entry should be added. CUSTOM is the entry to add." - (custom-initialize custom) - (let ((current (custom-travel-path custom-data path))) - (or (member custom (custom-data current)) - (nconc (custom-data current) (list custom))))) - -(put 'custom-declare 'lisp-indent-hook 1) - -(defconst custom-type-properties - '((repeat (type . default) - ;; See `custom-match'. - (import . custom-repeat-import) - (eval . custom-repeat-eval) - (quote . custom-repeat-quote) - (accept . custom-repeat-accept) - (extract . custom-repeat-extract) - (validate . custom-repeat-validate) - (insert . custom-repeat-insert) - (match . custom-repeat-match) - (query . custom-repeat-query) - (prefix . "") - (del-tag . "[DEL]") - (add-tag . "[INS]")) - (pair (type . group) - ;; A cons-cell. - (accept . custom-pair-accept) - (eval . custom-pair-eval) - (import . custom-pair-import) - (quote . custom-pair-quote) - (valid . (lambda (c d) (consp d))) - (extract . custom-pair-extract)) - (list (type . group) - ;; A lisp list. - (quote . custom-list-quote) - (valid . (lambda (c d) - (listp d))) - (extract . custom-list-extract)) - (group (type . default) - ;; See `custom-match'. - (face-tag . nil) - (eval . custom-group-eval) - (import . custom-group-import) - (initialize . custom-group-initialize) - (apply . custom-group-apply) - (reset . custom-group-reset) - (factory-reset . custom-group-factory-reset) - (extract . nil) - (validate . custom-group-validate) - (query . custom-toggle-hide) - (accept . custom-group-accept) - (insert . custom-group-insert) - (find . custom-group-find)) - (toggle (type . choice) - ;; Booleans. - (data ((type . const) - (tag . "On ") - (default . t)) - ((type . const) - (tag . "Off") - (default . nil)))) - (triggle (type . choice) - ;; On/Off/Default. - (data ((type . const) - (tag . "On ") - (default . t)) - ((type . const) - (tag . "Off") - (default . nil)) - ((type . const) - (tag . "Def") - (default . custom:asis)))) - (choice (type . default) - ;; See `custom-match'. - (query . custom-choice-query) - (accept . custom-choice-accept) - (extract . custom-choice-extract) - (validate . custom-choice-validate) - (insert . custom-choice-insert) - (none (tag . "Unknown") - (default . __uninitialized__) - (type . const))) - (const (type . default) - ;; A `const' only matches a single lisp value. - (extract . (lambda (c f) (list (custom-default c)))) - (validate . (lambda (c f) nil)) - (valid . custom-const-valid) - (update . custom-const-update) - (insert . custom-const-insert)) - (face-doc (type . doc) - ;; A variable containing a face. - (doc . "\ -You can customize the look of Emacs by deciding which faces should be -used when. If you push one of the face buttons below, you will be -given a choice between a number of standard faces. The name of the -selected face is shown right after the face button, and it is -displayed its own face so you can see how it looks. If you know of -another standard face not listed and want to use it, you can select -`Other' and write the name in the editing field. - -If none of the standard faces suits you, you can select `Customize' to -create your own face. This will make six fields appear under the face -button. The `Fg' and `Bg' fields are the foreground and background -colors for the face, respectively. You should type the name of the -color in the field. You can use any X11 color name. A list of X11 -color names may be available in the file `/usr/lib/X11/rgb.txt' on -your system. The special color name `default' means that the face -will not change the color of the text. The `Stipple' field is weird, -so just ignore it. The three remaining fields are toggles, which will -make the text `bold', `italic', or `underline' respectively. For some -fonts `bold' or `italic' will not make any visible change.")) - (face (type . choice) - (eval . custom-face-eval) - (import . custom-face-import) - (data ((tag . "None") - (default . nil) - (type . const)) - ((tag . "Default") - (default . default) - (face . custom-const-face) - (type . const)) - ((tag . "Bold") - (default . bold) - (face . custom-const-face) - (type . const)) - ((tag . "Bold-italic") - (default . bold-italic) - (face . custom-const-face) - (type . const)) - ((tag . "Italic") - (default . italic) - (face . custom-const-face) - (type . const)) - ((tag . "Underline") - (default . underline) - (face . custom-const-face) - (type . const)) - ((tag . "Highlight") - (default . highlight) - (face . custom-const-face) - (type . const)) - ((tag . "Modeline") - (default . modeline) - (face . custom-const-face) - (type . const)) - ((tag . "Region") - (default . region) - (face . custom-const-face) - (type . const)) - ((tag . "Secondary Selection") - (default . secondary-selection) - (face . custom-const-face) - (type . const)) - ((tag . "Customized") - (compact . t) - (face-tag . custom-face-hack) - (eval . custom-face-eval) - (data ((hidden . t) - (tag . "") - (doc . "\ -Select the properties you want this face to have.") - (default . custom-face-lookup) - (type . const)) - "\n" - ((tag . "Fg") - (hidden . t) - (default . "default") - (width . 20) - (type . string)) - ((tag . "Bg") - (default . "default") - (width . 20) - (type . string)) - ((tag . "Stipple") - (default . "default") - (width . 20) - (type . string)) - "\n" - ((tag . "Bold") - (default . custom:asis) - (type . triggle)) - " " - ((tag . "Italic") - (default . custom:asis) - (type . triggle)) - " " - ((tag . "Underline") - (hidden . t) - (default . custom:asis) - (type . triggle))) - (default . (custom-face-lookup "default" "default" "default" - nil nil nil)) - (type . list)) - ((prompt . "Other") - (face . custom-field-value) - (default . __uninitialized__) - (type . symbol)))) - (file (type . string) - ;; A string containing a file or directory name. - (directory . nil) - (default-file . nil) - (query . custom-file-query)) - (sexp (type . default) - ;; Any lisp expression. - (width . 40) - (default . (__uninitialized__ . "Uninitialized")) - (read . custom-sexp-read) - (write . custom-sexp-write)) - (symbol (type . sexp) - ;; A lisp symbol. - (width . 40) - (valid . (lambda (c d) (symbolp d)))) - (integer (type . sexp) - ;; A lisp integer. - (width . 10) - (valid . (lambda (c d) (integerp d)))) - (string (type . default) - ;; A lisp string. - (width . 40) - (valid . (lambda (c d) (stringp d))) - (read . custom-string-read) - (write . custom-string-write)) - (button (type . default) - ;; Push me. - (accept . ignore) - (extract . nil) - (validate . ignore) - (insert . custom-button-insert)) - (doc (type . default) - ;; A documentation only entry with no value. - (header . nil) - (reset . ignore) - (extract . nil) - (validate . ignore) - (insert . custom-documentation-insert)) - (default (width . 20) - (valid . (lambda (c v) t)) - (insert . custom-default-insert) - (update . custom-default-update) - (query . custom-default-query) - (tag . nil) - (prompt . nil) - (doc . nil) - (header . t) - (padding . ? ) - (quote . custom-default-quote) - (eval . (lambda (c v) nil)) - (export . custom-default-export) - (import . (lambda (c v) (list v))) - (synchronize . ignore) - (initialize . custom-default-initialize) - (extract . custom-default-extract) - (validate . custom-default-validate) - (apply . custom-default-apply) - (reset . custom-default-reset) - (factory-reset . custom-default-factory-reset) - (accept . custom-default-accept) - (match . custom-default-match) - (name . nil) - (compact . nil) - (hidden . nil) - (face . custom-default-face) - (data . nil) - (calculate . nil) - (default . __uninitialized__))) - "Alist of default properties for type symbols. -The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.") - -(defconst custom-local-type-properties nil - "Local type properties. -Entries in this list take precedence over `custom-type-properties'.") - -(make-variable-buffer-local 'custom-local-type-properties) - -(defconst custom-nil '__uninitialized__ - "Special value representing an uninitialized field.") - -(defconst custom-invalid '__invalid__ - "Special value representing an invalid field.") - -(defconst custom:asis 'custom:asis) -;; Bad, ugly, and horrible kludge. - -(defun custom-property (custom property) - "Extract from CUSTOM property PROPERTY." - (let ((entry (assq property custom))) - (while (null entry) - ;; Look in superclass. - (let ((type (custom-type custom))) - (setq custom (cdr (or (assq type custom-local-type-properties) - (assq type custom-type-properties))) - entry (assq property custom)) - (custom-assert 'custom))) - (cdr entry))) - -(defun custom-super (custom property) - "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass." - (let ((entry nil)) - (while (null entry) - ;; Look in superclass. - (let ((type (custom-type custom))) - (setq custom (cdr (or (assq type custom-local-type-properties) - (assq type custom-type-properties))) - entry (assq property custom)) - (custom-assert 'custom))) - (cdr entry))) - -(defun custom-property-set (custom property value) - "Set CUSTOM PROPERTY to VALUE by side effect. -CUSTOM must have at least one property already." - (let ((entry (assq property custom))) - (if entry - (setcdr entry value) - (setcdr custom (cons (cons property value) (cdr custom)))))) - -(defun custom-type (custom) - "Extract `type' from CUSTOM." - (cdr (assq 'type custom))) - -(defun custom-name (custom) - "Extract `name' from CUSTOM." - (custom-property custom 'name)) - -(defun custom-tag (custom) - "Extract `tag' from CUSTOM." - (custom-property custom 'tag)) - -(defun custom-face-tag (custom) - "Extract `face-tag' from CUSTOM." - (custom-property custom 'face-tag)) - -(defun custom-prompt (custom) - "Extract `prompt' from CUSTOM. -If none exist, default to `tag' or, failing that, `type'." - (or (custom-property custom 'prompt) - (custom-property custom 'tag) - (capitalize (symbol-name (custom-type custom))))) - -(defun custom-default (custom) - "Extract `default' from CUSTOM." - (let ((value (custom-property custom 'calculate))) - (if value - (eval value) - (custom-property custom 'default)))) - -(defun custom-data (custom) - "Extract the `data' from CUSTOM." - (custom-property custom 'data)) - -(defun custom-documentation (custom) - "Extract `doc' from CUSTOM." - (custom-property custom 'doc)) - -(defun custom-width (custom) - "Extract `width' from CUSTOM." - (custom-property custom 'width)) - -(defun custom-compact (custom) - "Extract `compact' from CUSTOM." - (custom-property custom 'compact)) - -(defun custom-padding (custom) - "Extract `padding' from CUSTOM." - (custom-property custom 'padding)) - -(defun custom-valid (custom value) - "Non-nil if CUSTOM may validly be set to VALUE." - (and (not (and (listp value) (eq custom-invalid (car value)))) - (funcall (custom-property custom 'valid) custom value))) - -(defun custom-import (custom value) - "Import CUSTOM VALUE from external variable. - -This function change VALUE into a form that makes it easier to edit -internally. What the internal form is exactly depends on CUSTOM. -The internal form is returned." - (if (eq custom-nil value) - (list custom-nil) - (funcall (custom-property custom 'import) custom value))) - -(defun custom-eval (custom value) - "Return non-nil if CUSTOM's VALUE needs to be evaluated." - (funcall (custom-property custom 'eval) custom value)) - -(defun custom-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (funcall (custom-property custom 'quote) custom value)) - -(defun custom-write (custom value) - "Convert CUSTOM VALUE to a string." - (cond ((eq value custom-nil) - "") - ((and (listp value) (eq (car value) custom-invalid)) - (cdr value)) - (t - (funcall (custom-property custom 'write) custom value)))) - -(defun custom-read (custom string) - "Convert CUSTOM field content STRING into lisp." - (condition-case nil - (funcall (custom-property custom 'read) custom string) - (error (cons custom-invalid string)))) - -(defun custom-match (custom values) - "Match CUSTOM with a list of VALUES. - -Return a cons-cell where the car is the sublist of VALUES matching CUSTOM, -and the cdr is the remaining VALUES. - -A CUSTOM is actually a regular expression over the alphabet of lisp -types. Most CUSTOM types are just doing a literal match, e.g. the -`symbol' type matches any lisp symbol. The exceptions are: - -group: which corresponds to a `(' and `)' group in a regular expression. -choice: which corresponds to a group of `|' in a regular expression. -repeat: which corresponds to a `*' in a regular expression. -optional: which corresponds to a `?', and isn't implemented yet." - (if (memq values (list custom-nil nil)) - ;; Nothing matches the uninitialized or empty list. - (cons custom-nil nil) - (funcall (custom-property custom 'match) custom values))) - -(defun custom-initialize (custom) - "Initialize `doc' and `default' attributes of CUSTOM." - (funcall (custom-property custom 'initialize) custom)) - -(defun custom-find (custom tag) - "Find child in CUSTOM with `tag' TAG." - (funcall (custom-property custom 'find) custom tag)) - -(defun custom-travel-path (custom path) - "Find decedent of CUSTOM by looking through PATH." - (if (null path) - custom - (custom-travel-path (custom-find custom (car path)) (cdr path)))) - -(defun custom-field-extract (custom field) - "Extract CUSTOM's value in FIELD." - (if (stringp custom) - nil - (funcall (custom-property (custom-field-custom field) 'extract) - custom field))) - -(defun custom-field-validate (custom field) - "Validate CUSTOM's value in FIELD. -Return nil if valid, otherwise return a cons-cell where the car is the -position of the error, and the cdr is a text describing the error." - (if (stringp custom) - nil - (funcall (custom-property custom 'validate) custom field))) - -;;; Field Functions: -;; -;; This section defines the public functions for manipulating the -;; FIELD datatype. The FIELD instance hold information about a -;; specific editing field in the customization buffer. -;; -;; Each FIELD can be seen as an instantiation of a CUSTOM. - -(defvar custom-field-last nil) -;; Last field containing point. -(make-variable-buffer-local 'custom-field-last) - -(defvar custom-modified-list nil) -;; List of modified fields. -(make-variable-buffer-local 'custom-modified-list) - -(defun custom-field-create (custom value) - "Create a field structure of type CUSTOM containing VALUE. - -A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where -CUSTOM defines the type of the field, -VALUE is the current value of the field, -ORIGINAL is the original value when created, and -START and END are markers to the start and end of the field." - (vector custom value custom-nil nil nil)) - -(defun custom-field-custom (field) - "Return the `custom' attribute of FIELD." - (aref field 0)) - -(defun custom-field-value (field) - "Return the `value' attribute of FIELD." - (aref field 1)) - -(defun custom-field-original (field) - "Return the `original' attribute of FIELD." - (aref field 2)) - -(defun custom-field-start (field) - "Return the `start' attribute of FIELD." - (aref field 3)) - -(defun custom-field-end (field) - "Return the `end' attribute of FIELD." - (aref field 4)) - -(defun custom-field-value-set (field value) - "Set the `value' attribute of FIELD to VALUE." - (aset field 1 value)) - -(defun custom-field-original-set (field original) - "Set the `original' attribute of FIELD to ORIGINAL." - (aset field 2 original)) - -(defun custom-field-move (field start end) - "Set the `start'and `end' attributes of FIELD to START and END." - (set-marker (or (aref field 3) (aset field 3 (make-marker))) start) - (set-marker (or (aref field 4) (aset field 4 (make-marker))) end)) - -(defun custom-field-query (field) - "Query user for content of current field." - (funcall (custom-property (custom-field-custom field) 'query) field)) + (custom-handle-keyword symbol keyword value + 'custom-variable)))))) + (run-hooks 'custom-define-hook) + symbol) -(defun custom-field-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE. -If optional ORIGINAL is non-nil, consider VALUE for the original value." - (let ((inhibit-point-motion-hooks t)) - (funcall (custom-property (custom-field-custom field) 'accept) - field value original))) +(defmacro defcustom (symbol value doc &rest args) + "Declare SYMBOL as a customizable variable that defaults to VALUE. +DOC is the variable documentation. -(defun custom-field-face (field) - "The face used for highlighting FIELD." - (let ((custom (custom-field-custom field))) - (if (stringp custom) - nil - (let ((face (funcall (custom-property custom 'face) field))) - (if (custom-facep face) face nil))))) +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 -(defun custom-field-update (field) - "Update the screen appearance of FIELD to correspond with the field's value." - (let ((custom (custom-field-custom field))) - (if (stringp custom) - nil - (funcall (custom-property custom 'update) field)))) + [KEYWORD VALUE]... -;;; Types: -;; -;; The following functions defines type specific actions. - -(defun custom-repeat-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (if (eq value custom-nil) - nil - (let ((child (custom-data custom)) - (found nil)) - (mapcar (lambda (v) (if (custom-eval child v) (setq found t))) - value)))) - -(defun custom-repeat-quote (custom value) - "A list of CUSTOM's VALUEs quoted." - (let ((child (custom-data custom))) - (apply 'append (mapcar (lambda (v) (custom-quote child v)) - value)))) - - -(defun custom-repeat-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((child (custom-data custom))) - (apply 'append (mapcar (lambda (v) (custom-import child v)) - value)))) - -(defun custom-repeat-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let ((values (copy-sequence (custom-field-value field))) - (all (custom-field-value field)) - (start (custom-field-start field)) - current new) - (if original - (custom-field-original-set field value)) - (while (consp value) - (setq new (car value) - value (cdr value)) - (if values - ;; Change existing field. - (setq current (car values) - values (cdr values)) - ;; Insert new field if series has grown. - (goto-char start) - (setq current (custom-repeat-insert-entry field)) - (setq all (custom-insert-before all nil current)) - (custom-field-value-set field all)) - (custom-field-accept current new original)) - (while (consp values) - ;; Delete old field if series has scrunk. - (setq current (car values) - values (cdr values)) - (let ((pos (custom-field-start current)) - data) - (while (not data) - (setq pos (previous-single-property-change pos 'custom-data)) - (custom-assert 'pos) - (setq data (get-text-property pos 'custom-data)) - (or (and (arrayp data) - (> (length data) 1) - (eq current (aref data 1))) - (setq data nil))) - (custom-repeat-delete data))))) - -(defun custom-repeat-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - (add-tag (custom-property custom 'add-tag)) - (start (make-marker)) - (data (vector field nil start nil))) - (custom-text-insert "\n") - (let ((pos (point))) - (custom-text-insert (custom-property custom 'prefix)) - (custom-tag-insert add-tag 'custom-repeat-add data) - (set-marker start pos)) - (custom-field-move field start (point)) - (custom-documentation-insert custom) - field)) - -(defun custom-repeat-insert-entry (repeat) - "Insert entry at point in the REPEAT field." - (let* ((inhibit-point-motion-hooks t) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - (custom (custom-field-custom repeat)) - (add-tag (custom-property custom 'add-tag)) - (del-tag (custom-property custom 'del-tag)) - (start (make-marker)) - (end (make-marker)) - (data (vector repeat nil start end)) - field) - (custom-extent-start-open) - (insert-before-markers "\n") - (backward-char 1) - (set-marker start (point)) - (custom-text-insert " ") - (aset data 1 (setq field (custom-insert (custom-data custom) nil))) - (custom-text-insert " ") - (set-marker end (point)) - (goto-char start) - (custom-text-insert (custom-property custom 'prefix)) - (custom-tag-insert add-tag 'custom-repeat-add data) - (custom-text-insert " ") - (custom-tag-insert del-tag 'custom-repeat-delete data) - (forward-char 1) - field)) - -(defun custom-repeat-add (data) - "Add list entry." - (let ((parent (aref data 0)) - (field (aref data 1)) - (at (aref data 2)) - new) - (goto-char at) - (setq new (custom-repeat-insert-entry parent)) - (custom-field-value-set parent - (custom-insert-before (custom-field-value parent) - field new)))) - -(defun custom-repeat-delete (data) - "Delete list entry." - (let ((inhibit-point-motion-hooks t) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - (parent (aref data 0)) - (field (aref data 1))) - (delete-region (aref data 2) (1+ (aref data 3))) - (custom-field-untouch (aref data 1)) - (custom-field-value-set parent - (delq field (custom-field-value parent))))) - -(defun custom-repeat-match (custom values) - "Match CUSTOM with VALUES." - (let* ((child (custom-data custom)) - (match (custom-match child values)) - matches) - (while (not (eq (car match) custom-nil)) - (setq matches (cons (car match) matches) - values (cdr match) - match (custom-match child values))) - (cons (nreverse matches) values))) - -(defun custom-repeat-extract (custom field) - "Extract list of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - () - (while values - (setq result (append result (custom-field-extract data (car values))) - values (cdr values)))) - result)) - -(defun custom-repeat-validate (custom field) - "Validate children." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - (setq result (cons (custom-field-start field) "Uninitialized list"))) - (while (and values (not result)) - (setq result (custom-field-validate data (car values)) - values (cdr values))) - result)) - -(defun custom-pair-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (custom-group-accept field (list (car value) (cdr value)) original)) - -(defun custom-pair-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (custom-group-eval custom (list (car value) (cdr value)))) - -(defun custom-pair-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((result (car (custom-group-import custom - (list (car value) (cdr value)))))) - (custom-assert '(eq (length result) 2)) - (list (cons (nth 0 result) (nth 1 result))))) - -(defun custom-pair-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (if (custom-eval custom value) - (let ((v (car (custom-group-quote custom - (list (car value) (cdr value)))))) - (list (list 'cons (nth 0 v) (nth 1 v)))) - (custom-default-quote custom value))) - -(defun custom-pair-extract (custom field) - "Extract cons of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (custom-assert '(eq (length values) (length data))) - (while values - (setq result (append result - (custom-field-extract (car data) (car values))) - data (cdr data) - values (cdr values))) - (custom-assert '(null data)) - (list (cons (nth 0 result) (nth 1 result))))) - -(defun custom-list-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (if (custom-eval custom value) - (let ((v (car (custom-group-quote custom value)))) - (list (cons 'list v))) - (custom-default-quote custom value))) - -(defun custom-list-extract (custom field) - "Extract list of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (custom-assert '(eq (length values) (length data))) - (while values - (setq result (append result - (custom-field-extract (car data) (car values))) - data (cdr data) - values (cdr values))) - (custom-assert '(null data)) - (list result))) - -(defun custom-group-validate (custom field) - "Validate children." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - (setq result (cons (custom-field-start field) "Uninitialized list")) - (custom-assert '(eq (length values) (length data)))) - (while (and values (not result)) - (setq result (custom-field-validate (car data) (car values)) - data (cdr data) - values (cdr values))) - result)) - -(defun custom-group-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (let ((found nil)) - (mapcar (lambda (c) - (or (stringp c) - (let ((match (custom-match c value))) - (if (custom-eval c (car match)) - (setq found t)) - (setq value (cdr match))))) - (custom-data custom)) - found)) - -(defun custom-group-quote (custom value) - "A list of CUSTOM's VALUE members, quoted." - (list (apply 'append - (mapcar (lambda (c) - (if (stringp c) - () - (let ((match (custom-match c value))) - (prog1 (custom-quote c (car match)) - (setq value (cdr match)))))) - (custom-data custom))))) - -(defun custom-group-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (list (apply 'append - (mapcar (lambda (c) - (if (stringp c) - () - (let ((match (custom-match c value))) - (prog1 (custom-import c (car match)) - (setq value (cdr match)))))) - (custom-data custom))))) - -(defun custom-group-initialize (custom) - "Initialize `doc' and `default' entries in CUSTOM." - (if (custom-name custom) - (custom-default-initialize custom) - (mapcar 'custom-initialize (custom-data custom)))) - -(defun custom-group-apply (field) - "Reset `value' in FIELD to `original'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-apply field) - (mapcar 'custom-field-apply values)))) - -(defun custom-group-reset (field) - "Reset `value' in FIELD to `original'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-reset field) - (mapcar 'custom-field-reset values)))) - -(defun custom-group-factory-reset (field) - "Reset `value' in FIELD to `default'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-factory-reset field) - (mapcar 'custom-field-factory-reset values)))) - -(defun custom-group-find (custom tag) - "Find child in CUSTOM with `tag' TAG." - (let ((data (custom-data custom)) - (result nil)) - (while (not result) - (custom-assert 'data) - (if (equal (custom-tag (car data)) tag) - (setq result (car data)) - (setq data (cdr data)))))) +The following KEYWORD's are defined: -(defun custom-group-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let* ((values (custom-field-value field)) - (custom (custom-field-custom field)) - (from (custom-field-start field)) - (face-tag (custom-face-tag custom)) - current) - (if face-tag - (custom-put-text-property from (+ from (length (custom-tag custom))) - 'face (funcall face-tag field value))) - (if original - (custom-field-original-set field value)) - (while values - (setq current (car values) - values (cdr values)) - (if current - (let* ((custom (custom-field-custom current)) - (match (custom-match custom value))) - (setq value (cdr match)) - (custom-field-accept current (car match) original)))))) +: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. -(defun custom-group-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - fields hidden - (from (point)) - (compact (custom-compact custom)) - (tag (custom-tag custom)) - (face-tag (custom-face-tag custom))) - (cond (face-tag (custom-text-insert tag)) - (tag (custom-tag-insert tag field))) - (or compact (custom-documentation-insert custom)) - (or compact (custom-text-insert "\n")) - (let ((data (custom-data custom))) - (while data - (setq fields (cons (custom-insert (car data) (if level (1+ level))) - fields)) - (setq hidden (or (stringp (car data)) - (custom-property (car data) 'hidden))) - (setq data (cdr data)) - (if data (custom-text-insert (cond (hidden "") - (compact " ") - (t "\n")))))) - (if compact (custom-documentation-insert custom)) - (custom-field-value-set field (nreverse fields)) - (custom-field-move field from (point)) - field)) +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))) -(defun custom-choice-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - (from (point))) - (custom-text-insert "lars er en nisse") - (custom-field-move field from (point)) - (custom-documentation-insert custom) - (custom-field-reset field) - field)) +;;; The `defface' Macro. -(defun custom-choice-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let ((custom (custom-field-custom field)) - (start (custom-field-start field)) - (end (custom-field-end field)) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - from) - (cond (original - (setq custom-modified-list (delq field custom-modified-list)) - (custom-field-original-set field value)) - ((equal value (custom-field-original field)) - (setq custom-modified-list (delq field custom-modified-list))) - (t - (add-to-list 'custom-modified-list field))) - (custom-field-untouch (custom-field-value field)) - (delete-region start end) - (goto-char start) - (setq from (point)) - (insert-before-markers " ") - (backward-char 1) - (custom-category-set (point) (1+ (point)) 'custom-hidden-properties) - (custom-tag-insert (custom-tag custom) field) - (custom-text-insert ": ") - (let ((data (custom-data custom)) - found begin) - (while (and data (not found)) - (if (not (custom-valid (car data) value)) - (setq data (cdr data)) - (setq found (custom-insert (car data) nil)) - (setq data nil))) - (if found - () - (setq begin (point) - found (custom-insert (custom-property custom 'none) nil)) - (custom-add-text-properties - begin (point) - (list rear-nonsticky t - 'face custom-field-uninitialized-face))) - (or original - (custom-field-original-set found (custom-field-original field))) - (custom-field-accept found value original) - (custom-field-value-set field found) - (custom-field-move field from end)))) +(defmacro defface (face spec doc &rest args) + "Declare FACE as a customizable face that defaults to SPEC. +FACE does not need to be quoted. -(defun custom-choice-extract (custom field) - "Extract child's value." - (let ((value (custom-field-value field))) - (custom-field-extract (custom-field-custom value) value))) +Third argument DOC is the face documentation. -(defun custom-choice-validate (custom field) - "Validate child's value." - (let ((value (custom-field-value field)) - (custom (custom-field-custom field))) - (if (or (eq value custom-nil) - (eq (custom-field-custom value) (custom-property custom 'none))) - (cons (custom-field-start field) "Make a choice") - (custom-field-validate (custom-field-custom value) value)))) +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. -(defun custom-choice-query (field) - "Choose a child." - (let* ((custom (custom-field-custom field)) - (old (custom-field-custom (custom-field-value field))) - (default (custom-prompt old)) - (tag (custom-prompt custom)) - (data (custom-data custom)) - current alist) - (if (eq (length data) 2) - (custom-field-accept field (custom-default (if (eq (nth 0 data) old) - (nth 1 data) - (nth 0 data)))) - (while data - (setq current (car data) - data (cdr data)) - (setq alist (cons (cons (custom-prompt current) current) alist))) - (let ((answer (cond ((and (fboundp 'button-press-event-p) - (fboundp 'popup-menu) - (button-press-event-p last-input-event)) - (cdr (assoc (car (custom-x-really-popup-menu - last-input-event tag - (reverse alist))) - alist))) - ((listp last-input-event) - (x-popup-menu last-input-event - (list tag (cons "" (reverse alist))))) - (t - (let ((choice (completing-read (concat tag - " (default " - default - "): ") - alist nil t))) - (if (or (null choice) (string-equal choice "")) - (setq choice default)) - (cdr (assoc choice alist))))))) - (if answer - (custom-field-accept field (custom-default answer))))))) +The remaining arguments should have the form -(defun custom-file-query (field) - "Prompt for a file name" - (let* ((value (custom-field-value field)) - (custom (custom-field-custom field)) - (valid (custom-valid custom value)) - (directory (custom-property custom 'directory)) - (default (and (not valid) - (custom-property custom 'default-file))) - (tag (custom-tag custom)) - (prompt (if default - (concat tag " (" default "): ") - (concat tag ": ")))) - (custom-field-accept field - (if (custom-valid custom value) - (read-file-name prompt - (if (file-name-absolute-p value) - "" - directory) - default nil value) - (read-file-name prompt directory default))))) + [KEYWORD VALUE]... -(defun custom-face-eval (custom value) - "Return non-nil if CUSTOM's VALUE needs to be evaluated." - (not (symbolp value))) +The following KEYWORD's are defined: -(defun custom-face-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((name (or (and (facep value) (symbol-name (face-name value))) - (symbol-name value)))) - (list (if (string-match "\ -custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)" - name) - (list 'custom-face-lookup - (match-string 1 name) - (match-string 2 name) - (match-string 3 name) - (intern (match-string 4 name)) - (intern (match-string 5 name)) - (intern (match-string 6 name))) - value)))) +:group VALUE should be a customization group. + Add FACE to that group. -(defun custom-face-lookup (&optional fg bg stipple bold italic underline) - "Lookup or create a face with specified attributes." - (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" - (or fg "default") - (or bg "default") - (or stipple "default") - bold italic underline)))) - (if (and (custom-facep name) - (fboundp 'make-face)) - () - (copy-face 'default name) - (when (and fg - (not (string-equal fg "default"))) - (condition-case () - (set-face-foreground name fg) - (error nil))) - (when (and bg - (not (string-equal bg "default"))) - (condition-case () - (set-face-background name bg) - (error nil))) - (when (and stipple - (not (string-equal stipple "default")) - (not (eq stipple 'custom:asis)) - (fboundp 'set-face-stipple)) - (set-face-stipple name stipple)) - (when (and bold - (not (eq bold 'custom:asis))) - (condition-case () - (make-face-bold name) - (error nil))) - (when (and italic - (not (eq italic 'custom:asis))) - (condition-case () - (make-face-italic name) - (error nil))) - (when (and underline - (not (eq underline 'custom:asis))) - (condition-case () - (set-face-underline-p name t) - (error nil)))) - name)) +SPEC should be an alist of the form ((DISPLAY ATTS)...). -(defun custom-face-hack (field value) - "Face that should be used for highlighting FIELD containing VALUE." - (let* ((custom (custom-field-custom field)) - (form (funcall (custom-property custom 'export) custom value)) - (face (apply (car form) (cdr form)))) - (if (custom-facep face) face nil))) +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. -(defun custom-const-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom custom-nil)) - (face (custom-field-face field)) - (from (point))) - (custom-text-insert (custom-tag custom)) - (custom-add-text-properties from (point) - (list 'face face - rear-nonsticky t)) - (custom-documentation-insert custom) - (custom-field-move field from (point)) - field)) +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...)...) -(defun custom-const-update (field) - "Update face of FIELD." - (let ((from (custom-field-start field)) - (custom (custom-field-custom field))) - (custom-put-text-property from (+ from (length (custom-tag custom))) - 'face (custom-field-face field)))) +For the DISPLAY to match a FRAME, the REQ property of the frame must +match one of the ITEM. The following REQ are defined: -(defun custom-const-valid (custom value) - "Non-nil if CUSTOM can validly have the value VALUE." - (equal (custom-default custom) value)) +`type' (the value of `window-system') + Should be one of `x' or `tty'. -(defun custom-const-face (field) - "Face used for a FIELD." - (custom-default (custom-field-custom field))) +`class' (the frame's color support) + Should be one of `color', `grayscale', or `mono'. -(defun custom-sexp-read (custom string) - "Read from CUSTOM an STRING." - (save-match-data - (save-excursion - (set-buffer (get-buffer-create " *Custom Scratch*")) - (erase-buffer) - (insert string) - (goto-char (point-min)) - (prog1 (read (current-buffer)) - (or (looking-at - (concat (regexp-quote (char-to-string - (custom-padding custom))) - "*\\'")) - (error "Junk at end of expression")))))) +`background' (what color is used for the background text) + Should be one of `light' or `dark'. -(autoload 'pp-to-string "pp") +Read the section about customization in the emacs lisp manual for more +information." + `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) -(defun custom-sexp-write (custom sexp) - "Write CUSTOM SEXP as string." - (let ((string (prin1-to-string sexp))) - (if (<= (length string) (custom-width custom)) - string - (setq string (pp-to-string sexp)) - (string-match "[ \t\n]*\\'" string) - (concat "\n" (substring string 0 (match-beginning 0)))))) +;;; The `defgroup' Macro. -(defun custom-string-read (custom string) - "Read string by ignoring trailing padding characters." - (let ((last (length string)) - (padding (custom-padding custom))) - (while (and (> last 0) - (eq (aref string (1- last)) padding)) - (setq last (1- last))) - (substring string 0 last))) - -(defun custom-string-write (custom string) - "Write raw string." - string) - -(defun custom-button-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (custom-tag-insert (concat "[" (custom-tag custom) "]") - (custom-property custom 'query)) - (custom-documentation-insert custom) - nil) - -(defun custom-default-export (custom value) - ;; Convert CUSTOM's VALUE to external representation. - ;; See `custom-import'. - (if (custom-eval custom value) - (eval (car (custom-quote custom value))) - value)) - -(defun custom-default-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (list (if (and (not (custom-eval custom value)) - (or (and (symbolp value) - value - (not (eq t value))) - (and (listp value) - value - (not (memq (car value) '(quote function lambda)))))) - (list 'quote value) - value))) - -(defun custom-default-initialize (custom) - "Initialize `doc' and `default' entries in CUSTOM." - (let ((name (custom-name custom))) - (if (null name) - () - (let ((default (custom-default custom)) - (doc (custom-documentation custom)) - (vdoc (documentation-property name 'variable-documentation t))) - (if doc - (or vdoc (put name 'variable-documentation doc)) - (if vdoc (custom-property-set custom 'doc vdoc))) - (if (eq default custom-nil) - (if (boundp name) - (custom-property-set custom 'default (symbol-value name))) - (or (boundp name) - (set name default))))))) - -(defun custom-default-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let ((field (custom-field-create custom custom-nil)) - (tag (custom-tag custom))) - (if (null tag) - () - (custom-tag-insert tag field) - (custom-text-insert ": ")) - (custom-field-insert field) - (custom-documentation-insert custom) - field)) - -(defun custom-default-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (if original - (custom-field-original-set field value)) - (custom-field-value-set field value) - (custom-field-update field)) - -(defun custom-default-apply (field) - "Apply any changes in FIELD since the last apply." - (let* ((custom (custom-field-custom field)) - (name (custom-name custom))) - (if (null name) - (error "This field cannot be applied alone")) - (custom-external-set name (custom-name-value name)) - (custom-field-reset field))) - -(defun custom-default-reset (field) - "Reset content of editing FIELD to `original'." - (custom-field-accept field (custom-field-original field) t)) - -(defun custom-default-factory-reset (field) - "Reset content of editing FIELD to `default'." - (let* ((custom (custom-field-custom field)) - (default (car (custom-import custom (custom-default custom))))) - (or (eq default custom-nil) - (custom-field-accept field default nil)))) - -(defun custom-default-query (field) - "Prompt for a FIELD" - (let* ((custom (custom-field-custom field)) - (value (custom-field-value field)) - (initial (custom-write custom value)) - (prompt (concat (custom-prompt custom) ": "))) - (custom-field-accept field - (custom-read custom - (if (custom-valid custom value) - (read-string prompt (cons initial 1)) - (read-string prompt)))))) - -(defun custom-default-match (custom values) - "Match CUSTOM with VALUES." - values) - -(defun custom-default-extract (custom field) - "Extract CUSTOM's content in FIELD." - (list (custom-field-value field))) - -(defun custom-default-validate (custom field) - "Validate FIELD." - (let ((value (custom-field-value field)) - (start (custom-field-start field))) - (cond ((eq value custom-nil) - (cons start "Uninitialized field")) - ((and (consp value) (eq (car value) custom-invalid)) - (cons start "Unparsable field content")) - ((custom-valid custom value) - nil) - (t - (cons start "Wrong type of field content"))))) - -(defun custom-default-face (field) - "Face used for a FIELD." - (let ((value (custom-field-value field))) - (cond ((eq value custom-nil) - custom-field-uninitialized-face) - ((not (custom-valid (custom-field-custom field) value)) - custom-field-invalid-face) - ((not (equal (custom-field-original field) value)) - custom-field-modified-face) - (t - custom-field-face)))) - -(defun custom-default-update (field) - "Update the content of FIELD." - (let ((inhibit-point-motion-hooks t) - (before-change-functions nil) - (after-change-functions nil) - (start (custom-field-start field)) - (end (custom-field-end field)) - (pos (point))) - ;; Keep track of how many modified fields we have. - (cond ((equal (custom-field-value field) (custom-field-original field)) - (setq custom-modified-list (delq field custom-modified-list))) - ((memq field custom-modified-list)) - (t - (setq custom-modified-list (cons field custom-modified-list)))) - ;; Update the field. - (goto-char end) - (insert-before-markers " ") - (delete-region start (1- end)) - (goto-char start) - (custom-field-insert field) - (goto-char end) - (delete-char 1) - (goto-char pos) - (and (<= start pos) - (<= pos end) - (custom-field-enter field)))) - -;;; Create Buffer: -;; -;; Public functions to create a customization buffer and to insert -;; various forms of text, fields, and buttons in it. - -(defun customize () - "Customize GNU Emacs. -Create a *Customize* buffer with editable customization information -about GNU Emacs." - (interactive) - (custom-buffer-create "*Customize*") - (custom-reset-all)) - -(defun custom-buffer-create (name &optional custom types set get save) - "Create a customization buffer named NAME. -If the optional argument CUSTOM is non-nil, use that as the custom declaration. -If the optional argument TYPES is non-nil, use that as the local types. -If the optional argument SET is non-nil, use that to set external data. -If the optional argument GET is non-nil, use that to get external data. -If the optional argument SAVE is non-nil, use that for saving changes." - (switch-to-buffer name) - (buffer-disable-undo (current-buffer)) - (custom-mode) - (setq custom-local-type-properties types) - (if (null custom) - () - (make-local-variable 'custom-data) - (setq custom-data custom)) - (if (null set) - () - (make-local-variable 'custom-external-set) - (setq custom-external-set set)) - (if (null get) - () - (make-local-variable 'custom-external) - (setq custom-external get)) - (if (null save) - () - (make-local-variable 'custom-save) - (setq custom-save save)) - (let ((inhibit-point-motion-hooks t) - (before-change-functions nil) - (after-change-functions nil)) - (erase-buffer) - (insert "\n") - (goto-char (point-min)) - (custom-text-insert "This is a customization buffer.\n") - (custom-help-insert "\n") - (custom-help-button 'custom-forward-field) - (custom-help-button 'custom-backward-field) - (custom-help-button 'custom-enter-value) - (custom-help-button 'custom-field-factory-reset) - (custom-help-button 'custom-field-reset) - (custom-help-button 'custom-field-apply) - (custom-help-button 'custom-save-and-exit) - (custom-help-button 'custom-toggle-documentation) - (custom-help-insert "\nClick mouse-2 on any button to activate it.\n") - (custom-text-insert "\n") - (custom-insert custom-data 0) - (goto-char (point-min)))) - -(defun custom-insert (custom level) - "Insert custom declaration CUSTOM in current buffer at level LEVEL." - (if (stringp custom) - (progn - (custom-text-insert custom) - nil) - (and level (null (custom-property custom 'header)) - (setq level nil)) - (and level - (> level 0) - (custom-text-insert (concat "\n" (make-string level ?*) " "))) - (let ((field (funcall (custom-property custom 'insert) custom level))) - (custom-name-enter (custom-name custom) field) - field))) - -(defun custom-text-insert (text) - "Insert TEXT in current buffer." - (insert text)) - -(defun custom-tag-insert (tag field &optional data) - "Insert TAG for FIELD in current buffer." - (let ((from (point))) - (insert tag) - (custom-category-set from (point) 'custom-button-properties) - (custom-put-text-property from (point) 'custom-tag field) - (if data - (custom-add-text-properties from (point) (list 'custom-data data))))) - -(defun custom-documentation-insert (custom &rest ignore) - "Insert documentation from CUSTOM in current buffer." - (let ((doc (custom-documentation custom))) - (if (null doc) - () - (custom-help-insert "\n" doc)))) - -(defun custom-help-insert (&rest args) - "Insert ARGS as documentation text." - (let ((from (point))) - (apply 'insert args) - (custom-category-set from (point) 'custom-documentation-properties))) - -(defun custom-help-button (command) - "Describe how to execute COMMAND." - (let ((from (point))) - (insert "`" (key-description (where-is-internal command nil t)) "'") - (custom-set-text-properties from (point) - (list 'face custom-button-face - mouse-face custom-mouse-face - 'custom-jump t ;Make TAB jump over it. - 'custom-tag command - 'start-open t - 'end-open t)) - (custom-category-set from (point) 'custom-documentation-properties)) - (custom-help-insert ": " (custom-first-line (documentation command)) "\n")) - -;;; Mode: -;; -;; The Customization major mode and interactive commands. - -(defvar custom-mode-map nil - "Keymap for Custom Mode.") -(if custom-mode-map - nil - (setq custom-mode-map (make-sparse-keymap)) - (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button) - (define-key custom-mode-map "\t" 'custom-forward-field) - (define-key custom-mode-map "\M-\t" 'custom-backward-field) - (define-key custom-mode-map "\r" 'custom-enter-value) - (define-key custom-mode-map "\C-k" 'custom-kill-line) - (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset) - (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all) - (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset) - (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all) - (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply) - (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all) - (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit) - (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation)) - -;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f -;; forward-field, C-b backward-field, C-n next-field, C-p -;; previous-field, ? describe-field. - -(defun custom-mode () - "Major mode for doing customizations. - -\\{custom-mode-map}" - (kill-all-local-variables) - (setq major-mode 'custom-mode - mode-name "Custom") - (use-local-map custom-mode-map) - (make-local-variable 'before-change-functions) - (setq before-change-functions '(custom-before-change)) - (make-local-variable 'after-change-functions) - (setq after-change-functions '(custom-after-change)) - (if (not (fboundp 'make-local-hook)) - ;; Emacs 19.28 and earlier. - (add-hook 'post-command-hook - (lambda () - (if (eq major-mode 'custom-mode) - (custom-post-command)))) - ;; Emacs 19.29. - (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'custom-post-command nil t))) - -(defun custom-forward-field (arg) - "Move point to the next field or button. -With optional ARG, move across that many fields." - (interactive "p") - (while (> arg 0) - (let ((next (if (get-text-property (point) 'custom-tag) - (next-single-property-change (point) 'custom-tag) - (point)))) - (setq next (or (next-single-property-change next 'custom-tag) - (next-single-property-change (point-min) 'custom-tag))) - (if next - (goto-char next) - (error "No customization fields in this buffer."))) - (or (get-text-property (point) 'custom-jump) - (setq arg (1- arg)))) - (while (< arg 0) - (let ((previous (if (get-text-property (1- (point)) 'custom-tag) - (previous-single-property-change (point) 'custom-tag) - (point)))) - (setq previous - (or (previous-single-property-change previous 'custom-tag) - (previous-single-property-change (point-max) 'custom-tag))) - (if previous - (goto-char previous) - (error "No customization fields in this buffer."))) - (or (get-text-property (1- (point)) 'custom-jump) - (setq arg (1+ arg))))) - -(defun custom-backward-field (arg) - "Move point to the previous field or button. -With optional ARG, move across that many fields." - (interactive "p") - (custom-forward-field (- arg))) - -(defun custom-toggle-documentation (&optional arg) - "Toggle display of documentation text. -If the optional argument is non-nil, show text iff the argument is positive." - (interactive "P") - (let ((hide (or (and (null arg) - (null (custom-category-get - 'custom-documentation-properties 'invisible))) - (<= (prefix-numeric-value arg) 0)))) - (custom-category-put 'custom-documentation-properties 'invisible hide) - (custom-category-put 'custom-documentation-properties intangible hide)) - (redraw-display)) - -(defun custom-enter-value (field data) - "Enter value for current customization field or push button." - (interactive (list (get-text-property (point) 'custom-tag) - (get-text-property (point) 'custom-data))) - (cond (data - (funcall field data)) - ((eq field 'custom-enter-value) - (error "Don't be silly")) - ((and (symbolp field) (fboundp field)) - (call-interactively field)) - (field - (custom-field-query field)) - (t - (message "Nothing to enter here")))) - -(defun custom-kill-line () - "Kill to end of field or end of line, whichever is first." - (interactive) - (let ((field (get-text-property (point) 'custom-field)) - (newline (save-excursion (search-forward "\n"))) - (next (next-single-property-change (point) 'custom-field))) - (if (and field (> newline next)) - (kill-region (point) next) - (call-interactively 'kill-line)))) - -(defun custom-push-button (event) - "Activate button below mouse pointer." - (interactive "@e") - (let* ((pos (event-point event)) - (field (get-text-property pos 'custom-field)) - (tag (get-text-property pos 'custom-tag)) - (data (get-text-property pos 'custom-data))) - (cond (data - (funcall tag data)) - ((and (symbolp tag) (fboundp tag)) - (call-interactively tag)) - (field - (call-interactively (lookup-key global-map (this-command-keys)))) - (tag - (custom-enter-value tag data)) - (t - (error "Nothing to click on here."))))) - -(defun custom-reset-all () - "Undo any changes since the last apply in all fields." - (interactive (and custom-modified-list - (not (y-or-n-p "Discard all changes? ")) - (error "Reset aborted"))) - (let ((all custom-name-fields) - current field) - (while all - (setq current (car all) - field (cdr current) - all (cdr all)) - (custom-field-reset field)))) - -(defun custom-field-reset (field) - "Undo any changes in FIELD since the last apply." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (if (arrayp field) - (let* ((custom (custom-field-custom field)) - (name (custom-name custom))) - (save-excursion - (if name - (custom-field-original-set - field (car (custom-import custom (custom-external name))))) - (if (not (custom-valid custom (custom-field-original field))) - (error "This field cannot be reset alone") - (funcall (custom-property custom 'reset) field) - (funcall (custom-property custom 'synchronize) field)))))) - -(defun custom-factory-reset-all () - "Reset all field to their default values." - (interactive (and custom-modified-list - (not (y-or-n-p "Discard all changes? ")) - (error "Reset aborted"))) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (custom-field-factory-reset field)))) - -(defun custom-field-factory-reset (field) - "Reset FIELD to its default value." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (if (arrayp field) - (save-excursion - (funcall (custom-property (custom-field-custom field) 'factory-reset) - field)))) - -(defun custom-apply-all () - "Apply any changes since the last reset in all fields." - (interactive (if custom-modified-list - nil - (error "No changes to apply."))) - (custom-field-parse custom-field-last) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (let ((error (custom-field-validate (custom-field-custom field) field))) - (if (null error) - () - (goto-char (car error)) - (error (cdr error)))))) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (custom-field-apply field)))) - -(defun custom-field-apply (field) - "Apply any changes in FIELD since the last apply." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (custom-field-parse custom-field-last) - (if (arrayp field) - (let* ((custom (custom-field-custom field)) - (error (custom-field-validate custom field))) - (if error - (error (cdr error))) - (funcall (custom-property custom 'apply) field)))) - -(defun custom-toggle-hide (&rest ignore) - "Hide or show entry." - (interactive) - (error "This button is not yet implemented")) - -(defun custom-save-and-exit () - "Save and exit customization buffer." - (interactive "@") - (save-excursion - (funcall custom-save)) - (kill-buffer (current-buffer))) - -(defun custom-save () - "Save customization information." - (interactive) - (custom-apply-all) - (let ((new custom-name-fields)) - (set-buffer (find-file-noselect custom-file)) - (goto-char (point-min)) - (save-excursion - (let ((old (condition-case nil - (read (current-buffer)) - (end-of-file (append '(setq custom-dummy - 'custom-dummy) ()))))) - (or (eq (car old) 'setq) - (error "Invalid customization file: %s" custom-file)) - (while new - (let* ((field (cdr (car new))) - (custom (custom-field-custom field)) - (value (custom-field-original field)) - (default (car (custom-import custom (custom-default custom)))) - (name (car (car new)))) - (setq new (cdr new)) - (custom-assert '(eq name (custom-name custom))) - (if (equal default value) - (setcdr old (custom-plist-delq name (cdr old))) - (setcdr old (plist-put (cdr old) name - (car (custom-quote custom value))))))) - (erase-buffer) - (insert ";; " custom-file "\ - --- Automatically generated customization information. -;; -;; Feel free to edit by hand, but the entire content should consist of -;; a single setq. Any other lisp expressions will confuse the -;; automatic configuration engine. - -\(setq ") - (setq old (cdr old)) - (while old - (prin1 (car old) (current-buffer)) - (setq old (cdr old)) - (insert " ") - (pp (car old) (current-buffer)) - (setq old (cdr old)) - (if old (insert "\n "))) - (insert ")\n") - (save-buffer) - (kill-buffer (current-buffer)))))) - -(defun custom-load () - "Save customization information." - (interactive (and custom-modified-list - (not (equal (list (custom-name-field 'custom-file)) - custom-modified-list)) - (not (y-or-n-p "Discard all changes? ")) - (error "Load aborted"))) - (load-file (custom-name-value 'custom-file)) - (custom-reset-all)) - -;;; Field Editing: -;; -;; Various internal functions for implementing the direct editing of -;; fields in the customization buffer. - -(defun custom-field-untouch (field) - ;; Remove FIELD and its children from `custom-modified-list'. - (setq custom-modified-list (delq field custom-modified-list)) - (if (arrayp field) - (let ((value (custom-field-value field))) - (cond ((null (custom-data (custom-field-custom field)))) - ((arrayp value) - (custom-field-untouch value)) - ((listp value) - (mapcar 'custom-field-untouch value)))))) - - -(defun custom-field-insert (field) - ;; Insert editing FIELD in current buffer. - (let ((from (point)) - (custom (custom-field-custom field)) - (value (custom-field-value field))) - (insert (custom-write custom value)) - (insert-char (custom-padding custom) - (- (custom-width custom) (- (point) from))) - (custom-field-move field from (point)) - (custom-set-text-properties - from (point) - (list 'custom-field field - 'custom-tag field - 'face (custom-field-face field) - 'start-open t - 'end-open t)))) - -(defun custom-field-read (field) - ;; Read the screen content of FIELD. - (custom-read (custom-field-custom field) - (custom-buffer-substring-no-properties (custom-field-start field) - (custom-field-end field)))) - -;; Fields are shown in a special `active' face when point is inside -;; it. You activate the field by moving point inside (entering) it -;; and deactivate the field by moving point outside (leaving) it. - -(defun custom-field-leave (field) - ;; Deactivate FIELD. - (let ((before-change-functions nil) - (after-change-functions nil)) - (custom-put-text-property (custom-field-start field) (custom-field-end field) - 'face (custom-field-face field)))) - -(defun custom-field-enter (field) - ;; Activate FIELD. - (let* ((start (custom-field-start field)) - (end (custom-field-end field)) - (custom (custom-field-custom field)) - (padding (custom-padding custom)) - (before-change-functions nil) - (after-change-functions nil)) - (or (eq this-command 'self-insert-command) - (let ((pos end)) - (while (and (< start pos) - (eq (char-after (1- pos)) padding)) - (setq pos (1- pos))) - (if (< pos (point)) - (goto-char pos)))) - (custom-put-text-property start end 'face custom-field-active-face))) - -(defun custom-field-resize (field) - ;; Resize FIELD after change. - (let* ((custom (custom-field-custom field)) - (begin (custom-field-start field)) - (end (custom-field-end field)) - (pos (point)) - (padding (custom-padding custom)) - (width (custom-width custom)) - (size (- end begin))) - (cond ((< size width) - (goto-char end) - (if (fboundp 'insert-before-markers-and-inherit) - ;; Emacs 19. - (insert-before-markers-and-inherit - (make-string (- width size) padding)) - ;; XEmacs: BUG: Doesn't work! - (insert-before-markers (make-string (- width size) padding))) - (goto-char pos)) - ((> size width) - (let ((start (if (and (< (+ begin width) pos) (<= pos end)) - pos - (+ begin width)))) - (goto-char end) - (while (and (< start (point)) (= (preceding-char) padding)) - (backward-delete-char 1)) - (goto-char pos)))))) - -(defvar custom-field-changed nil) -;; List of fields changed on the screen but whose VALUE attribute has -;; not yet been updated to reflect the new screen content. -(make-variable-buffer-local 'custom-field-changed) - -(defun custom-field-parse (field) - ;; Parse FIELD content iff changed. - (if (memq field custom-field-changed) - (progn - (setq custom-field-changed (delq field custom-field-changed)) - (custom-field-value-set field (custom-field-read field)) - (custom-field-update field)))) - -(defun custom-post-command () - ;; Keep track of their active field. - (custom-assert '(eq major-mode 'custom-mode)) - (let ((field (custom-field-property (point)))) - (if (eq field custom-field-last) - (if (memq field custom-field-changed) - (custom-field-resize field)) - (custom-field-parse custom-field-last) - (if custom-field-last - (custom-field-leave custom-field-last)) - (if field - (custom-field-enter field)) - (setq custom-field-last field)) - (set-buffer-modified-p (or custom-modified-list - custom-field-changed)))) - -(defvar custom-field-was nil) -;; The custom data before the change. -(make-variable-buffer-local 'custom-field-was) - -(defun custom-before-change (begin end) - ;; Check that we the modification is allowed. - (if (not (eq major-mode 'custom-mode)) - (message "Aargh! Why is custom-before-change called here?") - (let ((from (custom-field-property begin)) - (to (custom-field-property end))) - (cond ((or (null from) (null to)) - (error "You can only modify the fields")) - ((not (eq from to)) - (error "Changes must be limited to a single field.")) - (t - (setq custom-field-was from)))))) - -(defun custom-after-change (begin end length) - ;; Keep track of field content. - (if (not (eq major-mode 'custom-mode)) - (message "Aargh! Why is custom-after-change called here?") - (let ((field custom-field-was)) - (custom-assert '(prog1 field (setq custom-field-was nil))) - ;; Prevent mixing fields properties. - (custom-put-text-property begin end 'custom-field field) - ;; Update the field after modification. - (if (eq (custom-field-property begin) field) - (let ((field-end (custom-field-end field))) - (if (> end field-end) - (set-marker field-end end)) - (add-to-list 'custom-field-changed field)) - ;; We deleted the entire field, reinsert it. - (custom-assert '(eq begin end)) - (save-excursion - (goto-char begin) - (custom-field-value-set field - (custom-read (custom-field-custom field) "")) - (custom-field-insert field)))))) - -(defun custom-field-property (pos) - ;; The `custom-field' text property valid for POS. - (or (get-text-property pos 'custom-field) - (and (not (eq pos (point-min))) - (get-text-property (1- pos) 'custom-field)))) - -;;; Generic Utilities: -;; -;; Some utility functions that are not really specific to custom. - -(defun custom-assert (expr) - "Assert that EXPR evaluates to non-nil at this point" - (or (eval expr) - (error "Assertion failed: %S" expr))) - -(defun custom-first-line (string) - "Return the part of STRING before the first newline." - (let ((pos 0) - (len (length string))) - (while (and (< pos len) (not (eq (aref string pos) ?\n))) - (setq pos (1+ pos))) - (if (eq pos len) - string - (substring string 0 pos)))) - -(defun custom-insert-before (list old new) - "In LIST insert before OLD a NEW element." - (cond ((null list) - (list new)) - ((null old) - (nconc list (list new))) - ((eq old (car list)) - (cons new list)) +(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 - (let ((list list)) - (while (not (eq old (car (cdr list)))) - (setq list (cdr list)) - (custom-assert '(cdr list))) - (setcdr list (cons new (cdr list)))) - list))) - -(defun custom-strip-padding (string padding) - "Remove padding from STRING." - (let ((regexp (concat (regexp-quote (char-to-string padding)) "+"))) - (while (string-match regexp string) - (setq string (concat (substring string 0 (match-beginning 0)) - (substring string (match-end 0)))))) - string) - -(defun custom-plist-memq (prop plist) - "Return non-nil if PROP is a property of PLIST. Comparison done with EQ." - (let (result) - (while plist - (if (eq (car plist) prop) - (setq result plist - plist nil) - (setq plist (cdr (cdr plist))))) - result)) - -(defun custom-plist-delq (prop plist) - "Delete property PROP from property list PLIST." - (while (eq (car plist) prop) - (setq plist (cdr (cdr plist)))) - (let ((list plist) - (next (cdr (cdr plist)))) - (while next - (if (eq (car next) prop) - (progn - (setq next (cdr (cdr next))) - (setcdr (cdr list) next)) - (setq list next - next (cdr (cdr next)))))) - plist) + (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)))))) -;;; Meta Customization: - -(custom-declare '() - '((tag . "Meta Customization") - (doc . "Customization of the customization support.") - (type . group) - (data ((type . face-doc)) - ((tag . "Button Face") - (default . bold) - (doc . "Face used for tags in customization buffers.") - (name . custom-button-face) - (synchronize . (lambda (f) - (custom-category-put 'custom-button-properties - 'face custom-button-face))) - (type . face)) - ((tag . "Mouse Face") - (default . highlight) - (doc . "\ -Face used when mouse is above a button in customization buffers.") - (name . custom-mouse-face) - (synchronize . (lambda (f) - (custom-category-put 'custom-button-properties - mouse-face - custom-mouse-face))) - (type . face)) - ((tag . "Field Face") - (default . italic) - (doc . "Face used for customization fields.") - (name . custom-field-face) - (type . face)) - ((tag . "Uninitialized Face") - (default . modeline) - (doc . "Face used for uninitialized customization fields.") - (name . custom-field-uninitialized-face) - (type . face)) - ((tag . "Invalid Face") - (default . highlight) - (doc . "\ -Face used for customization fields containing invalid data.") - (name . custom-field-invalid-face) - (type . face)) - ((tag . "Modified Face") - (default . bold-italic) - (doc . "Face used for modified customization fields.") - (name . custom-field-modified-face) - (type . face)) - ((tag . "Active Face") - (default . underline) - (doc . "\ -Face used for customization fields while they are being edited.") - (name . custom-field-active-face) - (type . face))))) - -;; custom.el uses two categories. - -(custom-category-create 'custom-documentation-properties) -(custom-category-put 'custom-documentation-properties rear-nonsticky t) - -(custom-category-create 'custom-button-properties) -(custom-category-put 'custom-button-properties 'face custom-button-face) -(custom-category-put 'custom-button-properties mouse-face custom-mouse-face) -(custom-category-put 'custom-button-properties rear-nonsticky t) - -(custom-category-create 'custom-hidden-properties) -(custom-category-put 'custom-hidden-properties 'invisible - (not (string-match "XEmacs" emacs-version))) -(custom-category-put 'custom-hidden-properties intangible t) +(if (string-match "XEmacs" emacs-version) + (autoload 'custom-menu-create "cus-edit") + (custom-menu-reset)) -(and init-file-user ; Don't load any init file if -q was used. - (file-readable-p custom-file) - (load-file custom-file)) +;;; The End. (provide 'custom) -;;; custom.el ends here +;; 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 |