Mercurial > hg > xemacs-beta
changeset 18:d95e72db5c07 r19-15b92
Import from CVS: tag r19-15b92
line wrap: on
line diff
--- a/CHANGES-beta Mon Aug 13 08:49:21 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 08:49:43 2007 +0200 @@ -1,4 +1,12 @@ -*- indented-text -*- +to 19.15 beta92 +-- gnus-5.4.11 +-- tm-7.103.1 +-- custom-1.24 +-- widget-1.24 +-- Corrections for dumping custom.elc with XEmacs +-- Miscellaneous bug fixes + to 19.15 beta91 -- Gnus-5.4.9 Courtesy of Lars Magne Ingebrigtsen -- Custom-1.20 Courtesy of Per Abrahamsen
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/custom-edit.el Mon Aug 13 08:49:43 2007 +0200 @@ -0,0 +1,1635 @@ +;;; custom-edit.el --- Tools for customization Emacs. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, faces +;; Version: 1.24 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `custom.el'. + +;;; Code: + +(require 'custom) +(require 'widget-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) + +;;; 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)) + +(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) + (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 (symbol) + "Customize FACE." + (interactive (list (completing-read "Customize face: " + obarray 'custom-facep))) + (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." + (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 ") + (widget-create 'info-link + :tag "help" + :help-echo "Push me for help." + "(custom)The Customization Buffer") + (widget-insert " for more information.\n\n") + (setq custom-options + (mapcar (lambda (entry) + (prog1 + (if (> (length options) 1) + (widget-create (nth 1 entry) + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry)) + ;; If there is only one entry, don't hide it! + (widget-create (nth 1 entry) + :custom-state 'unknown + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry))) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\n"))) + options)) + (mapcar 'custom-magic-reset custom-options) + (widget-create 'push-button + :tag "Set" + :help-echo "Push me to set all modifications." + :action (lambda (widget &optional event) + (custom-set))) + (widget-insert " ") + (widget-create 'push-button + :tag "Save" + :help-echo "Push me to make the modifications default." + :action (lambda (widget &optional event) + (custom-save))) + (widget-insert " ") + (widget-create 'push-button + :tag "Reset" + :help-echo "Push me to undo all modifications.." + :action (lambda (widget &optional event) + (custom-reset event))) + (widget-insert "\n") + (widget-setup)) + +;;; 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 "Push me to read the manual." + :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 "\ +Push me to 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 "\ +Push me to 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 "Push me to 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." + (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." + (widget-value-set widget (widget-value widget)) + (custom-redraw-magic widget)) + +(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 "Push me to 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)) + 'saved + 'set)) + ((setq tmp (get symbol 'saved-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'saved + 'set)) + ((setq tmp (get symbol 'factory-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'factory + 'set)) + (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 (symbol-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 (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. + +(defvar custom-face-edit-args + (mapcar (lambda (att) + (list 'group + :inline t + (list 'const :format "" :value (nth 0 att)) + (nth 1 att))) + custom-face-attributes)) + +(define-widget 'custom-face-edit 'checklist + "Edit face attributes." + :format "%t: %v" + :tag "Attributes" + :extra-offset 12 + :args (mapcar (lambda (att) + (list 'group + :inline t + (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 + :args '((const :tag "all" t) + (checklist :offset 0 + :extra-offset 9 + :args ((group (const :format "Type: " type) + (checklist :inline t + :offset 0 + (const :format "X " + x) + (const :format "PM " + pm) + (const :format "Win32 " + win32) + (const :format "DOS " + pc) + (const :format "TTY%n" + tty))) + (group (const :format "Class: " class) + (checklist :inline t + :offset 0 + (const :format "Color " + color) + (const :format + "Grayscale " + grayscale) + (const :format "Monochrome%n" + mono))) + (group (const :format "Background: " background) + (checklist :inline t + :offset 0 + (const :format "Light " + light) + (const :format "Dark\n" + 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 "Push me to set or reset this face." + :documentation-property 'face-documentation + :value-create 'custom-face-value-create + :action 'custom-face-action + :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)))))) + +(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)) + (custom-load-widget widget) + (let* ((symbol (widget-value widget)) + (edit (widget-create-child-and-convert + widget 'editable-list + :entry-format "%i %d %v" + :value (or (get symbol 'saved-face) + (get symbol 'factory-face)) + '(group :format "%v" + custom-display custom-face-edit)))) + (custom-face-state-set widget) + (widget-put widget :children (list edit))))) + +(defvar custom-face-menu + '(("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-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 (symbol-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) + (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))) + (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) + (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)) + (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 "Push me to 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) + (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)) + (children (mapcar (lambda (entry) + (widget-insert "\n") + (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))) + (mapcar 'custom-magic-reset children) + (widget-put widget :children children) + (custom-group-state-update widget))))) + +(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 (symbol-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 (eolp) + (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 (eolp) + (princ "\n"))))) + +(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))) + +(defun custom-group-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization group SYMBOL." + (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-menu-nesting (1- custom-menu-nesting)) + (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 () + "Update customize menu." + (interactive) + (add-hook 'custom-define-hook 'custom-menu-reset) + (let ((menu `(,(car custom-help-menu) + ,(widget-apply '(custom-group) :custom-menu 'emacs) + ,@(cdr (cdr custom-help-menu))))) + (if (fboundp 'add-submenu) + (add-submenu '("Help") menu) + (define-key global-map [menu-bar help-menu customize-menu] + (cons (car menu) (easy-menu-create-keymaps (car menu) (cdr menu))))))) + +;;; 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 'custom-edit) + +;; custom-edit.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/custom-opt.el Mon Aug 13 08:49:43 2007 +0200 @@ -0,0 +1,45 @@ +;;; custom-opt.el --- An option group. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, faces +;; Version: 1.24 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Code: + +(require 'custom) + +(defgroup options nil + "This group contains often used customization options." + :group 'emacs) + +(defvar custom-options + '((line-number-mode boolean) + (column-number-mode boolean) + (debug-on-error boolean) + (debug-on-quit boolean) + (case-fold-search boolean) + (case-replace boolean) + (transient-mark-mode boolean)) + "Alist of customization options. +The first element of each entry should be a variable name, the second +a widget type.") + +(let ((options custom-options) + option name type) + (while options + (setq option (car options) + options (cdr options) + name (nth 0 option) + type (nth 1 option)) + (put name 'custom-type type) + (custom-add-to-group 'options name 'custom-variable)) + (run-hooks 'custom-define-hook)) + +;;; The End. + +(provide 'custom-opt) + +;; custom-edit.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/custom.el Mon Aug 13 08:49:43 2007 +0200 @@ -0,0 +1,590 @@ +;;; custom.el -- Tools for declaring and initializing options. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, faces +;; Version: 1.24 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; If you want to use this code, please visit the URL above. +;; +;; This file only contain the code needed to declare and initialize +;; user options. The code to customize options is autoloaded from +;; `custom-edit.el'. + +;;; Code: + +(require 'widget) + +(define-widget-keywords :prefix :tag :load :link :options :type :group) + +;; These autoloads should be deleted when the file is added to Emacs +(autoload 'customize "custom-edit" nil t) +(autoload 'customize-variable "custom-edit" nil t) +(autoload 'customize-face "custom-edit" nil t) +(autoload 'customize-apropos "custom-edit" nil t) +(autoload 'customize-customized "custom-edit" nil t) +(autoload 'custom-buffer-create "custom-edit") +(autoload 'custom-menu-update "custom-edit") +(autoload 'custom-make-dependencies "custom-edit") + +;;; Compatibility. + +(unless (fboundp 'x-color-values) + ;; Emacs function missing in XEmacs 19.14. + (defun x-color-values (color) + "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)))) + +(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))) + +(defun custom-background-mode () + "Kludge to detext background mode." + (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 + (selected-frame) + 'background-color) + (color-instance-name + (specifier-instance + (face-background 'default)))) + (error nil))) + (< (apply '+ (x-color-values color)) + (/ (apply '+ (x-color-values "white")) + 3))) + 'dark) + (t 'light)))) + (modify-frame-parameters (selected-frame) + (list (cons 'background-mode mode))) + mode)) + +;; 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) + (defun custom-facep (face) + "Face symbol or object." + (or (facep face) + (find-face face)))) + (t + (defalias 'custom-facep 'facep))) + +;;; The `defcustom' Macro. + +;;;###autoload +(defun custom-declare-variable (symbol value doc &rest args) + "Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments." + (unless (and (default-boundp symbol) + (not (get symbol 'saved-value))) + (set-default symbol (if (get symbol 'saved-value) + (eval (car (get symbol 'saved-value))) + (eval value)))) + (put symbol 'factory-value (list value)) + (when doc + (put symbol 'variable-documentation doc)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :type) + (put symbol 'custom-type value)) + ((eq keyword :options) + (if (get symbol 'custom-options) + ;; Slow safe code to avoid duplicates. + (mapcar (lambda (option) + (custom-add-option symbol option)) + value) + ;; Fast code for the common case. + (put symbol 'custom-options (copy-list value)))) + (t + (custom-handle-keyword symbol keyword value + 'custom-variable)))))) + (run-hooks 'custom-define-hook) + symbol) + +;;;###autoload +(defmacro defcustom (symbol value doc &rest args) + "Declare SYMBOL as a customizable variable that defaults to VALUE. +DOC is the variable documentation. + +Neither SYMBOL nor VALUE needs to be quoted. +If SYMBOL is not already bound, initialize it to VALUE. +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:type VALUE should be a widget type. +:options VALUE should be a list of valid members of the widget type. +:group VALUE should be a customization group. + Add SYMBOL to that group. + +Read the section about customization in the emacs lisp manual for more +information." + `(eval-and-compile + (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))) + +;;; The `defface' Macro. + +;;;###autoload +(defun custom-declare-face (face spec doc &rest args) + "Like `defface', but FACE is evaluated as a normal argument." + (put face 'factory-face spec) + (when (fboundp 'facep) + (unless (and (custom-facep face) + (not (get face 'saved-face))) + ;; If the user has already created the face, respect that. + (let ((value (or (get face 'saved-face) spec))) + (custom-face-display-set face value)))) + (when doc + (put face 'face-documentation doc)) + (custom-handle-all-keywords face args 'custom-face) + (run-hooks 'custom-define-hook) + face) + +;;;###autoload +(defmacro defface (face spec doc &rest args) + "Declare FACE as a customizable face that defaults to SPEC. +FACE does not need to be quoted. + +Third argument DOC is the face documentation. + +If FACE has been set with `custom-set-face', set the face attributes +as specified by that function, otherwise set the face attributes +according to SPEC. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:group VALUE should be a customization group. + Add FACE to that group. + +SPEC should be an alist of the form ((DISPLAY ATTS)...). + +ATTS is a list of face attributes and their values. The possible +attributes are defined in the variable `custom-face-attributes'. +Alternatively, ATTS can be a face in which case the attributes of that +face is used. + +The ATTS of the first entry in SPEC where the DISPLAY matches the +frame should take effect in that frame. DISPLAY can either be the +symbol `t', which will match all frames, or an alist of the form +\((REQ ITEM...)...) + +For the DISPLAY to match a FRAME, the REQ property of the frame must +match one of the ITEM. The following REQ are defined: + +`type' (the value of (window-system)) + Should be one of `x' or `tty'. + +`class' (the frame's color support) + Should be one of `color', `grayscale', or `mono'. + +`background' (what color is used for the background text) + Should be one of `light' or `dark'. + +Read the section about customization in the emacs lisp manual for more +information." + `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) + +;;; The `defgroup' Macro. + +;;;###autoload +(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) + +;;;###autoload +(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)) + +;;;###autoload +(defun custom-add-to-group (group option widget) + "To existing GROUP add a new OPTION of type WIDGET, +If there already is an entry for that option, overwrite it." + (let* ((members (get group 'custom-group)) + (old (assq option members))) + (if old + (setcar (cdr old) widget) + (put group 'custom-group (nconc members (list (list option widget))))))) + +;;; Properties. + +(defun custom-handle-all-keywords (symbol args type) + "For customization option SYMBOL, handle keyword arguments ARGS. +Third argument TYPE is the custom option type." + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (custom-handle-keyword symbol keyword value type))))) + +(defun custom-handle-keyword (symbol keyword value type) + "For customization option SYMBOL, handle KEYWORD with VALUE. +Fourth argument TYPE is the custom option type." + (cond ((eq keyword :group) + (custom-add-to-group value symbol type)) + ((eq keyword :link) + (custom-add-link symbol value)) + ((eq keyword :load) + (custom-add-load symbol value)) + ((eq keyword :tag) + (put symbol 'custom-tag value)) + (t + (error "Unknown keyword %s" symbol)))) + +(defun custom-add-option (symbol option) + "To the variable SYMBOL add OPTION. + +If SYMBOL is a hook variable, OPTION should be a hook member. +For other types variables, the effect is undefined." + (let ((options (get symbol 'custom-options))) + (unless (member option options) + (put symbol 'custom-options (cons option options))))) + +(defun custom-add-link (symbol widget) + "To the custom option SYMBOL add the link WIDGET." + (let ((links (get symbol 'custom-links))) + (unless (member widget links) + (put symbol 'custom-links (cons widget links))))) + +(defun custom-add-load (symbol load) + "To the custom option SYMBOL add the dependency LOAD. +LOAD should be either a library file name, or a feature name." + (let ((loads (get symbol 'custom-loads))) + (unless (member load loads) + (put symbol 'custom-loads (cons load loads))))) + +;;; Face Utilities. + +(and (fboundp 'make-face) + (make-face 'custom-face-empty)) + +(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 'copy-face) + (copy-face 'custom-face-empty 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) + (apply 'custom-face-attribites-set face frame atts) + (setq spec nil)))))) + +(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-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! + (unless frame + (setq frame (selected-frame))) + (if (eq display t) + t + (let ((match t)) + (while (and display match) + (let* ((entry (car display)) + (req (car entry)) + (options (cdr entry))) + (setq display (cdr display)) + (cond ((eq req 'type) + (let ((type (if (fboundp 'device-type) + (device-type (frame-device frame)) + window-system))) + (setq match (memq type options)))) + ((eq req 'class) + (let ((class (if (fboundp 'device-class) + (device-class (frame-device frame)) + (frame-property frame 'display-type)))) + (setq match (memq class options)))) + ((eq req 'background) + (let ((background (or custom-background-mode + (frame-property frame 'background-mode) + (custom-background-mode)))) + (setq match (memq background options)))) + (t + (error "Unknown req `%S' with options `%S'" req options))))) + match))) + +(defconst custom-face-attributes + '((:bold (toggle :format "Bold: %v") custom-set-face-bold) + (:italic (toggle :format "Italic: %v") custom-set-face-italic) + (:underline + (toggle :format "Underline: %v") set-face-underline-p) + (:foreground (color :tag "Foreground") set-face-foreground) + (:background (color :tag "Background") set-face-background) + (:stipple (editable-field :format "Stipple: %v") set-face-stipple)) + "Alist of face attributes. + +The elements are of the form (KEY TYPE SET) 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. + +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.") + +(when (string-match "XEmacs" emacs-version) + ;; Support for special XEmacs font attributes. + (require 'font) + + (unless (fboundp 'face-font-name) + (defun face-font-name (face &rest args) + (apply 'face-font face args))) + + (defun set-face-font-size (face size &rest args) + "Set the font of FACE to SIZE" + (let* ((font (apply 'face-font-name face args)) + (fontobj (font-create-object font))) + (set-font-size fontobj size) + (apply 'set-face-font face fontobj args))) + + (defun set-face-font-family (face family &rest args) + "Set the font of FACE to FAMILY" + (let* ((font (apply 'face-font-name face args)) + (fontobj (font-create-object font))) + (set-font-family fontobj family) + (apply 'set-face-font face fontobj args))) + + (nconc custom-face-attributes + '((:family (editable-field :format "Family: %v") + set-face-font-family) + (:size (editable-field :format "Size: %v") + set-face-font-size)))) + +(defun custom-face-attribites-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) + (error nil))))) + +(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-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))) + +;;;###autoload +(defun custom-initialize-faces (&optional frame) + "Initialize all custom faces for FRAME. +If FRAME is nil or omitted, initialize them for all frames." + (mapatoms (lambda (symbol) + (let ((spec (or (get symbol 'saved-face) + (get symbol 'factory-face)))) + (when spec + (custom-face-display-set symbol spec frame)))))) + +;;; Initializing. + +;;;###autoload +(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))))))) + +;;;###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) + (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))))))) + +;;; Meta Customization + +(defgroup emacs nil + "Customization of the One True Editor." + :link '(custom-manual "(emacs)Top")) + +(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 'emacs) + +(defcustom custom-define-hook nil + "Hook called after defining each customize option." + :group 'customize + :type 'hook) + +;;; Menu support + +(defconst custom-help-menu '("Customize" + ["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) + (cond ((fboundp 'add-submenu) + ;; XEmacs with menus. + (add-submenu '("Help") custom-help-menu)) + ((string-match "XEmacs" emacs-version) + ;; XEmacs without menus. + ) + (t + ;; Emacs. + (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))))))) + +; (custom-menu-reset) + +;;; The End. + +(provide 'custom) + +;; custom.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/widget-edit.el Mon Aug 13 08:49:43 2007 +0200 @@ -0,0 +1,2202 @@ +;;; widget-edit.el --- Functions for creating and using widgets. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: extensions +;; Version: 1.24 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `widget.el'. + +;;; Code: + +(require 'widget) +(require 'cl) +(autoload 'pp-to-string "pp") +(autoload 'Info-goto-node "info") + +(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. +(eval-and-compile + (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 (&rest args) nil) + (defmacro defface (&rest args) nil) + (when (fboundp 'copy-face) + (copy-face 'default 'widget-documentation-face) + (copy-face 'bold 'widget-button-face) + (copy-face 'italic 'widget-field-face)) + (defvar widget-mouse-face 'highlight) + (defvar widget-menu-max-size 40))) + +;;; Compatibility. + +(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 'emacs) + +(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. + +(defun 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 "" + (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 + (cdr (assoc (completing-read (concat title ": ") + items nil t) + items))))) + +;;; 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))) + + (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 + '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 + 'face face + '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))) + (add-text-properties from to (list 'button widget + 'mouse-face widget-mouse-face + 'start-open t + 'end-open t + 'face face)))) + +(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))) + +;;; Widget Properties. + +(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'." + (cond ((widget-plist-member (cdr widget) property) + (plist-get (cdr widget) property)) + ((car widget) + (widget-get (get (car widget) 'widget-type) property)) + (t nil))) + +(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))) + +(defun widget-apply (widget property &rest args) + "Apply the value of WIDGET's PROPERTY to the widget itself. +ARGS are passed as extra argments 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))) + +;;; 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 Comands. + +(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 "\t" 'widget-forward) + (define-key widget-keymap "\M-\t" 'widget-backward) + (define-key widget-keymap [(shift tab)] 'widget-backward) + (define-key widget-keymap [(shift tab)] 'widget-backward) + (define-key widget-keymap [backtab] 'widget-backward) + (if (string-match "XEmacs" (emacs-version)) + (define-key widget-keymap [button2] 'widget-button-click) + (define-key widget-keymap [menu-bar] 'nil) + (define-key widget-keymap [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)) + (define-key widget-field-keymap "\C-m" 'widget-field-activate) + (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)) + (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 field :action event) + (call-interactively + (lookup-key widget-global-map (this-command-keys)))))) + +(defun widget-button-click (event) + "Activate button below mouse pointer." + (interactive "@e") + (widget-button-press (event-point event) event)) + +(defun widget-button-press (pos &optional event) + "Activate button at POS." + (interactive "@d") + (let* ((button (get-text-property pos 'button))) + (if button + (widget-apply button :action event) + (call-interactively + (lookup-key widget-global-map (this-command-keys)))))) + +(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"))))))))) + (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))))) + (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))) + +;;; 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) + :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)) + (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) + (if tag + (insert tag) + (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) + (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-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. + +(define-widget 'push-button 'item + "A pushable button." + :format "%[[%t]%]") + +;;; The `link' Widget. + +(define-widget 'link 'item + "An embedded link." + :help-echo "Push me to 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 'menu-choice + "Toggle between two states." + :convert-widget 'widget-toggle-convert-widget + :format "%v" + :on "on" + :off "off") + +(defun widget-toggle-convert-widget (widget) + ;; Create the types representing the `on' and `off' states. + (let ((on-type (widget-get widget :on-type)) + (off-type (widget-get widget :off-type))) + (unless on-type + (setq on-type + (list 'choice-item + :value t + :match (lambda (widget value) value) + :tag (widget-get widget :on)))) + (unless off-type + (setq off-type + (list 'choice-item :value nil :tag (widget-get widget :off)))) + (widget-put widget :args (list on-type off-type))) + widget) + +;;; The `checkbox' Widget. + +(define-widget 'checkbox 'toggle + "A checkbox toggle." + :convert-widget 'widget-item-convert-widget + :on-type '(choice-item :format "%[[X]%]" t) + :off-type '(choice-item :format "%[[ ]%]" nil)) + +;;; 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)) + (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 (widget-create-child-and-convert + widget 'checkbox :value (not (null chosen))))) + ((eq escape ?v) + (setq child + (cond ((not chosen) + (widget-create-child widget type)) + ((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 + :on-type '(choice-item :format "%[(*)%]" t) + :off-type '(choice-item :format "%[( )%]" nil)) + +(defun widget-radio-button-notify (widget child &optional event) + ;; Notify the parent. + (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)) + (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 (widget-create-child-and-convert + widget 'radio-button + :value (not (null chosen))))) + ((eq escape ?v) + (setq child (if chosen + (widget-create-child-value + widget type value) + (widget-create-child widget type)))) + (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 + (widget-value-set current value)) + (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-value button) + (widget-value-set button nil))))))) + ;; 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" + :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" + :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. + +(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. + (cond ((eq escape ?i) + (and (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (widget-create-child-and-convert widget 'insert-button)) + (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-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))) + 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 (widget-create-child-and-convert + widget 'insert-button))) + ((eq escape ?d) + (setq delete (widget-create-child-and-convert + widget 'delete-button))) + ((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 "Push me to toggle the 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 ": (defalt `" 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") + +;;; The `color' Widget. + +(define-widget 'color-item 'choice-item + "A color name (with sample)." + :format "%v (%[sample%])\n" + :button-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 "default" + :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 'widget-edit) + +;; widget-edit.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/widget-example.el Mon Aug 13 08:49:43 2007 +0200 @@ -0,0 +1,93 @@ +;;; widget-example.el -- example of using the widget library + +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, extensions, faces, hypermedia +;; Version: 1.24 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +(require 'widget) + +(eval-when-compile + (require 'widget-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\n") + (widget-create 'editable-field + :size 12 + :format "Name: %v " + "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))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/widget.el Mon Aug 13 08:49:43 2007 +0200 @@ -0,0 +1,70 @@ +;;; widget.el --- a library of user interface components. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> +;; Keywords: help, extensions, faces, hypermedia +;; Version: 1.24 +;; 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 `widget-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 :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) + +;; These autoloads should be deleted when the file is added to Emacs. +(autoload 'widget-create "widget-edit") +(autoload 'widget-insert "widget-edit") + +;;;###autoload +(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
--- a/lisp/gnus/ChangeLog Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/ChangeLog Mon Aug 13 08:49:43 2007 +0200 @@ -1,3 +1,60 @@ +Tue Feb 4 03:49:59 1997 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no> + + * gnus.el: Gnus v5.4.11 is released. + +Tue Feb 4 01:57:56 1997 Lars Magne Ingebrigtsen <larsi@ifi.uio.no> + + * nnvirtual.el (nnvirtual-last-accessed-component-group): New + variable. + (nnvirtual-request-article): Use it and allow fetching by + Message-ID. + + * gnus-dup.el (gnus-dup-enter-articles): Don't enter canceled + articles into dup lists. + + * nnvirtual.el (nnvirtual-update-read-and-marked): Check that we + have a current group. + + * message.el (message-mode): Add "field" menu under XEmacs. + +Mon Feb 3 07:46:33 1997 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no> + + * gnus.el: Gnus v5.4.10 is released. + +Mon Feb 3 05:48:09 1997 Lars Magne Ingebrigtsen <larsi@ifi.uio.no> + + * message.el (message-fcc-handler-function): Doc fix. + (message-do-fcc): Revert to 5.4.8 behavior. + + * gnus-util.el ((fboundp 'point-at-bol)): Made into defun. + + * gnus-topic.el (gnus-topic-check-topology): Skip "dummy.group". + (gnus-group-sort-topic): Delete "dummy.group". + + * gnus-art.el (article-make-date-line): Add a newline. + + * nnkiboze.el (nnkiboze-generate-group): Check that the nov file + exists. + + * gnus-sum.el (gnus-summary-make-menu-bar): Moved some. + + * gnus-art.el (gnus-article-make-menu-bar): Exclude the summary + menu. + + * gnus.el (gnus-similar-server-opened): New function. + (gnus-server-extend-method): Use it. + + * gnus-sum.el (gnus-data-set-header): New macro. + (gnus-summary-edit-article-done): Update when the Message-ID is + edited. + + * nnml.el (nnml-request-article): Return the correct group name. + +Sat Feb 1 21:29:56 1997 Lars Magne Ingebrigtsen <larsi@ifi.uio.no> + + * smiley.el (smiley-buffer): Use the `smiley-mouse-face' variable, + not face. + Sat Feb 1 14:19:54 1997 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no> * gnus.el: Gnus v5.4.9 is released.
--- a/lisp/gnus/custom-edit.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1634 +0,0 @@ -;;; custom-edit.el --- Tools for customization Emacs. -;; -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: help, faces -;; Version: 1.20 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Commentary: -;; -;; See `custom.el'. - -;;; Code: - -(require 'custom) -(require 'widget-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) - -;;; 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) - (funcall (intern "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)) - -(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) - (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 (symbol) - "Customize FACE." - (interactive (list (completing-read "Customize face: " - obarray 'custom-facep))) - (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." - (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 ") - (widget-create 'info-link - :tag "help" - :help-echo "Push me for help." - "(custom)The Customization Buffer") - (widget-insert " for more information.\n\n") - (setq custom-options - (mapcar (lambda (entry) - (prog1 - (if (> (length options) 1) - (widget-create (nth 1 entry) - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :value (nth 0 entry)) - ;; If there is only one entry, don't hide it! - (widget-create (nth 1 entry) - :custom-state 'unknown - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :value (nth 0 entry))) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (widget-insert "\n"))) - options)) - (mapcar 'custom-magic-reset custom-options) - (widget-create 'push-button - :tag "Set" - :help-echo "Push me to set all modifications." - :action (lambda (widget &optional event) - (custom-set))) - (widget-insert " ") - (widget-create 'push-button - :tag "Save" - :help-echo "Push me to make the modifications default." - :action (lambda (widget &optional event) - (custom-save))) - (widget-insert " ") - (widget-create 'push-button - :tag "Reset" - :help-echo "Push me to undo all modifications.." - :action (lambda (widget &optional event) - (custom-reset event))) - (widget-insert "\n") - (widget-setup)) - -;;; 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 "Push me to read the manual." - :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 "\ -Push me to 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 "\ -Push me to 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 "Push me to 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." - (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." - (widget-value-set widget (widget-value widget)) - (custom-redraw-magic widget)) - -(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 "Push me to 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)) - 'saved - 'set)) - ((setq tmp (get symbol 'saved-value)) - (if (condition-case nil - (equal value (eval (car tmp))) - (error nil)) - 'saved - 'set)) - ((setq tmp (get symbol 'factory-value)) - (if (condition-case nil - (equal value (eval (car tmp))) - (error nil)) - 'factory - 'set)) - (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 (symbol-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)) - (error "Invalid %S" val)) - ((eq form 'lisp) - (set symbol (eval (setq val (widget-value child)))) - (put symbol 'customized-value (list val))) - (t - (set symbol (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)) - (error "Invalid %S" val)) - ((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. - -(defvar custom-face-edit-args - (mapcar (lambda (att) - (list 'group - :inline t - (list 'const :format "" :value (nth 0 att)) - (nth 1 att))) - custom-face-attributes)) - -(define-widget 'custom-face-edit 'checklist - "Edit face attributes." - :format "%t: %v" - :tag "Attributes" - :extra-offset 12 - :args (mapcar (lambda (att) - (list 'group - :inline t - (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 - :args '((const :tag "all" t) - (checklist :offset 0 - :extra-offset 9 - :args ((group (const :format "Type: " type) - (checklist :inline t - :offset 0 - (const :format "X " - x) - (const :format "PM " - pm) - (const :format "Win32 " - win32) - (const :format "DOS " - pc) - (const :format "TTY%n" - tty))) - (group (const :format "Class: " class) - (checklist :inline t - :offset 0 - (const :format "Color " - color) - (const :format - "Grayscale " - grayscale) - (const :format "Monochrome%n" - mono))) - (group (const :format "Background: " background) - (checklist :inline t - :offset 0 - (const :format "Light " - light) - (const :format "Dark\n" - 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 "Push me to set or reset this face." - :documentation-property 'face-documentation - :value-create 'custom-face-value-create - :action 'custom-face-action - :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 - (state (widget-get widget :custom-state)) - (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)))))) - -(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)) - (custom-load-widget widget) - (let* ((symbol (widget-value widget)) - (edit (widget-create-child-and-convert - widget 'editable-list - :entry-format "%i %d %v" - :value (or (get symbol 'saved-face) - (get symbol 'factory-face)) - '(group :format "%v" - custom-display custom-face-edit)))) - (custom-face-state-set widget) - (widget-put widget :children (list edit))))) - -(defvar custom-face-menu - '(("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-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 (symbol-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) - (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))) - (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) - (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)) - (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 "Push me to 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) - (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)) - (children (mapcar (lambda (entry) - (widget-insert "\n") - (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))) - (mapcar 'custom-magic-reset children) - (widget-put widget :children children) - (custom-group-state-update widget))))) - -(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 (symbol-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 (eolp) - (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 (eolp) - (princ "\n"))))) - -(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))) - -(defun custom-group-menu-create (widget symbol) - "Ignoring WIDGET, create a menu entry for customization group SYMBOL." - (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-menu-nesting (1- custom-menu-nesting)) - (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 () - "Update customize menu." - (interactive) - (add-hook 'custom-define-hook 'custom-menu-reset) - (let ((menu `(,(car custom-help-menu) - ,(widget-apply '(custom-group) :custom-menu 'emacs) - ,@(cdr (cdr custom-help-menu))))) - (if (fboundp 'add-submenu) - (add-submenu '("Help") menu) - (define-key global-map [menu-bar help-menu customize-menu] - (cons (car menu) (easy-menu-create-keymaps (car menu) (cdr menu))))))) - -;;; 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 'custom-edit) - -;; custom-edit.el ends here
--- a/lisp/gnus/custom-opt.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -;;; custom-opt.el --- An option group. -;; -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: help, faces -;; Version: 1.20 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Code: - -(require 'custom) - -(defgroup options nil - "This group contains often used customization options." - :group 'emacs) - -(defvar custom-options - '((line-number-mode boolean) - (column-number-mode boolean) - (debug-on-error boolean) - (debug-on-quit boolean) - (case-fold-search boolean) - (case-replace boolean) - (transient-mark-mode boolean)) - "Alist of customization options. -The first element of each entry should be a variable name, the second -a widget type.") - -(let ((options custom-options) - option name type) - (while options - (setq option (car options) - options (cdr options) - name (nth 0 option) - type (nth 1 option)) - (put name 'custom-type type) - (custom-add-to-group 'options name 'custom-variable)) - (run-hooks 'custom-define-hook)) - -;;; The End. - -(provide 'custom-opt) - -;; custom-edit.el ends here
--- a/lisp/gnus/custom.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,584 +0,0 @@ -;;; custom.el -- Tools for declaring and initializing options. -;; -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: help, faces -;; Version: 1.20 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Commentary: -;; -;; If you want to use this code, please visit the URL above. -;; -;; This file only contain the code needed to declare and initialize -;; user options. The code to customize options is autoloaded from -;; `custom-edit.el'. - -;;; Code: - -(require 'widget) - -(define-widget-keywords :prefix :tag :load :link :options :type :group) - -;; These autoloads should be deleted when the file is added to Emacs -(autoload 'customize "custom-edit" nil t) -(autoload 'customize-variable "custom-edit" nil t) -(autoload 'customize-face "custom-edit" nil t) -(autoload 'customize-apropos "custom-edit" nil t) -(autoload 'customize-customized "custom-edit" nil t) -(autoload 'custom-buffer-create "custom-edit") -(autoload 'custom-menu-update "custom-edit") -(autoload 'custom-make-dependencies "custom-edit") - -;;; Compatibility. - -(unless (fboundp 'x-color-values) - ;; Emacs function missing in XEmacs 19.14. - (defun x-color-values (color) - "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)))) - -(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))) - -(defun custom-background-mode () - "Kludge to detext background mode." - (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 - (selected-frame) - 'background-color) - (color-instance-name - (specifier-instance - (face-background 'default)))) - (error nil))) - (< (apply '+ (x-color-values color)) - (/ (apply '+ (x-color-values "white")) - 3))) - 'dark) - (t 'light)))) - (modify-frame-parameters (selected-frame) - (list (cons 'background-mode mode))) - mode)) - -;; 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) - (defun custom-facep (face) - "Face symbol or object." - (or (facep face) - (find-face face)))) - (t - (defalias 'custom-facep 'facep))) - -;;; The `defcustom' Macro. - -;;;###autoload -(defun custom-declare-variable (symbol value doc &rest args) - "Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments." - (unless (and (default-boundp symbol) - (not (get symbol 'saved-value))) - (set-default symbol (if (get symbol 'saved-value) - (eval (car (get symbol 'saved-value))) - (eval value)))) - (put symbol 'factory-value (list value)) - (when doc - (put symbol 'variable-documentation doc)) - (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (cond ((eq keyword :type) - (put symbol 'custom-type value)) - ((eq keyword :options) - (if (get symbol 'custom-options) - ;; Slow safe code to avoid duplicates. - (mapcar (lambda (option) - (custom-add-option symbol option)) - value) - ;; Fast code for the common case. - (put symbol 'custom-options (copy-list value)))) - (t - (custom-handle-keyword symbol keyword value - 'custom-variable)))))) - (run-hooks 'custom-define-hook) - symbol) - -;;;###autoload -(defmacro defcustom (symbol value doc &rest args) - "Declare SYMBOL as a customizable variable that defaults to VALUE. -DOC is the variable documentation. - -Neither SYMBOL nor VALUE needs to be quoted. -If SYMBOL is not already bound, initialize it to VALUE. -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following KEYWORD's are defined: - -:type VALUE should be a widget type. -:options VALUE should be a list of valid members of the widget type. -:group VALUE should be a customization group. - Add SYMBOL to that group. - -Read the section about customization in the emacs lisp manual for more -information." - `(eval-and-compile - (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))) - -;;; The `defface' Macro. - -;;;###autoload -(defun custom-declare-face (face spec doc &rest args) - "Like `defface', but FACE is evaluated as a normal argument." - (put face 'factory-face spec) - (when (fboundp 'facep) - (unless (and (custom-facep face) - (not (get face 'saved-face))) - ;; If the user has already created the face, respect that. - (let ((value (or (get face 'saved-face) spec))) - (custom-face-display-set face value)))) - (when doc - (put face 'face-documentation doc)) - (custom-handle-all-keywords face args 'custom-face) - (run-hooks 'custom-define-hook) - face) - -;;;###autoload -(defmacro defface (face spec doc &rest args) - "Declare FACE as a customizable face that defaults to SPEC. -FACE does not need to be quoted. - -Third argument DOC is the face documentation. - -If FACE has been set with `custom-set-face', set the face attributes -as specified by that function, otherwise set the face attributes -according to SPEC. - -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following KEYWORD's are defined: - -:group VALUE should be a customization group. - Add FACE to that group. - -SPEC should be an alist of the form ((DISPLAY ATTS)...). - -ATTS is a list of face attributes and their values. The possible -attributes are defined in the variable `custom-face-attributes'. -Alternatively, ATTS can be a face in which case the attributes of that -face is used. - -The ATTS of the first entry in SPEC where the DISPLAY matches the -frame should take effect in that frame. DISPLAY can either be the -symbol `t', which will match all frames, or an alist of the form -\((REQ ITEM...)...) - -For the DISPLAY to match a FRAME, the REQ property of the frame must -match one of the ITEM. The following REQ are defined: - -`type' (the value of (window-system)) - Should be one of `x' or `tty'. - -`class' (the frame's color support) - Should be one of `color', `grayscale', or `mono'. - -`background' (what color is used for the background text) - Should be one of `light' or `dark'. - -Read the section about customization in the emacs lisp manual for more -information." - `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) - -;;; The `defgroup' Macro. - -;;;###autoload -(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) - -;;;###autoload -(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)) - -;;;###autoload -(defun custom-add-to-group (group option widget) - "To existing GROUP add a new OPTION of type WIDGET, -If there already is an entry for that option, overwrite it." - (let* ((members (get group 'custom-group)) - (old (assq option members))) - (if old - (setcar (cdr old) widget) - (put group 'custom-group (nconc members (list (list option widget))))))) - -;;; Properties. - -(defun custom-handle-all-keywords (symbol args type) - "For customization option SYMBOL, handle keyword arguments ARGS. -Third argument TYPE is the custom option type." - (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (custom-handle-keyword symbol keyword value type))))) - -(defun custom-handle-keyword (symbol keyword value type) - "For customization option SYMBOL, handle KEYWORD with VALUE. -Fourth argument TYPE is the custom option type." - (cond ((eq keyword :group) - (custom-add-to-group value symbol type)) - ((eq keyword :link) - (custom-add-link symbol value)) - ((eq keyword :load) - (custom-add-load symbol value)) - ((eq keyword :tag) - (put symbol 'custom-tag value)) - (t - (error "Unknown keyword %s" symbol)))) - -(defun custom-add-option (symbol option) - "To the variable SYMBOL add OPTION. - -If SYMBOL is a hook variable, OPTION should be a hook member. -For other types variables, the effect is undefined." - (let ((options (get symbol 'custom-options))) - (unless (member option options) - (put symbol 'custom-options (cons option options))))) - -(defun custom-add-link (symbol widget) - "To the custom option SYMBOL add the link WIDGET." - (let ((links (get symbol 'custom-links))) - (unless (member widget links) - (put symbol 'custom-links (cons widget links))))) - -(defun custom-add-load (symbol load) - "To the custom option SYMBOL add the dependency LOAD. -LOAD should be either a library file name, or a feature name." - (let ((loads (get symbol 'custom-loads))) - (unless (member load loads) - (put symbol 'custom-loads (cons load loads))))) - -;;; Face Utilities. - -(and (fboundp 'make-face) - (make-face 'custom-face-empty)) - -(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 'copy-face) - (copy-face 'custom-face-empty 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) - (apply 'custom-face-attribites-set face frame atts) - (setq spec nil)))))) - -(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-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! - (unless frame - (setq frame (selected-frame))) - (if (eq display t) - t - (let ((match t)) - (while (and display match) - (let* ((entry (car display)) - (req (car entry)) - (options (cdr entry))) - (setq display (cdr display)) - (cond ((eq req 'type) - (let ((type (if (fboundp 'device-type) - (device-type (frame-device frame)) - window-system))) - (setq match (memq type options)))) - ((eq req 'class) - (let ((class (if (fboundp 'device-class) - (device-class (frame-device frame)) - (frame-property frame 'display-type)))) - (setq match (memq class options)))) - ((eq req 'background) - (let ((background (or custom-background-mode - (frame-property frame 'background-mode) - (custom-background-mode)))) - (setq match (memq background options)))) - (t - (error "Unknown req `%S' with options `%S'" req options))))) - match))) - -(defconst custom-face-attributes - '((:bold (toggle :format "Bold: %v") custom-set-face-bold) - (:italic (toggle :format "Italic: %v") custom-set-face-italic) - (:underline - (toggle :format "Underline: %v") set-face-underline-p) - (:foreground (color :tag "Foreground") set-face-foreground) - (:background (color :tag "Background") set-face-background) - (:stipple (editable-field :format "Stipple: %v") set-face-stipple)) - "Alist of face attributes. - -The elements are of the form (KEY TYPE SET) 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. - -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.") - -(when (string-match "XEmacs" emacs-version) - ;; Support for special XEmacs font attributes. - (require 'font) - - (unless (fboundp 'face-font-name) - (defun face-font-name (face &rest args) - (apply 'face-font face args))) - - (defun set-face-font-size (face size &rest args) - "Set the font of FACE to SIZE" - (let* ((font (apply 'face-font-name face args)) - (fontobj (font-create-object font))) - (set-font-size fontobj size) - (apply 'set-face-font face fontobj args))) - - (defun set-face-font-family (face family &rest args) - "Set the font of FACE to FAMILY" - (let* ((font (apply 'face-font-name face args)) - (fontobj (font-create-object font))) - (set-font-family fontobj family) - (apply 'set-face-font face fontobj args))) - - (nconc custom-face-attributes - '((:family (editable-field :format "Family: %v") - set-face-font-family) - (:size (editable-field :format "Size: %v") - set-face-font-size)))) - -(defun custom-face-attribites-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) - (error nil))))) - -(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-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))) - -;;;###autoload -(defun custom-initialize-faces (&optional frame) - "Initialize all custom faces for FRAME. -If FRAME is nil or omitted, initialize them for all frames." - (mapatoms (lambda (symbol) - (let ((spec (or (get symbol 'saved-face) - (get symbol 'factory-face)))) - (when spec - (custom-face-display-set symbol spec frame)))))) - -;;; Initializing. - -;;;###autoload -(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))))))) - -;;;###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) - (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))))))) - -;;; Meta Customization - -(defgroup emacs nil - "Customization of the One True Editor." - :link '(custom-manual "(emacs)Top")) - -(defgroup customize nil - "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 'emacs) - -(defcustom custom-define-hook nil - "Hook called after defining each customize option." - :group 'customize - :type 'hook) - -;;; Menu support - -(defconst custom-help-menu '("Customize" - ["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 (fboundp 'add-submenu) - (add-submenu '("Help") 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)))))) - -(custom-menu-reset) - -;;; The End. - -(provide 'custom) - -;; custom.el ends here
--- a/lisp/gnus/gnus-art.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-art.el Mon Aug 13 08:49:43 2007 +0200 @@ -1162,8 +1162,8 @@ ;; Delete any old Date headers. (if (re-search-forward date-regexp nil t) (progn - (setq bface (get-text-property (point-at-bol) 'face) - eface (get-text-property (1- (point-at-eol)) + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) 'face)) (message-remove-header date-regexp t) (beginning-of-line)) @@ -1201,11 +1201,13 @@ (concat "Date: " date "\n")) ;; Let the user define the format. ((eq type 'user) - (format-time-string gnus-article-time-format - (ignore-errors - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT"))))) + (concat + (format-time-string gnus-article-time-format + (ignore-errors + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT")))) + "\n")) ;; Do an X-Sent lapsed format. ((eq type 'lapsed) ;; If the date is seriously mangled, the timezone functions are @@ -1704,9 +1706,10 @@ ["Remove carriage return" gnus-article-remove-cr t] ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) - (when (boundp 'gnus-summary-article-menu) - (define-key gnus-article-mode-map [menu-bar commands] - (cons "Commands" gnus-summary-article-menu))) + (when nil + (when (boundp 'gnus-summary-article-menu) + (define-key gnus-article-mode-map [menu-bar commands] + (cons "Commands" gnus-summary-article-menu)))) (when (boundp 'gnus-summary-post-menu) (define-key gnus-article-mode-map [menu-bar post]
--- a/lisp/gnus/gnus-dup.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-dup.el Mon Aug 13 08:49:43 2007 +0200 @@ -117,6 +117,7 @@ (when (and (not (gnus-data-pseudo-p datum)) (> (gnus-data-number datum) 0) (gnus-data-read-p datum) + (not (= (gnus-data-mark datum) gnus-canceled-mark)) (setq msgid (mail-header-id (gnus-data-header datum))) (not (nnheader-fake-message-id-p msgid)) (not (intern-soft msgid gnus-dup-hashtb)))
--- a/lisp/gnus/gnus-edit.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,630 +0,0 @@ -;;; gnus-edit.el --- Gnus SCORE file editing -;; Copyright (C) 1995,96 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@iesd.auc.dk> -;; Keywords: news, help -;; Version: 0.2 - -;;; Commentary: -;; -;; Type `M-x gnus-score-customize RET' to invoke. - -;;; Code: - -(require 'custom) -(require 'gnus-score) -(eval-when-compile (require 'cl)) - -(defconst gnus-score-custom-data - '((tag . "Score") - (doc . "Customization of Gnus SCORE files. - -SCORE files allow you to assign a score to each article when you enter -a group, and automatically mark the articles as read or delete them -based on the score. In the summary buffer you can use the score to -sort the articles by score (`C-c C-s C-s') or to jump to the unread -article with the highest score (`,').") - (type . group) - (data "\n" - ((header . nil) - (doc . "Name of SCORE file to customize. - -Enter the name in the `File' field, then push the [Load] button to -load it. When done editing, push the [Save] button to save the file. - -Several score files may apply to each group, and several groups may -use the same score file. This is controlled implicitly by the name of -the score file and the value of the global variable -`gnus-score-find-score-files-function', and explicitly by the -`Files' and `Exclude Files' entries.") - (compact . t) - (type . group) - (data ((tag . "Load") - (type . button) - (query . gnus-score-custom-load)) - ((tag . "Save") - (type . button) - (query . gnus-score-custom-save)) - ((name . file) - (tag . "File") - (directory . gnus-kill-files-directory) - (default-file . "SCORE") - (type . file)))) - ((name . files) - (tag . "Files") - (doc . "\ -List of score files to load when the current score file is loaded. -You can use this to share score entries between multiple score files. - -Push the `[INS]' button add a score file to the list, or `[DEL]' to -delete a score file from the list.") - (type . list) - (data ((type . repeat) - (header . nil) - (data (type . file) - (directory . gnus-kill-files-directory))))) - ((name . exclude-files) - (tag . "Exclude Files") - (doc . "\ -List of score files to exclude when the current score file is loaded. -You can use this if you have a score file you want to share between a -number of newsgroups, except for the newsgroup this score file -matches. [ Did anyone get that? ] - -Push the `[INS]' button add a score file to the list, or `[DEL]' to -delete a score file from the list.") - (type . list) - (data ((type . repeat) - (header . nil) - (data (type . file) - (directory . gnus-kill-files-directory))))) - ((name . mark) - (tag . "Mark") - (doc . "\ -Articles below this score will be automatically marked as read. - -This means that when you enter the summary buffer, the articles will -be shown but will already be marked as read. You can then press `x' -to get rid of them entirely. - -By default articles with a negative score will be marked as read. To -change this, push the `Mark' button, and choose `Integer'. You can -then enter a value in the `Mark' field.") - (type . gnus-score-custom-maybe-type)) - ((name . expunge) - (tag . "Expunge") - (doc . "\ -Articles below this score will not be shown in the summary buffer.") - (type . gnus-score-custom-maybe-type)) - ((name . mark-and-expunge) - (tag . "Mark and Expunge") - (doc . "\ -Articles below this score will be marked as read, but not shown. - -Someone should explain me the difference between this and `expunge' -alone or combined with `mark'.") - (type . gnus-score-custom-maybe-type)) - ((name . eval) - (tag . "Eval") - (doc . "\ -Evaluate this lisp expression when the entering summary buffer.") - (type . sexp)) - ((name . read-only) - (tag . "Read Only") - (doc . "Read-only score files will not be updated or saved. -Except from this buffer, of course!") - (type . toggle)) - ((type . doc) - (doc . "\ -Each news header has an associated list of score entries. -You can use the [INS] buttons to add new score entries anywhere in the -list, or the [DEL] buttons to delete specific score entries. - -Each score entry should specify a string that should be matched with -the content actual header in order to determine whether the entry -applies to that header. Enter that string in the `Match' field. - -If the score entry matches, the articles score will be adjusted with -some amount. Enter that amount in the in the `Score' field. You -should specify a positive amount for score entries that matches -articles you find interesting, and a negative amount for score entries -matching articles you would rather avoid. The final score for the -article will be the sum of the score of all score entries that match -the article. - -The score entry can be either permanent or expirable. To make the -entry permanent, push the `Date' button and choose the `Permanent' -entry. To make the entry expirable, choose instead the `Integer' -entry. After choosing the you can enter the date the score entry was -last matched in the `Date' field. The date will be automatically -updated each time the score entry matches an article. When the date -become too old, the score entry will be removed. - -For your convenience, the date is specified as the number of days -elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 -BC. - -Finally, you can choose what kind of match you want to perform by -pushing the `Type' button. For most entries you can choose between -`Exact' which mean the header content must be exactly identical to the -match string, or `Substring' meaning the match string should be -somewhere in the header content, or even `Regexp' to use Emacs regular -expression matching. The last choice is `Fuzzy' which is like `Exact' -except that whitespace derivations, a beginning `Re:' or a terminating -parenthetical remark are all ignored. Each of the four types have a -variant which will ignore case in the comparison. That variant is -indicated with a `(fold)' after its name.")) - ((name . from) - (tag . "From") - (doc . "Scoring based on the authors email address.") - (type . gnus-score-custom-string-type)) - ((name . subject) - (tag . "Subject") - (doc . "Scoring based on the articles subject.") - (type . gnus-score-custom-string-type)) - ((name . followup) - (tag . "Followup") - (doc . "Scoring based on who the article is a followup to. - -If you want to see all followups to your own articles, add an entry -with a positive score matching your email address here. You can also -put an entry with a negative score matching someone who is so annoying -that you don't even want to see him quoted in followups.") - (type . gnus-score-custom-string-type)) - ((name . xref) - (tag . "Xref") - (doc . "Scoring based on article crossposting. - -If you want to score based on which newsgroups an article is posted -to, this is the header to use. The syntax is a little different from -the `Newsgroups' header, but scoring in `Xref' is much faster. As an -example, to match all crossposted articles match on `:.*:' using the -`Regexp' type.") - (type . gnus-score-custom-string-type)) - ((name . references) - (tag . "References") - (doc . "Scoring based on article references. - -The `References' header gives you an alternative way to score on -followups. If you for example want to see follow all discussions -where people from `iesd.auc.dk' school participate, you can add a -substring match on `iesd.auc.dk>' on this header.") - (type . gnus-score-custom-string-type)) - ((name . message-id) - (tag . "Message-ID") - (doc . "Scoring based on the articles message-id. - -This isn't very useful, but Lars like completeness. You can use it to -match all messaged generated by recent Gnus version with a `Substring' -match on `.fsf@'.") - (type . gnus-score-custom-string-type)) - ((type . doc) - (doc . "\ -WARNING: Scoring on the following three pseudo headers is very slow! -Scoring on any of the real headers use a technique that avoids -scanning the entire article, only the actual headers you score on are -scanned, and this scanning has been heavily optimized. Using just a -single entry for one the three pseudo-headers `Head', `Body', and -`All' will require GNUS to retrieve and scan the entire article, which -can be very slow on large groups. However, if you add one entry for -any of these headers, you can just as well add several. Each -subsequent entry cost relatively little extra time.")) - ((name . head) - (tag . "Head") - (doc . "Scoring based on the article header. - -Instead of matching the content of a single header, the entire header -section of the article is matched. You can use this to match on -arbitrary headers, foe example to single out TIN lusers, use a substring -match on `Newsreader: TIN'. That should get 'em!") - (type . gnus-score-custom-string-type)) - ((name . body) - (tag . "Body") - (doc . "Scoring based on the article body. - -If you think any article that mentions `Kibo' is inherently -interesting, do a substring match on His name. You Are Allowed.") - (type . gnus-score-custom-string-type)) - ((name . all) - (tag . "All") - (doc . "Scoring based on the whole article.") - (type . gnus-score-custom-string-type)) - ((name . date) - (tag . "Date") - (doc . "Scoring based on article date. - -You can change the score of articles that have been posted before, -after, or at a specific date. You should add the date in the `Match' -field, and then select `before', `after', or `at' by pushing the -`Type' button. Imagine you want to lower the score of very old -articles, or want to raise the score of articles from the future (such -things happen!). Then you can't use date scoring for that. In fact, -I can't imagine anything you would want to use this for. - -For your convenience, the date is specified in Usenet date format.") - (type . gnus-score-custom-date-type)) - ((type . doc) - (doc . "\ -The Lines and Chars headers use integer based scoring. - -This means that you should write an integer in the `Match' field, and -the push the `Type' field to if the `Chars' or `Lines' header should -be larger, equal, or smaller than the number you wrote in the match -field.")) - ((name . chars) - (tag . "Characters") - (doc . "Scoring based on the number of characters in the article.") - (type . gnus-score-custom-integer-type)) - ((name . lines) - (tag . "Lines") - (doc . "Scoring based on the number of lines in the article.") - (type . gnus-score-custom-integer-type)) - ((name . orphan) - (tag . "Orphan") - (doc . "Score to add to articles with no parents.") - (type . gnus-score-custom-maybe-type)) - ((name . adapt) - (tag . "Adapt") - (doc . "Adapting the score files to your newsreading habits. - -When you have finished reading a group GNUS can automatically create -new score entries based on which articles you read and which you -skipped. This is normally controlled by the two global variables -`gnus-use-adaptive-scoring' and `gnus-default-adaptive-score-alist', -The first determines whether adaptive scoring should be enabled or -not, while the second determines what score entries should be created. - -You can overwrite the setting of `gnus-use-adaptive-scoring' by -selecting `Enable' or `Disable' by pressing the `Adapt' button. -Selecting `Custom' will allow you to specify the exact adaptation -rules (overwriting `gnus-default-adaptive-score-alist').") - (type . choice) - (data ((tag . "Default") - (default . nil) - (type . const)) - ((tag . "Enable") - (default . t) - (type . const)) - ((tag . "Disable") - (default . ignore) - (type . const)) - ((tag . "Custom") - (doc . "Customization of adaptive scoring. - -Each time you read an article it will be marked as read. Likewise, if -you delete it, it will be marked as deleted, and if you tick it, it will -be marked as ticked. When you leave a group, GNUS can automatically -create score file entries based on these marks, so next time you enter -the group articles with subjects that you read last time have higher -score and articles with subjects that deleted will have lower score. - -Below is a list of such marks. You can insert new marks to the list -by pushing on one of the `[INS]' buttons in the left margin to create -a new entry and then pushing the `Mark' button to select the mark. -For each mark there is another list, this time of article headers, -which determine how the mark should affect that header. The `[INS]' -buttons of this list are indented to indicate that the belong to the -mark above. Push the `Header' button to choose a header, and then -enter a score value in the `Score' field. - -For each article that are marked with `Mark' when you leave the -group, a temporary score entry for the articles `Header' with the -value of `Score' will be added the adapt file. If the score entry -already exists, `Score' will be added to its value. If you understood -that, you are smart. - -You can select the special value `Other' when pressing the `Mark' or -`Header' buttons. This is because Lars might add more useful values -there. If he does, it is up to you to figure out what they are named.") - (type . list) - (default . ((__uninitialized__))) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (header . nil) - (compact . t) - (data ((type . choice) - (tag . "Mark") - (data ((tag . "Unread") - (default . gnus-unread-mark) - (type . const)) - ((tag . "Ticked") - (default . gnus-ticked-mark) - (type . const)) - ((tag . "Dormant") - (default . gnus-dormant-mark) - (type . const)) - ((tag . "Deleted") - (default . gnus-del-mark) - (type . const)) - ((tag . "Read") - (default . gnus-read-mark) - (type . const)) - ((tag . "Expirable") - (default . gnus-expirable-mark) - (type . const)) - ((tag . "Killed") - (default . gnus-killed-mark) - (type . const)) - ((tag . "Kill-file") - (default . gnus-kill-file-mark) - (type . const)) - ((tag . "Low-score") - (default . gnus-low-score-mark) - (type . const)) - ((tag . "Catchup") - (default . gnus-catchup-mark) - (type . const)) - ((tag . "Ancient") - (default . gnus-ancient-mark) - (type . const)) - ((tag . "Canceled") - (default . gnus-canceled-mark) - (type . const)) - ((prompt . "Other") - (default . ??) - (type . sexp)))) - ((type . repeat) - (prefix . " ") - (data . ((type . list) - (compact . t) - (data ((tag . "Header") - (type . choice) - (data ((tag . "Subject") - (default . subject) - (type . const)) - ((prompt . "From") - (tag . "From ") - (default . from) - (type . const)) - ((prompt . "Other") - (width . 7) - (default . nil) - (type . symbol)))) - ((tag . "Score") - (type . integer)))))))))))))) - ((name . local) - (tag . "Local") - (doc . "\ -List of local variables to set when this score file is loaded. - -Using this entry can provide a convenient way to set variables that -will affect the summary mode for only some specific groups, i.e. those -groups matched by the current score file.") - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Name") - (width . 26) - (type . symbol)) - ((tag . "Value") - (width . 26) - (type . sexp))))))))))) - -(defconst gnus-score-custom-type-properties - '((gnus-score-custom-maybe-type - (type . choice) - (data ((type . integer) - (default . 0)) - ((tag . "Default") - (type . const) - (default . nil)))) - (gnus-score-custom-string-type - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Match") - (width . 59) - (type . string)) - "\n " - ((tag . "Score") - (type . integer)) - ((tag . "Date") - (type . choice) - (data ((type . integer) - (default . 0) - (width . 9)) - ((tag . "Permanent") - (type . const) - (default . nil)))) - ((tag . "Type") - (type . choice) - (data ((tag . "Exact") - (default . E) - (type . const)) - ((tag . "Substring") - (default . S) - (type . const)) - ((tag . "Regexp") - (default . R) - (type . const)) - ((tag . "Fuzzy") - (default . F) - (type . const)) - ((tag . "Exact (fold)") - (default . e) - (type . const)) - ((tag . "Substring (fold)") - (default . s) - (type . const)) - ((tag . "Regexp (fold)") - (default . r) - (type . const)) - ((tag . "Fuzzy (fold)") - (default . f) - (type . const)))))))))) - (gnus-score-custom-integer-type - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Match") - (type . integer)) - ((tag . "Score") - (type . integer)) - ((tag . "Date") - (type . choice) - (data ((type . integer) - (default . 0) - (width . 9)) - ((tag . "Permanent") - (type . const) - (default . nil)))) - ((tag . "Type") - (type . choice) - (data ((tag . "<") - (default . <) - (type . const)) - ((tag . ">") - (default . >) - (type . const)) - ((tag . "=") - (default . =) - (type . const)) - ((tag . ">=") - (default . >=) - (type . const)) - ((tag . "<=") - (default . <=) - (type . const)))))))))) - (gnus-score-custom-date-type - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Match") - (width . 59) - (type . string)) - "\n " - ((tag . "Score") - (type . integer)) - ((tag . "Date") - (type . choice) - (data ((type . integer) - (default . 0) - (width . 9)) - ((tag . "Permanent") - (type . const) - (default . nil)))) - ((tag . "Type") - (type . choice) - (data ((tag . "Before") - (default . before) - (type . const)) - ((tag . "After") - (default . after) - (type . const)) - ((tag . "At") - (default . at) - (type . const)))))))))))) - -(defvar gnus-score-custom-file nil - "Name of SCORE file being customized.") - -(defun gnus-score-customize () - "Create a buffer for editing gnus SCORE files." - (interactive) - (let (gnus-score-alist) - (custom-buffer-create "*Score Edit*" gnus-score-custom-data - gnus-score-custom-type-properties - 'gnus-score-custom-set - 'gnus-score-custom-get - 'gnus-score-custom-save)) - (make-local-variable 'gnus-score-custom-file) - (setq gnus-score-custom-file - (expand-file-name "SCORE" gnus-kill-files-directory)) - (make-local-variable 'gnus-score-alist) - (setq gnus-score-alist nil) - (custom-reset-all)) - -(defun gnus-score-custom-get (name) - (if (eq name 'file) - gnus-score-custom-file - (let ((entry (assoc (symbol-name name) gnus-score-alist))) - (if entry - (mapcar 'gnus-score-custom-sanify (cdr entry)) - (setq entry (assoc name gnus-score-alist)) - (if (or (memq name '(files exclude-files local)) - (and (eq name 'adapt) - (not (symbolp (car (cdr entry)))))) - (cdr entry) - (car (cdr entry))))))) - -(defun gnus-score-custom-set (name value) - (cond ((eq name 'file) - (setq gnus-score-custom-file value)) - ((assoc (symbol-name name) gnus-score-alist) - (if value - (setcdr (assoc (symbol-name name) gnus-score-alist) value) - (setq gnus-score-alist (delq (assoc (symbol-name name) - gnus-score-alist) - gnus-score-alist)))) - ((assoc (symbol-name name) gnus-header-index) - (if value - (setq gnus-score-alist - (cons (cons (symbol-name name) value) gnus-score-alist)))) - ((assoc name gnus-score-alist) - (cond ((null value) - (setq gnus-score-alist (delq (assoc name gnus-score-alist) - gnus-score-alist))) - ((and (listp value) (not (eq name 'eval))) - (setcdr (assoc name gnus-score-alist) value)) - (t - (setcdr (assoc name gnus-score-alist) (list value))))) - ((null value)) - ((and (listp value) (not (eq name 'eval))) - (setq gnus-score-alist (cons (cons name value) gnus-score-alist))) - (t - (setq gnus-score-alist - (cons (cons name (list value)) gnus-score-alist))))) - -(defun gnus-score-custom-sanify (entry) - (list (nth 0 entry) - (or (nth 1 entry) gnus-score-interactive-default-score) - (nth 2 entry) - (cond ((null (nth 3 entry)) - 's) - ((memq (nth 3 entry) '(before after at >= <=)) - (nth 3 entry)) - (t - (intern (substring (symbol-name (nth 3 entry)) 0 1)))))) - -(defvar gnus-score-cache nil) - -(defun gnus-score-custom-load () - (interactive) - (let ((file (custom-name-value 'file))) - (if (eq file custom-nil) - (error "You must specify a file name")) - (setq file (expand-file-name file gnus-kill-files-directory)) - (gnus-score-load file) - (setq gnus-score-custom-file file) - (custom-reset-all) - (gnus-message 4 "Loaded"))) - -(defun gnus-score-custom-save () - (interactive) - (custom-apply-all) - (gnus-score-remove-from-cache gnus-score-custom-file) - (let ((file gnus-score-custom-file) - (score gnus-score-alist) - emacs-lisp-mode-hook) - (save-excursion - (set-buffer (get-buffer-create "*Score*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (pp score (current-buffer)) - (gnus-make-directory (file-name-directory file)) - (write-region (point-min) (point-max) file nil 'silent) - (kill-buffer (current-buffer)))) - (gnus-message 4 "Saved")) - -(provide 'gnus-edit) - -;;; gnus-edit.el end here
--- a/lisp/gnus/gnus-group.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-group.el Mon Aug 13 08:49:43 2007 +0200 @@ -836,7 +836,7 @@ (gnus-group-setup-buffer) (gnus-update-format-specifications nil 'group 'group-mode) (let ((case-fold-search nil) - (props (text-properties-at (point-at-bol))) + (props (text-properties-at (gnus-point-at-bol))) (empty (= (point-min) (point-max))) (group (gnus-group-group-name)) number) @@ -1220,23 +1220,23 @@ (defun gnus-group-group-name () "Get the name of the newsgroup on the current line." - (let ((group (get-text-property (point-at-bol) 'gnus-group))) + (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group))) (and group (symbol-name group)))) (defun gnus-group-group-level () "Get the level of the newsgroup on the current line." - (get-text-property (point-at-bol) 'gnus-level)) + (get-text-property (gnus-point-at-bol) 'gnus-level)) (defun gnus-group-group-indentation () "Get the indentation of the newsgroup on the current line." - (or (get-text-property (point-at-bol) 'gnus-indentation) + (or (get-text-property (gnus-point-at-bol) 'gnus-indentation) (and gnus-group-indentation-function (funcall gnus-group-indentation-function)) "")) (defun gnus-group-group-unread () "Get the number of unread articles of the newsgroup on the current line." - (get-text-property (point-at-bol) 'gnus-unread)) + (get-text-property (gnus-point-at-bol) 'gnus-unread)) (defun gnus-group-new-mail (group) (if (nnmail-new-mail-p (gnus-group-real-name group))
--- a/lisp/gnus/gnus-salt.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-salt.el Mon Aug 13 08:49:43 2007 +0200 @@ -658,7 +658,7 @@ (unless (zerop level) (gnus-tree-indent level) (insert (cadr gnus-tree-parent-child-edges)) - (setq col (- (setq beg (point)) (point-at-bol) 1)) + (setq col (- (setq beg (point)) (gnus-point-at-bol) 1)) ;; Draw "|" lines upwards. (while (progn (forward-line -1) @@ -682,7 +682,7 @@ (defsubst gnus-tree-indent-vertical () (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent) - (- (point) (point-at-bol))))) + (- (point) (gnus-point-at-bol))))) (when (> len 0) (insert (make-string len ? )))))
--- a/lisp/gnus/gnus-score.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-score.el Mon Aug 13 08:49:43 2007 +0200 @@ -1871,7 +1871,7 @@ (funcall search-func match nil t)) ;; Is it really exact? (and (eolp) - (= (point-at-bol) (match-beginning 0)) + (= (gnus-point-at-bol) (match-beginning 0)) ;; Yup. (progn (setq found (setq arts (get-text-property @@ -1942,7 +1942,7 @@ (goto-char (point-min)) (while (and (not (eobp)) (search-forward match nil t)) - (when (and (= (point-at-bol) (match-beginning 0)) + (when (and (= (gnus-point-at-bol) (match-beginning 0)) (eolp)) (setq found (setq arts (get-text-property (point) 'articles))) (if trace @@ -2026,7 +2026,7 @@ hashtb)) (gnus-sethash word - (append (get-text-property (point-at-eol) 'articles) val) + (append (get-text-property (gnus-point-at-eol) 'articles) val) hashtb))) (set-syntax-table syntab)) ;; Make all the ignorable words ignored.
--- a/lisp/gnus/gnus-setup.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-setup.el Mon Aug 13 08:49:43 2007 +0200 @@ -35,6 +35,15 @@ (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)) +(defvar gnus-use-installed-gnus t + "*If non-nil Use installed version of Gnus.") + +(defvar gnus-use-installed-tm running-xemacs + "*If non-nil use installed version of tm.") + +(defvar gnus-use-installed-mailcrypt running-xemacs + "*If non-nil use installed version of mailcrypt.") + (defvar gnus-emacs-lisp-directory (if running-xemacs "/usr/local/lib/xemacs/" "/usr/local/share/emacs/") @@ -44,10 +53,6 @@ "gnus-5.0.15/lisp/") "Directory where Gnus Emacs lisp is found.") -(defvar gnus-sgnus-lisp-directory (concat gnus-emacs-lisp-directory - "sgnus/lisp/") - "Directory where September Gnus Emacs lisp is found.") - (defvar gnus-tm-lisp-directory (concat gnus-emacs-lisp-directory "site-lisp/") "Directory where TM Emacs lisp is found.") @@ -57,10 +62,10 @@ "Directory where Mailcrypt Emacs Lisp is found.") (defvar gnus-bbdb-lisp-directory (concat gnus-emacs-lisp-directory - "site-lisp/bbdb-1.50/") + "site-lisp/bbdb-1.51/") "Directory where Big Brother Database is found.") -(defvar gnus-use-tm t +(defvar gnus-use-tm running-xemacs "Set this if you want MIME support for Gnus") (defvar gnus-use-mhe nil "Set this if you want to use MH-E for mail reading") @@ -76,14 +81,10 @@ "Set this if you want to use Mailcrypt for dealing with PGP messages") (defvar gnus-use-bbdb nil "Set this if you want to use the Big Brother DataBase") -(defvar gnus-use-september nil - "Set this if you are using the experimental September Gnus") -(let ((gnus-directory (if gnus-use-september - gnus-sgnus-lisp-directory - gnus-gnus-lisp-directory))) - (when (null (member gnus-directory load-path)) - (push gnus-directory load-path))) +(when (and (not gnus-use-installed-gnus) + (null (member gnus-gnus-lisp-directory load-path))) + (push gnus-gnus-lisp-directory load-path)) ;;; We can't do this until we know where Gnus is. (require 'message) @@ -93,16 +94,21 @@ ;;; MORIOKA Tomohiko <morioka@jaist.ac.jp> (when gnus-use-tm - (when (null (member gnus-tm-lisp-directory load-path)) + (when (and (not gnus-use-installed-tm) + (null (member gnus-tm-lisp-directory load-path))) (setq load-path (cons gnus-tm-lisp-directory load-path))) - (load "mime-setup")) + ;; tm may or may not be dumped with XEmacs. In Sunpro it is, otherwise + ;; it isn't. + (unless (featurep 'mime-setup) + (load "mime-setup"))) ;;; Mailcrypt by ;;; Jin Choi <jin@atype.com> ;;; Patrick LoPresti <patl@lcs.mit.edu> (when gnus-use-mailcrypt - (when (null (member gnus-mailcrypt-lisp-directory load-path)) + (when (and (not gnus-use-installed-mailcrypt) + (null (member gnus-mailcrypt-lisp-directory load-path))) (setq load-path (cons gnus-mailcrypt-lisp-directory load-path))) (autoload 'mc-install-write-mode "mailcrypt" nil t) (autoload 'mc-install-read-mode "mailcrypt" nil t) @@ -116,6 +122,7 @@ ;;; Jamie Zawinski <jwz@lucid.com> (when gnus-use-bbdb + ;; bbdb will never be installed with emacs. (when (null (member gnus-bbdb-lisp-directory load-path)) (setq load-path (cons gnus-bbdb-lisp-directory load-path))) (autoload 'bbdb "bbdb-com" @@ -161,10 +168,12 @@ ;;;### (autoloads (gnus gnus-slave gnus-no-server) "gnus" "lisp/gnus.el" (12473 2137)) ;;; Generated autoloads from lisp/gnus.el -(autoload 'gnus-slave-no-server "gnus" "\ +;; Don't redo this if autoloads already exist +(unless (fboundp 'gnus) + (autoload 'gnus-slave-no-server "gnus" "\ Read network news as a slave without connecting to local server." t nil) -(autoload 'gnus-no-server "gnus" "\ + (autoload 'gnus-no-server "gnus" "\ Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2. @@ -172,10 +181,10 @@ prompt the user for the name of an NNTP server to use. As opposed to `gnus', this command will not connect to the local server." t nil) -(autoload 'gnus-slave "gnus" "\ + (autoload 'gnus-slave "gnus" "\ Read news as a slave." t nil) -(autoload 'gnus "gnus" "\ + (autoload 'gnus "gnus" "\ Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will @@ -185,21 +194,21 @@ ;;; These have moved out of gnus.el into other files. ;;; FIX FIX FIX: should other things be in gnus-setup? or these not in it? -(autoload 'gnus-update-format "gnus-spec" "\ + (autoload 'gnus-update-format "gnus-spec" "\ Update the format specification near point." t nil) -(autoload 'gnus-fetch-group "gnus-group" "\ + (autoload 'gnus-fetch-group "gnus-group" "\ Start Gnus if necessary and enter GROUP. Returns whether the fetching was successful or not." t nil) -(defalias 'gnus-batch-kill 'gnus-batch-score) + (defalias 'gnus-batch-kill 'gnus-batch-score) -(autoload 'gnus-batch-score "gnus-kill" "\ + (autoload 'gnus-batch-score "gnus-kill" "\ Run batched scoring. Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ... Newsgroups is a list of strings in Bnews format. If you want to score the comp hierarchy, you'd say \"comp.all\". If you would not like to -score the alt hierarchy, you'd say \"!alt.all\"." t nil) +score the alt hierarchy, you'd say \"!alt.all\"." t nil)) (provide 'gnus-setup)
--- a/lisp/gnus/gnus-sound.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -;;; gnus-sound.el --- Sound effects for Gnus -;; Copyright (C) 1996 Free Software Foundation - -;; Author: Steven L. Baur <steve@miranova.com> -;; Keywords: news - -;; 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: -;; This file provides access to sound effects in Gnus. -;; Prerelease: This file is partially stripped to support earcons.el -;; You can safely ignore most of it until Red Gnus. **Evil Laugh** -;;; Code: - -(if (null (boundp 'running-xemacs)) - (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))) - -(require 'nnheader) -(eval-when-compile (require 'cl)) - -(defvar gnus-sound-inline-sound - (and (fboundp 'device-sound-enabled-p) - (device-sound-enabled-p)) - "When t, we will not spawn a subprocess to play sounds.") - -(defvar gnus-sound-directory (nnheader-find-etc-directory "sounds") - "The directory containing the Sound Files.") - -(defvar gnus-sound-au-player "/usr/bin/showaudio" - "Executable program for playing sun AU format sound files") -(defvar gnus-sound-wav-player "/usr/local/bin/play" - "Executable program for playing WAV files") - - -;;; The following isn't implemented yet. Wait for Red Gnus. -;(defvar gnus-sound-effects-enabled t -; "When t, Gnus will use sound effects.") -;(defvar gnus-sound-enable-hooks nil -; "Functions run when enabling sound effects.") -;(defvar gnus-sound-disable-hooks nil -; "Functions run when disabling sound effects.") -;(defvar gnus-sound-theme-song nil -; "Theme song for Gnus.") -;(defvar gnus-sound-enter-group nil -; "Sound effect played when selecting a group.") -;(defvar gnus-sound-exit-group nil -; "Sound effect played when exiting a group.") -;(defvar gnus-sound-score-group nil -; "Sound effect played when scoring a group.") -;(defvar gnus-sound-busy-sound nil -; "Sound effect played when going into a ... sequence.") - - -;;;###autoload -;(defun gnus-sound-enable-sound () -; "Enable Sound Effects for Gnus." -; (interactive) -; (setq gnus-sound-effects-enabled t) -; (run-hooks gnus-sound-enable-hooks)) - -;;;###autoload -;(defun gnus-sound-disable-sound () -; "Disable Sound Effects for Gnus." -; (interactive) -; (setq gnus-sound-effects-enabled nil) -; (run-hooks gnus-sound-disable-hooks)) - -;;;###autoload -(defun gnus-sound-play (file) - "Play a sound through the speaker." - (interactive) - (let ((sound-file (if (file-exists-p file) - file - (concat gnus-sound-directory file)))) - (when (file-exists-p sound-file) - (if gnus-sound-inline-sound - (play-sound-file (concat gnus-sound-directory sound-file)) - (cond ((string-match "\\.wav$" sound-file) - (call-process gnus-sound-wav-player - (concat gnus-sound-directory sound-file) - 0 - nil)) - ((string-match "\\.au$" sound-file) - (call-process gnus-sound-au-player - (concat gnus-sound-directory sound-file) - 0 - nil))))))) - - -;;; The following isn't implemented yet, wait for Red Gnus -;(defun gnus-sound-startrek-sounds () -; "Enable sounds from Star Trek the original series." -; (interactive) -; (setq gnus-sound-busy-sound "working.au") -; (setq gnus-sound-enter-group "bulkhead_door.au") -; (setq gnus-sound-exit-group "bulkhead_door.au") -; (setq gnus-sound-score-group "ST_laser.au") -; (setq gnus-sound-theme-song "startrek.au") -; (add-hook 'gnus-select-group-hook 'gnus-sound-startrek-select-group) -; (add-hook 'gnus-exit-group-hook 'gnus-sound-startrek-exit-group)) -;;;*** - -(provide 'gnus-sound) - -(run-hooks 'gnus-sound-load-hook) - -;;; gnus-sound.el ends here
--- a/lisp/gnus/gnus-srvr.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-srvr.el Mon Aug 13 08:49:43 2007 +0200 @@ -224,7 +224,7 @@ (gnus-server-position-point)) (defun gnus-server-server-name () - (let ((server (get-text-property (point-at-bol) 'gnus-server))) + (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) (and server (symbol-name server)))) (defalias 'gnus-server-position-point 'gnus-goto-colon) @@ -671,7 +671,7 @@ (defun gnus-browse-group-name () (save-excursion (beginning-of-line) - (when (re-search-forward ": \\(.*\\)$" (point-at-eol) t) + (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) (gnus-group-prefixed-name (match-string 1) gnus-browse-current-method)))) (defun gnus-browse-unsubscribe-group ()
--- a/lisp/gnus/gnus-start.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-start.el Mon Aug 13 08:49:43 2007 +0200 @@ -1666,7 +1666,7 @@ (while (not (eobp)) (condition-case () (progn - (narrow-to-region (point) (point-at-eol)) + (narrow-to-region (point) (gnus-point-at-eol)) ;; group gets set to a symbol interned in the hash table ;; (what a hack!!) - jwz (setq group (let ((obarray hashtb)) (read cur))) @@ -1694,7 +1694,7 @@ (unless ignore-errors (gnus-message 3 "Warning - illegal active: %s" (buffer-substring - (point-at-bol) (point-at-eol)))))) + (gnus-point-at-bol) (gnus-point-at-eol)))))) (widen) (forward-line 1))))) @@ -1934,7 +1934,7 @@ ;; don't give a damn, frankly, my dear. (concat gnus-newsrc-options (buffer-substring - (point-at-bol) + (gnus-point-at-bol) ;; Options may continue on the next line. (or (and (re-search-forward "^[^ \t]" nil 'move) (progn (beginning-of-line) (point))) @@ -2005,8 +2005,8 @@ ;; The line was buggy. (setq group nil) (gnus-error 3.1 "Mangled line: %s" - (buffer-substring (point-at-bol) - (point-at-eol)))) + (buffer-substring (gnus-point-at-bol) + (gnus-point-at-eol)))) nil)) ;; Skip past ", ". Spaces are illegal in these ranges, but ;; we allow them, because it's a common mistake to put a @@ -2115,9 +2115,9 @@ (while (re-search-forward "[ \t]-n" nil t) (setq eol (or (save-excursion - (and (re-search-forward "[ \t]-n" (point-at-eol) t) + (and (re-search-forward "[ \t]-n" (gnus-point-at-eol) t) (- (point) 2))) - (point-at-eol))) + (gnus-point-at-eol))) ;; Search for all "words"... (while (re-search-forward "[^ \t,\n]+" eol t) (if (= (char-after (match-beginning 0)) ?!)
--- a/lisp/gnus/gnus-sum.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-sum.el Mon Aug 13 08:49:43 2007 +0200 @@ -1592,8 +1592,6 @@ ["Remove article" gnus-cache-remove-article t]) ["Enter digest buffer" gnus-summary-enter-digest-group t] ["Isearch article..." gnus-summary-isearch-article t] - ["Search articles forward..." gnus-summary-search-article-forward t] - ["Search articles backward..." gnus-summary-search-article-backward t] ["Beginning of the article" gnus-summary-beginning-of-article t] ["End of the article" gnus-summary-end-of-article t] ["Fetch parent of article" gnus-summary-refer-parent-article t] @@ -1740,6 +1738,8 @@ ["Toggle threading" gnus-summary-toggle-threads t]) ["Filter articles..." gnus-summary-execute-command t] ["Run command on subjects..." gnus-summary-universal-argument t] + ["Search articles forward..." gnus-summary-search-article-forward t] + ["Search articles backward..." gnus-summary-search-article-backward t] ["Toggle line truncation" gnus-summary-toggle-truncation t] ["Expand window" gnus-summary-expand-window t] ["Expire expirable articles" gnus-summary-expire-articles @@ -1945,6 +1945,9 @@ (defmacro gnus-data-header (data) `(nth 3 ,data)) +(defmacro gnus-data-set-header (data header) + `(setf (nth 3 ,data) ,header)) + (defmacro gnus-data-level (data) `(nth 4 ,data)) @@ -2974,7 +2977,7 @@ (setq thread (list (car (gnus-id-to-thread id)))) ;; Get the thread this article is part of. (setq thread (gnus-remove-thread id))) - (setq old-pos (point-at-bol)) + (setq old-pos (gnus-point-at-bol)) (setq current (save-excursion (and (zerop (forward-line -1)) (gnus-summary-article-number)))) @@ -3133,9 +3136,9 @@ (goto-char (gnus-data-pos d)) (gnus-data-remove number - (- (point-at-bol) + (- (gnus-point-at-bol) (prog1 - (1+ (point-at-eol)) + (1+ (gnus-point-at-eol)) (gnus-delete-line))))))) (defun gnus-sort-threads (threads) @@ -4196,7 +4199,7 @@ ;; This function has to be called with point after the article number ;; on the beginning of the line. (defun gnus-nov-parse-line (number dependencies &optional force-new) - (let ((eol (point-at-eol)) + (let ((eol (gnus-point-at-eol)) (buffer (current-buffer)) header ref id id-dep ref-dep) @@ -4354,9 +4357,9 @@ (goto-char (gnus-data-pos d)) (gnus-data-remove number - (- (point-at-bol) + (- (gnus-point-at-bol) (prog1 - (1+ (point-at-eol)) + (1+ (gnus-point-at-eol)) (gnus-delete-line)))))) (when old-header (mail-header-set-number header (mail-header-number old-header))) @@ -6913,11 +6916,26 @@ (save-excursion (save-restriction (message-narrow-to-head) - (let ((header (nnheader-parse-head t))) - (set-buffer buffer) - (mail-header-set-number header (cdr gnus-article-current)) - (gnus-summary-update-article-line - (cdr gnus-article-current) header)))) + (let ((head (buffer-string)) + header) + (nnheader-temp-write nil + (insert (format "211 %d Article retrieved.\n" + (cdr gnus-article-current))) + (insert head) + (insert ".\n") + (let ((nntp-server-buffer (current-buffer))) + (setq header (car (gnus-get-newsgroup-headers + (save-excursion + (set-buffer gnus-summary-buffer) + gnus-newsgroup-dependencies) + t)))) + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-data-set-header + (gnus-data-find (cdr gnus-article-current)) + header) + (gnus-summary-update-article-line + (cdr gnus-article-current) header)))))) ;; Update threads. (set-buffer (or buffer gnus-summary-buffer)) (gnus-summary-update-article (cdr gnus-article-current))) @@ -7314,7 +7332,7 @@ (defun gnus-summary-update-mark (mark type) (let ((forward (cdr (assq type gnus-summary-mark-positions))) (buffer-read-only nil)) - (re-search-backward "[\n\r]" (point-at-bol) 'move-to-limit) + (re-search-backward "[\n\r]" (gnus-point-at-bol) 'move-to-limit) (when (looking-at "\r") (incf forward)) (when (and forward
--- a/lisp/gnus/gnus-topic.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-topic.el Mon Aug 13 08:49:43 2007 +0200 @@ -94,16 +94,16 @@ (defun gnus-group-topic-name () "The name of the topic on the current line." - (let ((topic (get-text-property (point-at-bol) 'gnus-topic))) + (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) (and topic (symbol-name topic)))) (defun gnus-group-topic-level () "The level of the topic on the current line." - (get-text-property (point-at-bol) 'gnus-topic-level)) + (get-text-property (gnus-point-at-bol) 'gnus-topic-level)) (defun gnus-group-topic-unread () "The number of unread articles in topic on the current line." - (get-text-property (point-at-bol) 'gnus-topic-unread)) + (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) (defun gnus-topic-unread (topic) "Return the number of unread articles in TOPIC." @@ -118,7 +118,7 @@ (defun gnus-topic-visible-p () "Return non-nil if the current topic is visible." - (get-text-property (point-at-bol) 'gnus-topic-visible)) + (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) (defun gnus-topic-articles-in-topic (entries) (let ((total 0) @@ -642,7 +642,7 @@ (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) gnus-topic-alist))) (entry (assoc (caar gnus-topic-topology) gnus-topic-alist)) - (newsrc gnus-newsrc-alist) + (newsrc (cdr gnus-newsrc-alist)) group) (while newsrc (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) @@ -1287,6 +1287,7 @@ ;; !!!Sometimes nil elements sneak into the alist, ;; for some reason or other. (setcar alist (delq nil (car alist))) + (setcar alist (delete "dummy.group" (car alist))) (gnus-topic-sort-topic (pop alist) func reverse)))) (defun gnus-topic-sort-topic (topic func reverse)
--- a/lisp/gnus/gnus-util.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-util.el Mon Aug 13 08:49:43 2007 +0200 @@ -30,26 +30,6 @@ ;;; Code: -;(if (fboundp 'point-at-bol) -; (fset 'gnus-point-at-bol 'point-at-bol) -; (defsubst gnus-point-at-bol () -; "Return point at the beginning of the line." -; (let ((p (point))) -; (beginning-of-line) -; (prog1 -; (point) -; (goto-char p))))) - -;(if (fboundp 'point-at-eol) -; (fset 'gnus-point-at-eol 'point-at-eol) -; (defsubst gnus-point-at-eol () -; "Return point at the end of the line." -; (let ((p (point))) -; (end-of-line) -; (prog1 -; (point) -; (goto-char p))))) - (require 'custom) (require 'cl) (require 'nnheader) @@ -122,6 +102,26 @@ (when (gnus-buffer-exists-p buf) (kill-buffer buf)))) +(if (fboundp 'point-at-bol) + (fset 'gnus-point-at-bol 'point-at-bol) + (defun gnus-point-at-bol () + "Return point at the beginning of the line." + (let ((p (point))) + (beginning-of-line) + (prog1 + (point) + (goto-char p))))) + +(if (fboundp 'point-at-eol) + (fset 'gnus-point-at-eol 'point-at-eol) + (defun gnus-point-at-eol () + "Return point at the end of the line." + (let ((p (point))) + (end-of-line) + (prog1 + (point) + (goto-char p))))) + (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." (if (equal (car list) elt) @@ -190,7 +190,7 @@ (defun gnus-goto-colon () (beginning-of-line) - (search-forward ":" (point-at-eol) t)) + (search-forward ":" (gnus-point-at-eol) t)) (defun gnus-remove-text-with-property (prop) "Delete all text in the current buffer with text property PROP."
--- a/lisp/gnus/gnus-uu.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-uu.el Mon Aug 13 08:49:43 2007 +0200 @@ -535,11 +535,11 @@ "Various")))) (goto-char (point-min)) (when (re-search-forward "^Subject: ") - (delete-region (point) (point-at-eol)) + (delete-region (point) (gnus-point-at-eol)) (insert subject)) (goto-char (point-min)) (when (re-search-forward "^From: ") - (delete-region (point) (point-at-eol)) + (delete-region (point) (gnus-point-at-eol)) (insert from)) (message-forward post) (delete-file file)
--- a/lisp/gnus/gnus-vis.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1607 +0,0 @@ -;;; gnus-vis.el --- display-oriented parts of Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> -;; Per Abrahamsen <abraham@iesd.auc.dk> -;; Keywords: news - -;; 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: - -;;; Code: - -(require 'gnus) -(require 'gnus-ems) -(require 'easymenu) -(require 'custom) -(require 'browse-url) -(require 'gnus-score) -(eval-when-compile (require 'cl)) - -(defvar gnus-group-menu-hook nil - "*Hook run after the creation of the group mode menu.") - -(defvar gnus-summary-menu-hook nil - "*Hook run after the creation of the summary mode menu.") - -(defvar gnus-article-menu-hook nil - "*Hook run after the creation of the article mode menu.") - -;;; Summary highlights. - -;(defvar gnus-summary-highlight-properties -; '((unread "ForestGreen" "green") -; (ticked "Firebrick" "pink") -; (read "black" "white") -; (low italic italic) -; (high bold bold) -; (canceled "yellow/black" "black/yellow"))) - -;(defvar gnus-summary-highlight-translation -; '(((unread (= mark gnus-unread-mark)) -; (ticked (or (= mark gnus-ticked-mark) (= mark gnus-dormant-mark))) -; (read (not (or (= mark gnus-unread-mark) (= mark gnus-dormant-mark) -; (= mark gnus-ticked-mark) (= mark gnus-canceled-mark)))) -; (canceled (= mark gnus-canceled-mark))) -; ((low (< score gnus-summary-default-score)) -; (high (> score gnus-summary-default-score))))) - -;(defun gnus-visual-map-face-translation () -; (let ((props gnus-summary-highlight-properties) -; (trans gnus-summary-highlight-translation) -; map) -; (while props))) - -;see gnus-cus.el -;(defvar gnus-summary-selected-face 'underline -; "*Face used for highlighting the current article in the summary buffer.") - -;see gnus-cus.el -;(defvar gnus-summary-highlight -; (cond ((not (eq gnus-display-type 'color)) -; '(((> score default) . bold) -; ((< score default) . italic))) -; ((eq gnus-background-mode 'dark) -; (list (cons '(= mark gnus-canceled-mark) -; (custom-face-lookup "yellow" "black" nil nil nil nil)) -; (cons '(and (> score default) -; (or (= mark gnus-dormant-mark) -; (= mark gnus-ticked-mark))) -; (custom-face-lookup "pink" nil nil t nil nil)) -; (cons '(and (< score default) -; (or (= mark gnus-dormant-mark) -; (= mark gnus-ticked-mark))) -; (custom-face-lookup "pink" nil nil nil t nil)) -; (cons '(or (= mark gnus-dormant-mark) -; (= mark gnus-ticked-mark)) -; (custom-face-lookup "pink" nil nil nil nil nil)) - -; (cons '(and (> score default) (= mark gnus-ancient-mark)) -; (custom-face-lookup "SkyBlue" nil nil t nil nil)) -; (cons '(and (< score default) (= mark gnus-ancient-mark)) -; (custom-face-lookup "SkyBlue" nil nil nil t nil)) -; (cons '(= mark gnus-ancient-mark) -; (custom-face-lookup "SkyBlue" nil nil nil nil nil)) - -; (cons '(and (> score default) (= mark gnus-unread-mark)) -; (custom-face-lookup "white" nil nil t nil nil)) -; (cons '(and (< score default) (= mark gnus-unread-mark)) -; (custom-face-lookup "white" nil nil nil t nil)) -; (cons '(= mark gnus-unread-mark) -; (custom-face-lookup "white" nil nil nil nil nil)) - -; (cons '(> score default) 'bold) -; (cons '(< score default) 'italic))) -; (t -; (list (cons '(= mark gnus-canceled-mark) -; (custom-face-lookup "yellow" "black" nil nil nil nil)) -; (cons '(and (> score default) -; (or (= mark gnus-dormant-mark) -; (= mark gnus-ticked-mark))) -; (custom-face-lookup "firebrick" nil nil t nil nil)) -; (cons '(and (< score default) -; (or (= mark gnus-dormant-mark) -; (= mark gnus-ticked-mark))) -; (custom-face-lookup "firebrick" nil nil nil t nil)) -; (cons '(or (= mark gnus-dormant-mark) -; (= mark gnus-ticked-mark)) -; (custom-face-lookup "firebrick" nil nil nil nil nil)) - -; (cons '(and (> score default) (= mark gnus-ancient-mark)) -; (custom-face-lookup "RoyalBlue" nil nil t nil nil)) -; (cons '(and (< score default) (= mark gnus-ancient-mark)) -; (custom-face-lookup "RoyalBlue" nil nil nil t nil)) -; (cons '(= mark gnus-ancient-mark) -; (custom-face-lookup "RoyalBlue" nil nil nil nil nil)) - -; (cons '(and (> score default) (/= mark gnus-unread-mark)) -; (custom-face-lookup "DarkGreen" nil nil t nil nil)) -; (cons '(and (< score default) (/= mark gnus-unread-mark)) -; (custom-face-lookup "DarkGreen" nil nil nil t nil)) -; (cons '(/= mark gnus-unread-mark) -; (custom-face-lookup "DarkGreen" nil nil nil nil nil)) - -; (cons '(> score default) 'bold) -; (cons '(< score default) 'italic)))) -; "*Alist of `(FORM . FACE)'. -;Summary lines are highlighted with the FACE for the first FORM which -;evaluate to a non-nil value. - -;Point will be at the beginning of the line when FORM is evaluated. -;The following can be used for convenience: - -;score: (gnus-summary-article-score) -;default: gnus-summary-default-score -;below: gnus-summary-mark-below -;mark: (gnus-summary-article-mark) - -;The latter can be used like this: -; ((= mark gnus-replied-mark) . underline)") - -;;; article highlights - -;see gnus-cus.el -;(defvar gnus-header-face-alist -; (cond ((not (eq gnus-display-type 'color)) -; '(("" bold italic))) -; ((eq gnus-background-mode 'dark) -; (list (list "From" nil -; (custom-face-lookup "SkyBlue" nil nil t t nil)) -; (list "Subject" nil -; (custom-face-lookup "pink" nil nil t t nil)) -; (list "Newsgroups:.*," nil -; (custom-face-lookup "yellow" nil nil t t nil)) -; (list "" -; (custom-face-lookup "cyan" nil nil t nil nil) -; (custom-face-lookup "green" nil nil nil t nil)))) -; (t -; (list (list "From" nil -; (custom-face-lookup "RoyalBlue" nil nil t t nil)) -; (list "Subject" nil -; (custom-face-lookup "firebrick" nil nil t t nil)) -; (list "Newsgroups:.*," nil -; (custom-face-lookup "red" nil nil t t nil)) -; (list "" -; (custom-face-lookup "DarkGreen" nil nil t nil nil) -; (custom-face-lookup "DarkGreen" nil nil nil t nil))))) -; "Alist of headers and faces used for highlighting them. -;The entries in the list has the form `(REGEXP NAME CONTENT)', where -;REGEXP is a regular expression matching the beginning of the header, -;NAME is the face used for highlighting the header name and CONTENT is -;the face used for highlighting the header content. - -;The first non-nil NAME or CONTENT with a matching REGEXP in the list -;will be used.") - - -;see gnus-cus.el -;(defvar gnus-make-foreground t -; "Non nil means foreground color to highlight citations.") - -;see gnus-cus.el -;(defvar gnus-article-button-face 'bold -; "Face used for text buttons.") - -;see gnus-cus.el -;(defvar gnus-article-mouse-face (if (boundp 'gnus-mouse-face) -; gnus-mouse-face -; 'highlight) -; "Face used when the mouse is over the button.") - -;see gnus-cus.el -;(defvar gnus-signature-face 'italic -; "Face used for signature.") - -(defvar gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-\\wa-zA-Z0-9_=!?#$@~`%&*+|\\/.,]*[-\\wa-zA-Z0-9_=#$@~`%&*+|\\/]" - "*Regular expression that matches URLs.") - -(defvar gnus-button-alist - `(("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 - t gnus-button-message-id 3) - ("\\(<?\\(url: ?\\)?news:\\([^>\n\t ]*\\)>?\\)" 1 t - gnus-button-message-id 3) - ("\\(<URL: *\\)?mailto: *\\([^> \n\t]+\\)>?" 0 t gnus-button-reply 2) - ;; This is how URLs _should_ be embedded in text... - ("<URL: *\\([^\n\r>]*\\)>" 0 t gnus-button-url 1) - ;; Next regexp stolen from highlight-headers.el. - ;; Modified by Vladimir Alexiev. - (,gnus-button-url-regexp 0 t gnus-button-url 0)) - "Alist of regexps matching buttons in article bodies. - -Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where -REGEXP: is the string matching text around the button, -BUTTON: is the number of the regexp grouping actually matching the button, -FORM: is a lisp expression which must eval to true for the button to -be added, -CALLBACK: is the function to call when the user push this button, and each -PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. - -CALLBACK can also be a variable, in that case the value of that -variable it the real callback function.") - -(defvar gnus-header-button-alist - `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" - 0 t gnus-button-message-id 0) - ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) - ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" - 0 t gnus-button-mailto 0) - ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) - ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) - ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t - gnus-button-message-id 3)) - "Alist of headers and regexps to match buttons in article heads. - -This alist is very similar to `gnus-button-alist', except that each -alist has an additional HEADER element first in each entry: - -\(HEADER REGEXP BUTTON FORM CALLBACK PAR) - -HEADER is a regexp to match a header. For a fuller explanation, see -`gnus-button-alist'.") - -;see gnus-cus.el -;(eval-when-compile -; (defvar browse-url-browser-function)) - -;;; Group mode highlighting. - -;see gnus-cus.el -;(defvar gnus-group-highlight nil -; "Group lines are highlighted with the FACE for the first FORM which -;evaluate to a non-nil value. -; -;Point will be at the beginning of the line when FORM is evaluated. -;Variables bound when these forms are evaluated include: -; -;group: The group name. -;unread: The number of unread articles. -;method: The select method. -;mailp: Whether the select method is a mail method. -;level: The level of the group. -;score: The score of the group. -;ticked: The number of ticked articles in the group. -;") - - -;;; Internal variables. - -(defvar gnus-button-marker-list nil) - - - -(eval-and-compile - (autoload 'nnkiboze-generate-groups "nnkiboze") - (autoload 'gnus-cite-parse-maybe "gnus-cite" nil t)) - -;;; -;;; gnus-menu -;;; - -(defun gnus-visual-turn-off-edit-menu (type) - (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) - [menu-bar edit] 'undefined)) - -;; Newsgroup buffer - -(defun gnus-group-make-menu-bar () - (gnus-visual-turn-off-edit-menu 'group) - (unless (boundp 'gnus-group-reading-menu) - - (easy-menu-define - gnus-group-reading-menu gnus-group-mode-map "" - '("Group" - ["Read" gnus-group-read-group (gnus-group-group-name)] - ["Select" gnus-group-select-group (gnus-group-group-name)] - ["See old articles" (gnus-group-select-group 'all) - :keys "C-u SPC" :active (gnus-group-group-name)] - ["Catch up" gnus-group-catchup-current (gnus-group-group-name)] - ["Catch up all articles" gnus-group-catchup-current-all - (gnus-group-group-name)] - ["Check for new articles" gnus-group-get-new-news-this-group - (gnus-group-group-name)] - ["Toggle subscription" gnus-group-unsubscribe-current-group - (gnus-group-group-name)] - ["Kill" gnus-group-kill-group (gnus-group-group-name)] - ["Yank" gnus-group-yank-group gnus-list-of-killed-groups] - ["Describe" gnus-group-describe-group (gnus-group-group-name)] - ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)] - ["Edit kill file" gnus-group-edit-local-kill - (gnus-group-group-name)] - ;; Actually one should check, if any of the marked groups gives t for - ;; (gnus-check-backend-function 'request-expire-articles ...) - ["Expire articles" gnus-group-expire-articles - (or (and (gnus-group-group-name) - (gnus-check-backend-function - 'request-expire-articles - (gnus-group-group-name))) gnus-group-marked)] - ["Set group level" gnus-group-set-current-level - (gnus-group-group-name)] - ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)] - )) - - (easy-menu-define - gnus-group-group-menu gnus-group-mode-map "" - '("Groups" - ("Listing" - ["List unread subscribed groups" gnus-group-list-groups t] - ["List (un)subscribed groups" gnus-group-list-all-groups t] - ["List killed groups" gnus-group-list-killed gnus-killed-list] - ["List zombie groups" gnus-group-list-zombies gnus-zombie-list] - ["List level..." gnus-group-list-level t] - ["Describe all groups" gnus-group-describe-all-groups t] - ["Group apropos..." gnus-group-apropos t] - ["Group and description apropos..." gnus-group-description-apropos t] - ["List groups matching..." gnus-group-list-matching t] - ["List all groups matching..." gnus-group-list-all-matching t] - ["List active file" gnus-group-list-active t]) - ("Sort" - ["Default sort" gnus-group-sort-groups - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by method" gnus-group-sort-groups-by-method - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by rank" gnus-group-sort-groups-by-rank - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by score" gnus-group-sort-groups-by-score - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by level" gnus-group-sort-groups-by-level - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by unread" gnus-group-sort-groups-by-unread - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by name" gnus-group-sort-groups-by-alphabet - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]) - ("Mark" - ["Mark group" gnus-group-mark-group - (and (gnus-group-group-name) - (not (memq (gnus-group-group-name) gnus-group-marked)))] - ["Unmark group" gnus-group-unmark-group - (and (gnus-group-group-name) - (memq (gnus-group-group-name) gnus-group-marked))] - ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked] - ["Mark regexp..." gnus-group-mark-regexp t] - ["Mark region" gnus-group-mark-region t] - ["Mark buffer" gnus-group-mark-buffer t] - ["Execute command" gnus-group-universal-argument - (or gnus-group-marked (gnus-group-group-name))]) - ("Subscribe" - ["Subscribe to a group" gnus-group-unsubscribe-group t] - ["Kill all newsgroups in region" gnus-group-kill-region t] - ["Kill all zombie groups" gnus-group-kill-all-zombies - gnus-zombie-list] - ["Kill all groups on level..." gnus-group-kill-level t]) - ("Foreign groups" - ["Make a foreign group" gnus-group-make-group t] - ["Add a directory group" gnus-group-make-directory-group t] - ["Add the help group" gnus-group-make-help-group t] - ["Add the archive group" gnus-group-make-archive-group t] - ["Make a doc group" gnus-group-make-doc-group t] - ["Make a kiboze group" gnus-group-make-kiboze-group t] - ["Make a virtual group" gnus-group-make-empty-virtual t] - ["Add a group to a virtual" gnus-group-add-to-virtual t] - ["Rename group" gnus-group-rename-group - (gnus-check-backend-function - 'request-rename-group (gnus-group-group-name))] - ["Delete group" gnus-group-delete-group - (gnus-check-backend-function - 'request-delete-group (gnus-group-group-name))]) - ("Editing groups" - ["Parameters" gnus-group-edit-group-parameters - (gnus-group-group-name)] - ["Select method" gnus-group-edit-group-method - (gnus-group-group-name)] - ["Info" gnus-group-edit-group (gnus-group-group-name)]) - ("Score file" - ["Flush cache" gnus-score-flush-cache - (or gnus-score-cache gnus-short-name-score-file-cache)]) - ("Move" - ["Next" gnus-group-next-group t] - ["Previous" gnus-group-prev-group t] - ["Next unread" gnus-group-next-unread-group t] - ["Previous unread" gnus-group-prev-unread-group t] - ["Next unread same level" gnus-group-next-unread-group-same-level t] - ["Previous unread same level" - gnus-group-previous-unread-group-same-level t] - ["Jump to group" gnus-group-jump-to-group t] - ["First unread group" gnus-group-first-unread-group t] - ["Best unread group" gnus-group-best-unread-group t]) - ["Transpose" gnus-group-transpose-groups - (gnus-group-group-name)] - ["Read a directory as a group..." gnus-group-enter-directory t] - )) - - (easy-menu-define - gnus-group-misc-menu gnus-group-mode-map "" - '("Misc" - ["Send a bug report" gnus-bug t] - ["Send a mail" gnus-group-mail t] - ["Post an article..." gnus-group-post-news t] - ["Customize score file" gnus-score-customize t] - ["Check for new news" gnus-group-get-new-news t] - ["Activate all groups" gnus-activate-all-groups t] - ["Delete bogus groups" gnus-group-check-bogus-groups t] - ["Find new newsgroups" gnus-find-new-newsgroups t] - ["Restart Gnus" gnus-group-restart t] - ["Read init file" gnus-group-read-init-file t] - ["Browse foreign server" gnus-group-browse-foreign-server t] - ["Enter server buffer" gnus-group-enter-server-mode t] - ["Expire all expirable articles" gnus-group-expire-all-groups t] - ["Generate any kiboze groups" nnkiboze-generate-groups t] - ["Gnus version" gnus-version t] - ["Save .newsrc files" gnus-group-save-newsrc t] - ["Suspend Gnus" gnus-group-suspend t] - ["Clear dribble buffer" gnus-group-clear-dribble t] - ["Edit global kill file" gnus-group-edit-global-kill t] - ["Read manual" gnus-info-find-node t] - ["Toggle topics" gnus-topic-mode t] - ("SOUP" - ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)] - ["Send replies" gnus-soup-send-replies - (fboundp 'gnus-soup-pack-packet)] - ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] - ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] - ["Brew SOUP" gnus-soup-brew-soup (fboundp 'gnus-soup-pack-packet)]) - ["Exit from Gnus" gnus-group-exit t] - ["Exit without saving" gnus-group-quit t] - )) - - (run-hooks 'gnus-group-menu-hook) - )) - -;; Summary buffer -(defun gnus-summary-make-menu-bar () - (gnus-visual-turn-off-edit-menu 'summary) - - (unless (boundp 'gnus-summary-misc-menu) - - (easy-menu-define - gnus-summary-kill-menu gnus-summary-mode-map "" - (cons - "Score" - (nconc - (list - ["Enter score..." gnus-summary-score-entry t]) - (gnus-visual-score-map 'increase) - (gnus-visual-score-map 'lower) - '(("Mark" - ["Kill below" gnus-summary-kill-below t] - ["Mark above" gnus-summary-mark-above t] - ["Tick above" gnus-summary-tick-above t] - ["Clear above" gnus-summary-clear-above t]) - ["Current score" gnus-summary-current-score t] - ["Set score" gnus-summary-set-score t] - ["Customize score file" gnus-score-customize t] - ["Switch current score file..." gnus-score-change-score-file t] - ["Set mark below..." gnus-score-set-mark-below t] - ["Set expunge below..." gnus-score-set-expunge-below t] - ["Edit current score file" gnus-score-edit-current-scores t] - ["Edit score file" gnus-score-edit-file t] - ["Trace score" gnus-score-find-trace t] - ["Rescore buffer" gnus-summary-rescore t] - ["Increase score..." gnus-summary-increase-score t] - ["Lower score..." gnus-summary-lower-score t])))) - - '(("Default header" - ["Ask" (gnus-score-set-default 'gnus-score-default-header nil) - :style radio - :selected (null gnus-score-default-header)] - ["From" (gnus-score-set-default 'gnus-score-default-header 'a) - :style radio - :selected (eq gnus-score-default-header 'a)] - ["Subject" (gnus-score-set-default 'gnus-score-default-header 's) - :style radio - :selected (eq gnus-score-default-header 's)] - ["Article body" - (gnus-score-set-default 'gnus-score-default-header 'b) - :style radio - :selected (eq gnus-score-default-header 'b )] - ["All headers" - (gnus-score-set-default 'gnus-score-default-header 'h) - :style radio - :selected (eq gnus-score-default-header 'h )] - ["Message-Id" (gnus-score-set-default 'gnus-score-default-header 'i) - :style radio - :selected (eq gnus-score-default-header 'i )] - ["Thread" (gnus-score-set-default 'gnus-score-default-header 't) - :style radio - :selected (eq gnus-score-default-header 't )] - ["Crossposting" - (gnus-score-set-default 'gnus-score-default-header 'x) - :style radio - :selected (eq gnus-score-default-header 'x )] - ["Lines" (gnus-score-set-default 'gnus-score-default-header 'l) - :style radio - :selected (eq gnus-score-default-header 'l )] - ["Date" (gnus-score-set-default 'gnus-score-default-header 'd) - :style radio - :selected (eq gnus-score-default-header 'd )] - ["Followups to author" - (gnus-score-set-default 'gnus-score-default-header 'f) - :style radio - :selected (eq gnus-score-default-header 'f )]) - ("Default type" - ["Ask" (gnus-score-set-default 'gnus-score-default-type nil) - :style radio - :selected (null gnus-score-default-type)] - ;; The `:active' key is commented out in the following, - ;; because the GNU Emacs hack to support radio buttons use - ;; active to indicate which button is selected. - ["Substring" (gnus-score-set-default 'gnus-score-default-type 's) - :style radio - ;; :active (not (memq gnus-score-default-header '(l d))) - :selected (eq gnus-score-default-type 's)] - ["Regexp" (gnus-score-set-default 'gnus-score-default-type 'r) - :style radio - ;; :active (not (memq gnus-score-default-header '(l d))) - :selected (eq gnus-score-default-type 'r)] - ["Exact" (gnus-score-set-default 'gnus-score-default-type 'e) - :style radio - ;; :active (not (memq gnus-score-default-header '(l d))) - :selected (eq gnus-score-default-type 'e)] - ["Fuzzy" (gnus-score-set-default 'gnus-score-default-type 'f) - :style radio - ;; :active (not (memq gnus-score-default-header '(l d))) - :selected (eq gnus-score-default-type 'f)] - ["Before date" (gnus-score-set-default 'gnus-score-default-type 'b) - :style radio - ;; :active (eq (gnus-score-default-header 'd)) - :selected (eq gnus-score-default-type 'b)] - ["At date" (gnus-score-set-default 'gnus-score-default-type 'n) - :style radio - ;; :active (eq (gnus-score-default-header 'd)) - :selected (eq gnus-score-default-type 'n)] - ["After date" (gnus-score-set-default 'gnus-score-default-type 'a) - :style radio - ;; :active (eq (gnus-score-default-header 'd)) - :selected (eq gnus-score-default-type 'a)] - ["Less than number" - (gnus-score-set-default 'gnus-score-default-type '<) - :style radio - ;; :active (eq (gnus-score-default-header 'l)) - :selected (eq gnus-score-default-type '<)] - ["Equal to number" - (gnus-score-set-default 'gnus-score-default-type '=) - :style radio - ;; :active (eq (gnus-score-default-header 'l)) - :selected (eq gnus-score-default-type '=)] - ["Greater than number" - (gnus-score-set-default 'gnus-score-default-type '>) - :style radio - ;; :active (eq (gnus-score-default-header 'l)) - :selected (eq gnus-score-default-type '>)]) - ["Default fold" gnus-score-default-fold-toggle - :style toggle - :selected gnus-score-default-fold] - ("Default duration" - ["Ask" (gnus-score-set-default 'gnus-score-default-duration nil) - :style radio - :selected (null gnus-score-default-duration)] - ["Permanent" - (gnus-score-set-default 'gnus-score-default-duration 'p) - :style radio - :selected (eq gnus-score-default-duration 'p)] - ["Temporary" - (gnus-score-set-default 'gnus-score-default-duration 't) - :style radio - :selected (eq gnus-score-default-duration 't)] - ["Immediate" - (gnus-score-set-default 'gnus-score-default-duration 'i) - :style radio - :selected (eq gnus-score-default-duration 'i)])) - - (easy-menu-define - gnus-summary-article-menu gnus-summary-mode-map "" - '("Article" - ("Hide" - ["All" gnus-article-hide t] - ["Headers" gnus-article-hide-headers t] - ["Signature" gnus-article-hide-signature t] - ["Citation" gnus-article-hide-citation t] - ["PGP" gnus-article-hide-pgp t] - ["Boring headers" gnus-article-hide-boring-headers t]) - ("Highlight" - ["All" gnus-article-highlight t] - ["Headers" gnus-article-highlight-headers t] - ["Signature" gnus-article-highlight-signature t] - ["Citation" gnus-article-highlight-citation t]) - ("Date" - ["Local" gnus-article-date-local t] - ["UT" gnus-article-date-ut t] - ["Original" gnus-article-date-original t] - ["Lapsed" gnus-article-date-lapsed t]) - ("Filter" - ["Overstrike" gnus-article-treat-overstrike t] - ["Word wrap" gnus-article-fill-cited-article t] - ["CR" gnus-article-remove-cr t] - ["Trailing blank lines" gnus-article-remove-trailing-blank-lines t] - ["Show X-Face" gnus-article-display-x-face t] - ["Quoted-Printable" gnus-article-de-quoted-unreadable t] - ["Rot 13" gnus-summary-caesar-message t] - ["Add buttons" gnus-article-add-buttons t] - ["Add buttons to head" gnus-article-add-buttons-to-head t] - ["Stop page breaking" gnus-summary-stop-page-breaking t] - ["Toggle MIME" gnus-summary-toggle-mime t] - ["Verbose header" gnus-summary-verbose-headers t] - ["Toggle header" gnus-summary-toggle-header t]) - ("Output" - ["Save in default format" gnus-summary-save-article t] - ["Save in file" gnus-summary-save-article-file t] - ["Save in Unix mail format" gnus-summary-save-article-mail t] - ["Save in MH folder" gnus-summary-save-article-folder t] - ["Save in VM folder" gnus-summary-save-article-vm t] - ["Save in RMAIL mbox" gnus-summary-save-article-rmail t] - ["Save body in file" gnus-summary-save-article-body-file t] - ["Pipe through a filter" gnus-summary-pipe-output t] - ["Add to SOUP packet" gnus-soup-add-article t]) - ("Backend" - ["Respool article..." gnus-summary-respool-article t] - ["Move article..." gnus-summary-move-article - (gnus-check-backend-function - 'request-move-article gnus-newsgroup-name)] - ["Copy article..." gnus-summary-copy-article t] - ["Crosspost article..." gnus-summary-crosspost-article - (gnus-check-backend-function - 'request-replace-article gnus-newsgroup-name)] - ["Import file..." gnus-summary-import-article t] - ["Edit article" gnus-summary-edit-article - (not (gnus-group-read-only-p))] - ["Delete article" gnus-summary-delete-article - (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name)] - ["Query respool" gnus-summary-respool-query t] - ["Delete expirable articles" gnus-summary-expire-articles-now - (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name)]) - ("Extract" - ["Uudecode" gnus-uu-decode-uu t] - ["Uudecode and save" gnus-uu-decode-uu-and-save t] - ["Unshar" gnus-uu-decode-unshar t] - ["Unshar and save" gnus-uu-decode-unshar-and-save t] - ["Save" gnus-uu-decode-save t] - ["Binhex" gnus-uu-decode-binhex t] - ["Postscript" gnus-uu-decode-postscript t]) - ["Enter digest buffer" gnus-summary-enter-digest-group t] - ["Isearch article..." gnus-summary-isearch-article t] - ["Search articles forward..." gnus-summary-search-article-forward t] - ["Search articles backward..." gnus-summary-search-article-backward t] - ["Beginning of the article" gnus-summary-beginning-of-article t] - ["End of the article" gnus-summary-end-of-article t] - ["Fetch parent of article" gnus-summary-refer-parent-article t] - ["Fetch referenced articles" gnus-summary-refer-references t] - ["Fetch article with id..." gnus-summary-refer-article t] - ["Redisplay" gnus-summary-show-article t])) - - (easy-menu-define - gnus-summary-thread-menu gnus-summary-mode-map "" - '("Threads" - ["Toggle threading" gnus-summary-toggle-threads t] - ["Hide threads" gnus-summary-hide-all-threads t] - ["Show threads" gnus-summary-show-all-threads t] - ["Hide thread" gnus-summary-hide-thread t] - ["Show thread" gnus-summary-show-thread t] - ["Go to next thread" gnus-summary-next-thread t] - ["Go to previous thread" gnus-summary-prev-thread t] - ["Go down thread" gnus-summary-down-thread t] - ["Go up thread" gnus-summary-up-thread t] - ["Top of thread" gnus-summary-top-thread t] - ["Mark thread as read" gnus-summary-kill-thread t] - ["Lower thread score" gnus-summary-lower-thread t] - ["Raise thread score" gnus-summary-raise-thread t] - ["Rethread current" gnus-summary-rethread-current t] - )) - - (easy-menu-define - gnus-summary-post-menu gnus-summary-mode-map "" - '("Post" - ["Post an article" gnus-summary-post-news t] - ["Followup" gnus-summary-followup t] - ["Followup and yank" gnus-summary-followup-with-original t] - ["Supersede article" gnus-summary-supersede-article t] - ["Cancel article" gnus-summary-cancel-article t] - ["Reply" gnus-summary-reply t] - ["Reply and yank" gnus-summary-reply-with-original t] - ["Mail forward" gnus-summary-mail-forward t] - ["Post forward" gnus-summary-post-forward t] - ["Digest and mail" gnus-uu-digest-mail-forward t] - ["Digest and post" gnus-uu-digest-post-forward t] - ["Resend message" gnus-summary-resend-message t] - ["Send bounced mail" gnus-summary-resend-bounced-mail t] - ["Send a mail" gnus-summary-mail-other-window t] - ["Uuencode and post" gnus-uu-post-news t] - ;;("Draft" - ;;["Send" gnus-summary-send-draft t] - ;;["Send bounced" gnus-resend-bounced-mail t]) - )) - - (easy-menu-define - gnus-summary-misc-menu gnus-summary-mode-map "" - '("Misc" - ("Mark" - ("Read" - ["Mark as read" gnus-summary-mark-as-read-forward t] - ["Mark same subject and select" - gnus-summary-kill-same-subject-and-select t] - ["Mark same subject" gnus-summary-kill-same-subject t] - ["Catchup" gnus-summary-catchup t] - ["Catchup all" gnus-summary-catchup-all t] - ["Catchup to here" gnus-summary-catchup-to-here t] - ["Catchup region" gnus-summary-mark-region-as-read t] - ["Mark excluded" gnus-summary-limit-mark-excluded-as-read t]) - ("Various" - ["Tick" gnus-summary-tick-article-forward t] - ["Mark as dormant" gnus-summary-mark-as-dormant t] - ["Remove marks" gnus-summary-clear-mark-forward t] - ["Set expirable mark" gnus-summary-mark-as-expirable t] - ["Set bookmark" gnus-summary-set-bookmark t] - ["Remove bookmark" gnus-summary-remove-bookmark t]) - ("Limit" - ["Marks..." gnus-summary-limit-to-marks t] - ["Subject..." gnus-summary-limit-to-subject t] - ["Author..." gnus-summary-limit-to-author t] - ["Score" gnus-summary-limit-to-score t] - ["Unread" gnus-summary-limit-to-unread t] - ["Non-dormant" gnus-summary-limit-exclude-dormant t] - ["Articles" gnus-summary-limit-to-articles t] - ["Pop limit" gnus-summary-pop-limit t] - ["Show dormant" gnus-summary-limit-include-dormant t] - ["Hide childless dormant" - gnus-summary-limit-exclude-childless-dormant t] - ;;["Hide thread" gnus-summary-limit-exclude-thread t] - ["Show expunged" gnus-summary-show-all-expunged t]) - ("Process mark" - ["Set mark" gnus-summary-mark-as-processable t] - ["Remove mark" gnus-summary-unmark-as-processable t] - ["Remove all marks" gnus-summary-unmark-all-processable t] - ["Mark above" gnus-uu-mark-over t] - ["Mark series" gnus-uu-mark-series t] - ["Mark region" gnus-uu-mark-region t] - ["Mark by regexp..." gnus-uu-mark-by-regexp t] - ["Mark all" gnus-uu-mark-all t] - ["Mark buffer" gnus-uu-mark-buffer t] - ["Mark sparse" gnus-uu-mark-sparse t] - ["Mark thread" gnus-uu-mark-thread t] - ["Unmark thread" gnus-uu-unmark-thread t])) - ("Scroll article" - ["Page forward" gnus-summary-next-page t] - ["Page backward" gnus-summary-prev-page t] - ["Line forward" gnus-summary-scroll-up t]) - ("Move" - ["Next unread article" gnus-summary-next-unread-article t] - ["Previous unread article" gnus-summary-prev-unread-article t] - ["Next article" gnus-summary-next-article t] - ["Previous article" gnus-summary-prev-article t] - ["Next unread subject" gnus-summary-next-unread-subject t] - ["Previous unread subject" gnus-summary-prev-unread-subject t] - ["Next article same subject" gnus-summary-next-same-subject t] - ["Previous article same subject" gnus-summary-prev-same-subject t] - ["First unread article" gnus-summary-first-unread-article t] - ["Best unread article" gnus-summary-best-unread-article t] - ["Go to subject number..." gnus-summary-goto-subject t] - ["Go to article number..." gnus-summary-goto-article t] - ["Go to the last article" gnus-summary-goto-last-article t] - ["Pop article off history" gnus-summary-pop-article t]) - ("Sort" - ["Sort by number" gnus-summary-sort-by-number t] - ["Sort by author" gnus-summary-sort-by-author t] - ["Sort by subject" gnus-summary-sort-by-subject t] - ["Sort by date" gnus-summary-sort-by-date t] - ["Sort by score" gnus-summary-sort-by-score t]) - ("Help" - ["Fetch group FAQ" gnus-summary-fetch-faq t] - ["Describe group" gnus-summary-describe-group t] - ["Read manual" gnus-info-find-node t]) - ("Cache" - ["Enter article" gnus-cache-enter-article t] - ["Remove article" gnus-cache-remove-article t]) - ("Modes" - ["Pick and read" gnus-pick-mode t] - ["Binary" gnus-binary-mode t]) - ["Filter articles..." gnus-summary-execute-command t] - ["Run command on subjects..." gnus-summary-universal-argument t] - ["Toggle line truncation" gnus-summary-toggle-truncation t] - ["Expand window" gnus-summary-expand-window t] - ["Expire expirable articles" gnus-summary-expire-articles - (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name)] - ["Edit local kill file" gnus-summary-edit-local-kill t] - ["Edit main kill file" gnus-summary-edit-global-kill t] - ("Exit" - ["Catchup and exit" gnus-summary-catchup-and-exit t] - ["Catchup all and exit" gnus-summary-catchup-and-exit t] - ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] - ["Exit group" gnus-summary-exit t] - ["Exit group without updating" gnus-summary-exit-no-update t] - ["Exit and goto next group" gnus-summary-next-group t] - ["Exit and goto prev group" gnus-summary-prev-group t] - ["Reselect group" gnus-summary-reselect-current-group t] - ["Rescan group" gnus-summary-rescan-group t]))) - - (run-hooks 'gnus-summary-menu-hook) - )) - -(defun gnus-score-set-default (var value) - "A version of set that updates the GNU Emacs menu-bar." - (set var value) - ;; It is the message that forces the active status to be updated. - (message "")) - -(defun gnus-visual-score-map (type) - (if t - nil - (let ((headers '(("author" "from" string) - ("subject" "subject" string) - ("article body" "body" string) - ("article head" "head" string) - ("xref" "xref" string) - ("lines" "lines" number) - ("followups to author" "followup" string))) - (types '((number ("less than" <) - ("greater than" >) - ("equal" =)) - (string ("substring" s) - ("exact string" e) - ("fuzzy string" f) - ("regexp" r)))) - (perms '(("temporary" (current-time-string)) - ("permanent" nil) - ("immediate" now))) - header) - (list - (apply - 'nconc - (list - (if (eq type 'lower) - "Lower score" - "Increase score")) - (let (outh) - (while headers - (setq header (car headers)) - (setq outh - (cons - (apply - 'nconc - (list (car header)) - (let ((ts (cdr (assoc (nth 2 header) types))) - outt) - (while ts - (setq outt - (cons - (apply - 'nconc - (list (caar ts)) - (let ((ps perms) - outp) - (while ps - (setq outp - (cons - (vector - (caar ps) - (list - 'gnus-summary-score-entry - (nth 1 header) - (if (or (string= (nth 1 header) - "head") - (string= (nth 1 header) - "body")) - "" - (list 'gnus-summary-header - (nth 1 header))) - (list 'quote (nth 1 (car ts))) - (list 'gnus-score-default nil) - (nth 1 (car ps)) - t) - t) - outp)) - (setq ps (cdr ps))) - (list (nreverse outp)))) - outt)) - (setq ts (cdr ts))) - (list (nreverse outt)))) - outh)) - (setq headers (cdr headers))) - (list (nreverse outh)))))))) - -;; Article buffer -(defun gnus-article-make-menu-bar () - (gnus-visual-turn-off-edit-menu 'summary) - (or - (boundp 'gnus-article-article-menu) - (progn - (easy-menu-define - gnus-article-article-menu gnus-article-mode-map "" - '("Article" - ["Scroll forwards" gnus-article-goto-next-page t] - ["Scroll backwards" gnus-article-goto-prev-page t] - ["Show summary" gnus-article-show-summary t] - ["Fetch Message-ID at point" gnus-article-refer-article t] - ["Mail to address at point" gnus-article-mail t] - )) - - (easy-menu-define - gnus-article-treatment-menu gnus-article-mode-map "" - '("Treatment" - ["Hide headers" gnus-article-hide-headers t] - ["Hide signature" gnus-article-hide-signature t] - ["Hide citation" gnus-article-hide-citation t] - ["Treat overstrike" gnus-article-treat-overstrike t] - ["Remove carriage return" gnus-article-remove-cr t] - ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] - )) - (run-hooks 'gnus-article-menu-hook)))) - -;;; -;;; summary highlights -;;; - -(defun gnus-highlight-selected-summary () - ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. - ;; Highlight selected article in summary buffer - (if gnus-summary-selected-face - (save-excursion - (let* ((beg (progn (beginning-of-line) (point))) - (end (progn (end-of-line) (point))) - ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>. - (from (if (get-text-property beg gnus-mouse-face-prop) - beg - (1+ (or (next-single-property-change - beg gnus-mouse-face-prop nil end) - beg)))) - (to (1- (or (next-single-property-change - from gnus-mouse-face-prop nil end) - end)))) - ;; If no mouse-face prop on line (e.g. xemacs) we - ;; will have to = from = end, so we highlight the - ;; entire line instead. - (if (= (+ to 2) from) - (progn - (setq from beg) - (setq to end))) - (if gnus-newsgroup-selected-overlay - (gnus-move-overlay gnus-newsgroup-selected-overlay - from to (current-buffer)) - (setq gnus-newsgroup-selected-overlay (gnus-make-overlay from to)) - (gnus-overlay-put gnus-newsgroup-selected-overlay 'face - gnus-summary-selected-face)))))) - -;; New implementation by Christian Limpach <Christian.Limpach@nice.ch>. -(defun gnus-summary-highlight-line () - "Highlight current line according to `gnus-summary-highlight'." - (let* ((list gnus-summary-highlight) - (p (point)) - (end (progn (end-of-line) (point))) - ;; now find out where the line starts and leave point there. - (beg (progn (beginning-of-line) (point))) - (article (gnus-summary-article-number)) - (score (or (cdr (assq (or article gnus-current-article) - gnus-newsgroup-scored)) - gnus-summary-default-score 0)) - (mark (or (gnus-summary-article-mark) gnus-unread-mark)) - (inhibit-read-only t)) - ;; Eval the cars of the lists until we find a match. - (let ((default gnus-summary-default-score)) - (while (and list - (not (eval (caar list)))) - (setq list (cdr list)))) - (let ((face (cdar list))) - (unless (eq face (get-text-property beg 'face)) - (gnus-put-text-property - beg end 'face - (setq face (if (boundp face) (symbol-value face) face))) - (when gnus-summary-highlight-line-function - (funcall gnus-summary-highlight-line-function article face)))) - (goto-char p))) - -(defun gnus-group-highlight-line () - "Highlight the current line according to `gnus-group-highlight'." - (let* ((list gnus-group-highlight) - (p (point)) - (end (progn (end-of-line) (point))) - ;; now find out where the line starts and leave point there. - (beg (progn (beginning-of-line) (point))) - (group (gnus-group-group-name)) - (entry (gnus-group-entry group)) - (unread (if (numberp (car entry)) (car entry) 0)) - (info (nth 2 entry)) - (method (gnus-server-get-method group (gnus-info-method info))) - (marked (gnus-info-marks info)) - (mailp (memq 'mail (assoc (symbol-name - (car (or method gnus-select-method))) - gnus-valid-select-methods))) - (level (or (gnus-info-level info) 9)) - (score (or (gnus-info-score info) 0)) - (ticked (gnus-range-length (cdr (assq 'tick marked)))) - (inhibit-read-only t)) - ;; Eval the cars of the lists until we find a match. - (while (and list - (not (eval (caar list)))) - (setq list (cdr list))) - (let ((face (cdar list))) - (unless (eq face (get-text-property beg 'face)) - (gnus-put-text-property - beg end 'face - (setq face (if (boundp face) (symbol-value face) face))) - (gnus-extent-start-open beg))) - (goto-char p))) - -;;; -;;; gnus-carpal -;;; - -(defvar gnus-carpal-group-buffer-buttons - '(("next" . gnus-group-next-unread-group) - ("prev" . gnus-group-prev-unread-group) - ("read" . gnus-group-read-group) - ("select" . gnus-group-select-group) - ("catch-up" . gnus-group-catchup-current) - ("new-news" . gnus-group-get-new-news-this-group) - ("toggle-sub" . gnus-group-unsubscribe-current-group) - ("subscribe" . gnus-group-unsubscribe-group) - ("kill" . gnus-group-kill-group) - ("yank" . gnus-group-yank-group) - ("describe" . gnus-group-describe-group) - "list" - ("subscribed" . gnus-group-list-groups) - ("all" . gnus-group-list-all-groups) - ("killed" . gnus-group-list-killed) - ("zombies" . gnus-group-list-zombies) - ("matching" . gnus-group-list-matching) - ("post" . gnus-group-post-news) - ("mail" . gnus-group-mail) - ("rescan" . gnus-group-get-new-news) - ("browse-foreign" . gnus-group-browse-foreign) - ("exit" . gnus-group-exit))) - -(defvar gnus-carpal-summary-buffer-buttons - '("mark" - ("read" . gnus-summary-mark-as-read-forward) - ("tick" . gnus-summary-tick-article-forward) - ("clear" . gnus-summary-clear-mark-forward) - ("expirable" . gnus-summary-mark-as-expirable) - "move" - ("scroll" . gnus-summary-next-page) - ("next-unread" . gnus-summary-next-unread-article) - ("prev-unread" . gnus-summary-prev-unread-article) - ("first" . gnus-summary-first-unread-article) - ("best" . gnus-summary-best-unread-article) - "article" - ("headers" . gnus-summary-toggle-header) - ("uudecode" . gnus-uu-decode-uu) - ("enter-digest" . gnus-summary-enter-digest-group) - ("fetch-parent" . gnus-summary-refer-parent-article) - "mail" - ("move" . gnus-summary-move-article) - ("copy" . gnus-summary-copy-article) - ("respool" . gnus-summary-respool-article) - "threads" - ("lower" . gnus-summary-lower-thread) - ("kill" . gnus-summary-kill-thread) - "post" - ("post" . gnus-summary-post-news) - ("mail" . gnus-summary-mail) - ("followup" . gnus-summary-followup-with-original) - ("reply" . gnus-summary-reply-with-original) - ("cancel" . gnus-summary-cancel-article) - "misc" - ("exit" . gnus-summary-exit) - ("fed-up" . gnus-summary-catchup-and-goto-next-group))) - -(defvar gnus-carpal-server-buffer-buttons - '(("add" . gnus-server-add-server) - ("browse" . gnus-server-browse-server) - ("list" . gnus-server-list-servers) - ("kill" . gnus-server-kill-server) - ("yank" . gnus-server-yank-server) - ("copy" . gnus-server-copy-server) - ("exit" . gnus-server-exit))) - -(defvar gnus-carpal-browse-buffer-buttons - '(("subscribe" . gnus-browse-unsubscribe-current-group) - ("exit" . gnus-browse-exit))) - -(defvar gnus-carpal-group-buffer "*Carpal Group*") -(defvar gnus-carpal-summary-buffer "*Carpal Summary*") -(defvar gnus-carpal-server-buffer "*Carpal Server*") -(defvar gnus-carpal-browse-buffer "*Carpal Browse*") - -(defvar gnus-carpal-attached-buffer nil) - -(defvar gnus-carpal-mode-hook nil - "*Hook run in carpal mode buffers.") - -(defvar gnus-carpal-button-face 'bold - "*Face used on carpal buttons.") - -(defvar gnus-carpal-header-face 'bold-italic - "*Face used on carpal buffer headers.") - -(defvar gnus-carpal-mode-map nil) -(put 'gnus-carpal-mode 'mode-class 'special) - -(if gnus-carpal-mode-map - nil - (setq gnus-carpal-mode-map (make-keymap)) - (suppress-keymap gnus-carpal-mode-map) - (define-key gnus-carpal-mode-map " " 'gnus-carpal-select) - (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select) - (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select)) - -(defun gnus-carpal-mode () - "Major mode for clicking buttons. - -All normal editing commands are switched off. -\\<gnus-carpal-mode-map> -The following commands are available: - -\\{gnus-carpal-mode-map}" - (interactive) - (kill-all-local-variables) - (setq mode-line-modified "-- ") - (setq major-mode 'gnus-carpal-mode) - (setq mode-name "Gnus Carpal") - (setq mode-line-process nil) - (use-local-map gnus-carpal-mode-map) - (buffer-disable-undo (current-buffer)) - (setq buffer-read-only t) - (make-local-variable 'gnus-carpal-attached-buffer) - (run-hooks 'gnus-carpal-mode-hook)) - -(defun gnus-carpal-setup-buffer (type) - (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type))))) - (if (get-buffer buffer) - () - (save-excursion - (set-buffer (get-buffer-create buffer)) - (gnus-carpal-mode) - (setq gnus-carpal-attached-buffer - (intern (format "gnus-%s-buffer" type))) - (gnus-add-current-to-buffer-list) - (let ((buttons (symbol-value - (intern (format "gnus-carpal-%s-buffer-buttons" - type)))) - (buffer-read-only nil) - button) - (while buttons - (setq button (car buttons) - buttons (cdr buttons)) - (if (stringp button) - (gnus-set-text-properties - (point) - (prog2 (insert button) (point) (insert " ")) - (list 'face gnus-carpal-header-face)) - (gnus-set-text-properties - (point) - (prog2 (insert (car button)) (point) (insert " ")) - (list 'gnus-callback (cdr button) - 'face gnus-carpal-button-face - gnus-mouse-face-prop 'highlight)))) - (let ((fill-column (- (window-width) 2))) - (fill-region (point-min) (point-max))) - (set-window-point (get-buffer-window (current-buffer)) - (point-min))))))) - -(defun gnus-carpal-select () - "Select the button under point." - (interactive) - (let ((func (get-text-property (point) 'gnus-callback))) - (if (null func) - () - (pop-to-buffer (symbol-value gnus-carpal-attached-buffer)) - (call-interactively func)))) - -(defun gnus-carpal-mouse-select (event) - "Select the button under the mouse pointer." - (interactive "e") - (mouse-set-point event) - (gnus-carpal-select)) - -;;; -;;; article highlights -;;; - -;; Written by Per Abrahamsen <abraham@iesd.auc.dk>. - -;;; Internal Variables: - -(defvar gnus-button-regexp nil) -;; Regexp matching any of the regexps from `gnus-button-alist'. - -(defvar gnus-button-last nil) -;; The value of `gnus-button-alist' when `gnus-button-regexp' was build. - -;;; Commands: - -(defun gnus-article-push-button (event) - "Check text under the mouse pointer for a callback function. -If the text under the mouse pointer has a `gnus-callback' property, -call it with the value of the `gnus-data' text property." - (interactive "e") - (set-buffer (window-buffer (posn-window (event-start event)))) - (let* ((pos (posn-point (event-start event))) - (data (get-text-property pos 'gnus-data)) - (fun (get-text-property pos 'gnus-callback))) - (if fun (funcall fun data)))) - -(defun gnus-article-press-button () - "Check text at point for a callback function. -If the text at point has a `gnus-callback' property, -call it with the value of the `gnus-data' text property." - (interactive) - (let* ((data (get-text-property (point) 'gnus-data)) - (fun (get-text-property (point) 'gnus-callback))) - (if fun (funcall fun data)))) - -(defun gnus-article-prev-button (n) - "Move point to N buttons backward. -If N is negative, move forward instead." - (interactive "p") - (gnus-article-next-button (- n))) - -(defun gnus-article-next-button (n) - "Move point to N buttons forward. -If N is negative, move backward instead." - (interactive "p") - (let ((function (if (< n 0) 'previous-single-property-change - 'next-single-property-change)) - (inhibit-point-motion-hooks t) - (backward (< n 0)) - (limit (if (< n 0) (point-min) (point-max)))) - (setq n (abs n)) - (while (and (not (= limit (point))) - (> n 0)) - ;; Skip past the current button. - (when (get-text-property (point) 'gnus-callback) - (goto-char (funcall function (point) 'gnus-callback nil limit))) - ;; Go to the next (or previous) button. - (gnus-goto-char (funcall function (point) 'gnus-callback nil limit)) - ;; Put point at the start of the button. - (when (and backward (not (get-text-property (point) 'gnus-callback))) - (goto-char (funcall function (point) 'gnus-callback nil limit))) - ;; Skip past intangible buttons. - (when (get-text-property (point) 'intangible) - (incf n)) - (decf n)) - (unless (zerop n) - (gnus-message 5 "No more buttons")) - n)) - -(defun gnus-article-highlight (&optional force) - "Highlight current article. -This function calls `gnus-article-highlight-headers', -`gnus-article-highlight-citation', -`gnus-article-highlight-signature', and `gnus-article-add-buttons' to -do the highlighting. See the documentation for those functions." - (interactive (list 'force)) - (gnus-article-highlight-headers) - (gnus-article-highlight-citation force) - (gnus-article-highlight-signature) - (gnus-article-add-buttons force) - (gnus-article-add-buttons-to-head)) - -(defun gnus-article-highlight-some (&optional force) - "Highlight current article. -This function calls `gnus-article-highlight-headers', -`gnus-article-highlight-signature', and `gnus-article-add-buttons' to -do the highlighting. See the documentation for those functions." - (interactive (list 'force)) - (gnus-article-highlight-headers) - (gnus-article-highlight-signature) - (gnus-article-add-buttons)) - -(defun gnus-article-highlight-headers () - "Highlight article headers as specified by `gnus-header-face-alist'." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (let ((alist gnus-header-face-alist) - (buffer-read-only nil) - (case-fold-search t) - (inhibit-point-motion-hooks t) - entry regexp header-face field-face from hpoints fpoints) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (narrow-to-region (1- (point)) (point-min)) - (while (setq entry (pop alist)) - (goto-char (point-min)) - (setq regexp (concat "^\\(" - (if (string-equal "" (nth 0 entry)) - "[^\t ]" - (nth 0 entry)) - "\\)") - header-face (nth 1 entry) - field-face (nth 2 entry)) - (while (and (re-search-forward regexp nil t) - (not (eobp))) - (beginning-of-line) - (setq from (point)) - (or (search-forward ":" nil t) - (forward-char 1)) - (when (and header-face - (not (memq (point) hpoints))) - (push (point) hpoints) - (gnus-put-text-property from (point) 'face header-face)) - (when (and field-face - (not (memq (setq from (point)) fpoints))) - (push from fpoints) - (if (re-search-forward "^[^ \t]" nil t) - (forward-char -2) - (goto-char (point-max))) - (gnus-put-text-property from (point) 'face field-face))))))))) - -(defun gnus-article-highlight-signature () - "Highlight the signature in an article. -It does this by highlighting everything after -`gnus-signature-separator' using `gnus-signature-face'." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t)) - (save-restriction - (when (and gnus-signature-face - (gnus-narrow-to-signature)) - (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) - 'face gnus-signature-face) - (widen) - (re-search-backward gnus-signature-separator nil t) - (let ((start (match-beginning 0)) - (end (set-marker (make-marker) (1+ (match-end 0))))) - (gnus-article-add-button start (1- end) 'gnus-signature-toggle - end))))))) - -(defun gnus-article-add-buttons (&optional force) - "Find external references in the article and make buttons of them. -\"External references\" are things like Message-IDs and URLs, as -specified by `gnus-button-alist'." - (interactive (list 'force)) - (save-excursion - (set-buffer gnus-article-buffer) - ;; Remove all old markers. - (while gnus-button-marker-list - (set-marker (pop gnus-button-marker-list) nil)) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (case-fold-search t) - (alist gnus-button-alist) - beg entry regexp) - (goto-char (point-min)) - ;; We skip the headers. - (unless (search-forward "\n\n" nil t) - (goto-char (point-max))) - (setq beg (point)) - (while (setq entry (pop alist)) - (setq regexp (car entry)) - (goto-char beg) - (while (re-search-forward regexp nil t) - (let* ((start (and entry (match-beginning (nth 1 entry)))) - (end (and entry (match-end (nth 1 entry)))) - (from (match-beginning 0))) - (when (or (eq t (nth 1 entry)) - (eval (nth 1 entry))) - ;; That optional form returned non-nil, so we add the - ;; button. - (gnus-article-add-button - start end 'gnus-button-push - (car (push (set-marker (make-marker) from) - gnus-button-marker-list)))))))))) - -;; Add buttons to the head of an article. -(defun gnus-article-add-buttons-to-head () - "Add buttons to the head of the article." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (case-fold-search t) - (alist gnus-header-button-alist) - entry beg end) - (nnheader-narrow-to-headers) - (while alist - ;; Each alist entry. - (setq entry (car alist) - alist (cdr alist)) - (goto-char (point-min)) - (while (re-search-forward (car entry) nil t) - ;; Each header matching the entry. - (setq beg (match-beginning 0)) - (setq end (or (and (re-search-forward "^[^ \t]" nil t) - (match-beginning 0)) - (point-max))) - (goto-char beg) - (while (re-search-forward (nth 1 entry) end t) - ;; Each match within a header. - (let* ((from (match-beginning 0)) - (entry (cdr entry)) - (start (match-beginning (nth 1 entry))) - (end (match-end (nth 1 entry))) - (form (nth 2 entry))) - (goto-char (match-end 0)) - (and (eval form) - (gnus-article-add-button - start end (nth 3 entry) - (buffer-substring (match-beginning (nth 4 entry)) - (match-end (nth 4 entry))))))) - (goto-char end)))) - (widen))) - -;;; External functions: - -(defun gnus-article-add-button (from to fun &optional data) - "Create a button between FROM and TO with callback FUN and data DATA." - (and gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay from to) - 'face gnus-article-button-face)) - (gnus-add-text-properties - from to - (nconc (and gnus-article-mouse-face - (list gnus-mouse-face-prop gnus-article-mouse-face)) - (list 'gnus-callback fun) - (and data (list 'gnus-data data))))) - -;;; Internal functions: - -(defun gnus-signature-toggle (end) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t)) - (if (get-text-property end 'invisible) - (gnus-unhide-text end (point-max)) - (gnus-hide-text end (point-max) gnus-hidden-properties))))) - -(defun gnus-button-entry () - ;; Return the first entry in `gnus-button-alist' matching this place. - (let ((alist gnus-button-alist) - (entry nil)) - (while alist - (setq entry (pop alist)) - (if (looking-at (car entry)) - (setq alist nil) - (setq entry nil))) - entry)) - -(defun gnus-button-push (marker) - ;; Push button starting at MARKER. - (save-excursion - (set-buffer gnus-article-buffer) - (goto-char marker) - (let* ((entry (gnus-button-entry)) - (inhibit-point-motion-hooks t) - (fun (nth 3 entry)) - (args (mapcar (lambda (group) - (let ((string (buffer-substring - (match-beginning group) - (match-end group)))) - (gnus-set-text-properties - 0 (length string) nil string) - string)) - (nthcdr 4 entry)))) - (cond - ((fboundp fun) - (apply fun args)) - ((and (boundp fun) - (fboundp (symbol-value fun))) - (apply (symbol-value fun) args)) - (t - (gnus-message 1 "You must define `%S' to use this button" - (cons fun args))))))) - -(defun gnus-button-message-id (message-id) - "Fetch MESSAGE-ID." - (save-excursion - (set-buffer gnus-summary-buffer) - (gnus-summary-refer-article message-id))) - -(defun gnus-button-mailto (address) - ;; Mail to ADDRESS. - (set-buffer (gnus-copy-article-buffer)) - (message-reply address)) - -(defun gnus-button-reply (address) - ;; Reply to ADDRESS. - (message-reply address)) - -(defun gnus-button-url (address) - "Browse ADDRESS." - (funcall browse-url-browser-function address)) - -;;; Next/prev buttons in the article buffer. - -(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") -(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") - -(defvar gnus-prev-page-map nil) -(unless gnus-prev-page-map - (setq gnus-prev-page-map (make-sparse-keymap)) - (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page) - (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page)) - -(defun gnus-insert-prev-page-button () - (let ((buffer-read-only nil)) - (gnus-eval-format - gnus-prev-page-line-format nil - `(gnus-prev t local-map ,gnus-prev-page-map - gnus-callback gnus-article-button-prev-page)))) - -(defvar gnus-next-page-map nil) -(unless gnus-next-page-map - (setq gnus-next-page-map (make-keymap)) - (suppress-keymap gnus-prev-page-map) - (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page) - (define-key gnus-next-page-map "\r" 'gnus-button-next-page)) - -(defun gnus-button-next-page () - "Go to the next page." - (interactive) - (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) - (gnus-article-next-page) - (select-window win))) - -(defun gnus-button-prev-page () - "Go to the prev page." - (interactive) - (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) - (gnus-article-prev-page) - (select-window win))) - -(defun gnus-insert-next-page-button () - (let ((buffer-read-only nil)) - (gnus-eval-format gnus-next-page-line-format nil - `(gnus-next t local-map ,gnus-next-page-map - gnus-callback - gnus-article-button-next-page)))) - -(defun gnus-article-button-next-page (arg) - "Go to the next page." - (interactive "P") - (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) - (gnus-article-next-page) - (select-window win))) - -(defun gnus-article-button-prev-page (arg) - "Go to the prev page." - (interactive "P") - (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) - (gnus-article-prev-page) - (select-window win))) - -;;; Compatibility Functions: - -(or (fboundp 'rassoc) - ;; Introduced in Emacs 19.29. - (defun rassoc (elt list) - "Return non-nil if ELT is `equal' to the cdr of an element of LIST. -The value is actually the element of LIST whose cdr is ELT." - (let (result) - (while list - (setq result (car list)) - (if (equal (cdr result) elt) - (setq list nil) - (setq result nil - list (cdr list)))) - result))) - -; (require 'gnus-cus) -(gnus-ems-redefine) -(provide 'gnus-vis) - -;;; gnus-vis.el ends here
--- a/lisp/gnus/gnus-xmas.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus-xmas.el Mon Aug 13 08:49:43 2007 +0200 @@ -133,7 +133,7 @@ (when gnus-newsgroup-selected-overlay (delete-extent gnus-newsgroup-selected-overlay)) (setq gnus-newsgroup-selected-overlay - (make-extent (point-at-bol) (point-at-eol))) + (make-extent (gnus-point-at-bol) (gnus-point-at-eol))) (set-extent-face gnus-newsgroup-selected-overlay gnus-summary-selected-face)))
--- a/lisp/gnus/gnus.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/gnus.el Mon Aug 13 08:49:43 2007 +0200 @@ -198,7 +198,7 @@ :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) -(defconst gnus-version-number "5.4.9" +(defconst gnus-version-number "5.4.11" "Version number for this version of Gnus.") (defconst gnus-version (format "Gnus v%s" gnus-version-number) @@ -1165,7 +1165,8 @@ (defcustom gnus-mode-non-string-length nil "*Max length of mode-line non-string contents. If this is nil, Gnus will take space as is needed, leaving the rest -of the modeline intact." +of the modeline intact. Note that the default of nil is unlikely +to be desirable; see the manual for further details." :group 'gnus-various :type '(choice (const nil) integer)) @@ -2351,14 +2352,21 @@ ;; "hello", and the select method is ("hello" (my-var "something")) ;; in the group "alt.alt", this will result in a new virtual server ;; called "hello+alt.alt". - (let ((entry - (gnus-copy-sequence - (if (gnus-server-equal method gnus-select-method) gnus-select-method - (cdr (assoc (car method) gnus-server-alist)))))) - (if (not entry) - method - (setcar (cdr entry) (concat (nth 1 entry) "+" group)) - (nconc entry (cdr method))))) + (if (or (not (gnus-similar-server-opened method)) + (not (cddr method))) + method + `(,(car method) ,(concat (cadr method) "+" group) + (,(intern (format "%s-address" (car method))) ,(cadr method)) + ,@(cddr method)))) + +(defun gnus-similar-server-opened (method) + (let ((opened gnus-opened-servers)) + (while (and method opened) + (when (and (equal (cadr method) (cadaar opened)) + (not (equal method (caar opened)))) + (setq method nil)) + (pop opened)) + (not method))) (defun gnus-server-status (method) "Return the status of METHOD." @@ -2388,7 +2396,7 @@ (setq method (cond ((stringp method) (gnus-server-to-method method)) - ((stringp (car method)) + ((stringp (cadr method)) (gnus-server-extend-method group method)) (t method)))
--- a/lisp/gnus/lpath.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/lpath.el Mon Aug 13 08:49:43 2007 +0200 @@ -12,7 +12,7 @@ (progn (defvar track-mouse nil) (maybe-fbind '(posn-point event-start x-popup-menu - error-message-string facemenu-get-face window-at + facemenu-get-face window-at coordinates-in-window-p compute-motion x-defined-colors easy-menu-create-keymaps)) ;; XEmacs thinks writting compatible code is obsolete. @@ -25,7 +25,7 @@ device-class get-popup-menu-response event-object x-defined-colors read-color add-submenu set-font-family font-create-object set-font-size frame-device find-face - set-extent-property make-extent))) + set-extent-property make-extent characterp display-error))) (setq load-path (cons "." load-path)) (require 'custom)
--- a/lisp/gnus/message.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/message.el Mon Aug 13 08:49:43 2007 +0200 @@ -112,9 +112,9 @@ (defcustom message-fcc-handler-function 'message-output "*A function called to save outgoing articles. This function will be called with the name of the file to store the -article in. The default function is `rmail-output' which saves in Unix +article in. The default function is `message-output' which saves in Unix mailbox format." - :type '(radio (function-item rmail-output) + :type '(radio (function-item message-output) (function :tag "Other")) :group 'message-sending) @@ -1098,6 +1098,7 @@ (when (string-match "XEmacs\\|Lucid" emacs-version) (message-setup-toolbar)) (easy-menu-add message-mode-menu message-mode-map) + (easy-menu-add message-mode-field-menu message-mode-map) ;; Allow mail alias things. (if (fboundp 'mail-abbrevs-setup) (mail-abbrevs-setup) @@ -2141,7 +2142,13 @@ (setq file (expand-file-name file)) (unless (file-exists-p (file-name-directory file)) (make-directory (file-name-directory file) t)) - (funcall message-fcc-handler-function file))) + (if (and message-fcc-handler-function + (not (eq message-fcc-handler-function 'rmail-output))) + (funcall message-fcc-handler-function file) + (if (and (file-readable-p file) (mail-file-babyl-p file)) + (rmail-output file 1 nil t) + (let ((mail-use-rfc822 t)) + (rmail-output file 1 t t)))))) (kill-buffer (current-buffer)))))
--- a/lisp/gnus/nnheader.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/nnheader.el Mon Aug 13 08:49:43 2007 +0200 @@ -157,7 +157,7 @@ ;; Parsing headers and NOV lines. (defsubst nnheader-header-value () - (buffer-substring (match-end 0) (point-at-eol))) + (buffer-substring (match-end 0) (gnus-point-at-eol))) (defun nnheader-parse-head (&optional naked) (let ((case-fold-search t) @@ -263,7 +263,7 @@ ;; (defvar nnheader-none-counter 0) (defun nnheader-parse-nov () - (let ((eol (point-at-eol))) + (let ((eol (gnus-point-at-eol))) (vector (nnheader-nov-read-integer) ; number (nnheader-nov-field) ; subject
--- a/lisp/gnus/nnkiboze.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/nnkiboze.el Mon Aug 13 08:49:43 2007 +0200 @@ -223,7 +223,8 @@ (when (file-exists-p newsrc-file) (load newsrc-file)) (nnheader-temp-write nov-file - (insert-file-contents nov-file) + (when (file-exists-p nov-file) + (insert-file-contents nov-file)) (setq nov-buffer (current-buffer)) ;; Go through the active hashtb and add new all groups that match the ;; kiboze regexp.
--- a/lisp/gnus/nnml.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/nnml.el Mon Aug 13 08:49:43 2007 +0200 @@ -188,7 +188,8 @@ (t (nnheader-report 'nnml "Article %s retrieved" id) ;; We return the article number. - (cons group (string-to-int (file-name-nondirectory path))))))) + (cons (if group-num (car group-num) group) + (string-to-int (file-name-nondirectory path))))))) (deffoo nnml-request-group (group &optional server dont-check) (cond
--- a/lisp/gnus/nnvirtual.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/nnvirtual.el Mon Aug 13 08:49:43 2007 +0200 @@ -184,26 +184,42 @@ (kill-buffer vbuf))))))) +(defvoo nnvirtual-last-accessed-component-group nil) (deffoo nnvirtual-request-article (article &optional group server buffer) - (when (and (nnvirtual-possibly-change-server server) - (numberp article)) - (let* ((amap (nnvirtual-map-article article)) - (cgroup (car amap))) - (cond - ((not amap) - (nnheader-report 'nnvirtual "No such article: %s" article)) - ((not (gnus-check-group cgroup)) - (nnheader-report - 'nnvirtual "Can't open server where %s exists" cgroup)) - ((not (gnus-request-group cgroup t)) - (nnheader-report 'nnvirtual "Can't open component group %s" cgroup)) - (t - (if buffer - (save-excursion - (set-buffer buffer) - (gnus-request-article-this-buffer (cdr amap) cgroup)) - (gnus-request-article (cdr amap) cgroup))))))) + (when (nnvirtual-possibly-change-server server) + (if (stringp article) + ;; This is a fetch by Message-ID. + (cond + ((not nnvirtual-last-accessed-component-group) + (nnheader-report + 'nnvirtual "Don't know what server to request from")) + (t + (save-excursion + (when buffer + (set-buffer buffer)) + (let ((method (gnus-find-method-for-group + nnvirtual-last-accessed-component-group))) + (funcall (gnus-get-function method 'request-article) + article nil (nth 1 method) buffer))))) + ;; This is a fetch by number. + (let* ((amap (nnvirtual-map-article article)) + (cgroup (car amap))) + (cond + ((not amap) + (nnheader-report 'nnvirtual "No such article: %s" article)) + ((not (gnus-check-group cgroup)) + (nnheader-report + 'nnvirtual "Can't open server where %s exists" cgroup)) + ((not (gnus-request-group cgroup t)) + (nnheader-report 'nnvirtual "Can't open component group %s" cgroup)) + (t + (setq nnvirtual-last-accessed-component-group cgroup) + (if buffer + (save-excursion + (set-buffer buffer) + (gnus-request-article-this-buffer (cdr amap) cgroup)) + (gnus-request-article (cdr amap) cgroup)))))))) (deffoo nnvirtual-open-server (server &optional defs) @@ -348,7 +364,7 @@ (looking-at "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") (goto-char (match-end 0)) - (unless (search-forward "\t" (point-at-eol) 'move) + (unless (search-forward "\t" (gnus-point-at-eol) 'move) (insert "\t")) ;; Remove any spaces at the beginning of the Xref field. @@ -362,7 +378,7 @@ ;; If there were existing xref lines, clean them up to have the correct ;; component server prefix. (let ((xref-end (save-excursion - (search-forward "\t" (point-at-eol) 'move) + (search-forward "\t" (gnus-point-at-eol) 'move) (point))) (len (length prefix))) (unless (= (point) xref-end) @@ -391,49 +407,49 @@ "Copy marks from the virtual group to the component groups. If READ-P is not nil, update the (un)read status of the components. If UPDATE-P is not nil, call gnus-group-update-group on the components." - (let ((unreads (and read-p - (nnvirtual-partition-sequence - (gnus-list-of-unread-articles - (nnvirtual-current-group))))) - (type-marks (mapcar (lambda (ml) - (cons (car ml) - (nnvirtual-partition-sequence (cdr ml)))) - (gnus-info-marks (gnus-get-info - (nnvirtual-current-group))))) - mark type groups carticles info entry) + (when nnvirtual-current-group + (let ((unreads (and read-p + (nnvirtual-partition-sequence + (gnus-list-of-unread-articles + (nnvirtual-current-group))))) + (type-marks (mapcar (lambda (ml) + (cons (car ml) + (nnvirtual-partition-sequence (cdr ml)))) + (gnus-info-marks (gnus-get-info + (nnvirtual-current-group))))) + mark type groups carticles info entry) - ;; Ok, atomically move all of the (un)read info, clear any old - ;; marks, and move all of the current marks. This way if someone - ;; hits C-g, you won't leave the component groups in a half-way state. - (gnus-atomic-progn - ;; move (un)read - (let ((gnus-newsgroup-active nil)) ;workaround guns-update-read-articles - (while (setq entry (pop unreads)) - (gnus-update-read-articles (car entry) (cdr entry)))) + ;; Ok, atomically move all of the (un)read info, clear any old + ;; marks, and move all of the current marks. This way if someone + ;; hits C-g, you won't leave the component groups in a half-way state. + (gnus-atomic-progn + ;; move (un)read + (let ((gnus-newsgroup-active nil)) ;workaround guns-update-read-articles + (while (setq entry (pop unreads)) + (gnus-update-read-articles (car entry) (cdr entry)))) - ;; clear all existing marks on the component groups - (setq groups nnvirtual-component-groups) - (while groups - (when (and (setq info (gnus-get-info (pop groups))) - (gnus-info-marks info)) - (gnus-info-set-marks info nil))) + ;; clear all existing marks on the component groups + (setq groups nnvirtual-component-groups) + (while groups + (when (and (setq info (gnus-get-info (pop groups))) + (gnus-info-marks info)) + (gnus-info-set-marks info nil))) - ;; Ok, currently type-marks is an assq list with keys of a mark type, - ;; with data of an assq list with keys of component group names - ;; and the articles which correspond to that key/group pair. - (while (setq mark (pop type-marks)) - (setq type (car mark)) - (setq groups (cdr mark)) - (while (setq carticles (pop groups)) - (gnus-add-marked-articles (car carticles) type (cdr carticles) - nil t)))) + ;; Ok, currently type-marks is an assq list with keys of a mark type, + ;; with data of an assq list with keys of component group names + ;; and the articles which correspond to that key/group pair. + (while (setq mark (pop type-marks)) + (setq type (car mark)) + (setq groups (cdr mark)) + (while (setq carticles (pop groups)) + (gnus-add-marked-articles (car carticles) type (cdr carticles) + nil t)))) - ;; possibly update the display, it is really slow - (when update-p - (setq groups nnvirtual-component-groups) - (while groups - (gnus-group-update-group (pop groups) t))) - )) + ;; possibly update the display, it is really slow + (when update-p + (setq groups nnvirtual-component-groups) + (while groups + (gnus-group-update-group (pop groups) t)))))) (defun nnvirtual-current-group ()
--- a/lisp/gnus/smiley.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/gnus/smiley.el Mon Aug 13 08:49:43 2007 +0200 @@ -224,10 +224,10 @@ (set-extent-property ext 'start-open t) (set-extent-property ext 'invisible t) (set-extent-property ext 'keymap smiley-map) - (set-extent-property ext 'mouse-face 'smiley-mouse-face) + (set-extent-property ext 'mouse-face smiley-mouse-face) (set-extent-property ext 'intangible t) ;; set annotation params - (set-extent-property ant 'mouse-face 'smiley-mouse-face) + (set-extent-property ant 'mouse-face smiley-mouse-face) (set-extent-property ant 'keymap smiley-map) ;; remember each other (set-extent-property ant 'smiley-extent ext)
--- a/lisp/gnus/widget-edit.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2127 +0,0 @@ -;;; widget-edit.el --- Functions for creating and using widgets. -;; -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: extensions -;; Version: 1.20 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Commentary: -;; -;; See `widget.el'. - -;;; Code: - -(require 'widget) -(require 'cl) -(autoload 'pp-to-string "pp") -(autoload 'Info-goto-node "info") - -(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. -(eval-and-compile - (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 (&rest args) nil) - (defmacro defface (&rest args) nil) - (when (fboundp 'copy-face) - (copy-face 'default 'widget-documentation-face) - (copy-face 'bold 'widget-button-face) - (copy-face 'italic 'widget-field-face)) - (defvar widget-mouse-face 'highlight) - (defvar widget-menu-max-size 40))) - -;;; Compatibility. - -(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) - (funcall (intern "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 'emacs) - -(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. - -(defun 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 "" - (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 - (cdr (assoc (completing-read (concat title ": ") - items nil t) - items))))) - -;;; 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 (or (widget-get widget :keymap) - widget-keymap)) - (face (or (widget-get widget :value-face) - 'widget-field-face))) - (set-text-properties from to (list 'field widget - 'read-only nil - 'keymap map - 'local-map map - 'face face)) - (unless (widget-get widget :size) - (add-text-properties to (1+ to) (list 'field widget - 'face face - '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))) - (add-text-properties from to (list 'button widget - 'mouse-face widget-mouse-face - 'start-open t - 'end-open t - 'face face)))) - -(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))) - -;;; Widget Properties. - -(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'." - (cond ((widget-plist-member (cdr widget) property) - (plist-get (cdr widget) property)) - ((car widget) - (widget-get (get (car widget) 'widget-type) property)) - (t nil))) - -(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))) - -(defun widget-apply (widget property &rest args) - "Apply the value of WIDGET's PROPERTY to the widget itself. -ARGS are passed as extra argments 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))) - -;;; 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 Comands. - -(defvar widget-keymap nil - "Keymap containing useful binding for buffers containing widgets. -Recommended as a parent keymap for modes using widgets.") - -(if widget-keymap - () - (setq widget-keymap (make-sparse-keymap)) - (set-keymap-parent widget-keymap global-map) - (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 [(shift tab)] 'widget-backward) - (define-key widget-keymap [backtab] 'widget-backward) - (if (string-match "XEmacs" (emacs-version)) - (define-key widget-keymap [button2] 'widget-button-click) - (define-key widget-keymap [menu-bar] 'nil) - (define-key widget-keymap [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) - -(defun widget-button-click (event) - "Activate button below mouse pointer." - (interactive "@e") - (widget-button-press (event-point event) event)) - -(defun widget-button-press (pos &optional event) - "Activate button at POS." - (interactive "@d") - (let* ((button (get-text-property pos 'button))) - (if button - (widget-apply button :action event) - (call-interactively - (lookup-key widget-global-map (this-command-keys)))))) - -(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"))))))))) - (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))))) - (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))) - -;;; 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) - :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)) - (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) - (if tag - (insert tag) - (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) - (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-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. - -(define-widget 'push-button 'item - "A pushable button." - :format "%[[%t]%]") - -;;; The `link' Widget. - -(define-widget 'link 'item - "An embedded link." - :help-echo "Push me to 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 - :format "%v" - :value "" - :action 'widget-field-action - :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-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)) - (set-marker (widget-get widget :value-from) nil) - (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)) - (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))) - (prog1 (buffer-substring-no-properties from to) - (set-buffer old))) - (widget-get widget :value)))) - -(defun widget-field-match (widget value) - ;; Match any string. - (stringp value)) - -;;; The `text' Widget. - -(define-widget 'text 'editable-field - "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 'menu-choice - "Toggle between two states." - :convert-widget 'widget-toggle-convert-widget - :format "%v" - :on "on" - :off "off") - -(defun widget-toggle-convert-widget (widget) - ;; Create the types representing the `on' and `off' states. - (let ((on-type (widget-get widget :on-type)) - (off-type (widget-get widget :off-type))) - (unless on-type - (setq on-type - (list 'choice-item - :value t - :match (lambda (widget value) value) - :tag (widget-get widget :on)))) - (unless off-type - (setq off-type - (list 'choice-item :value nil :tag (widget-get widget :off)))) - (widget-put widget :args (list on-type off-type))) - widget) - -;;; The `checkbox' Widget. - -(define-widget 'checkbox 'toggle - "A checkbox toggle." - :convert-widget 'widget-item-convert-widget - :on-type '(choice-item :format "%[[X]%]" t) - :off-type '(choice-item :format "%[[ ]%]" nil)) - -;;; 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)) - (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 (widget-create-child-and-convert - widget 'checkbox :value (not (null chosen))))) - ((eq escape ?v) - (setq child - (cond ((not chosen) - (widget-create-child widget type)) - ((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 - :on-type '(choice-item :format "%[(*)%]" t) - :off-type '(choice-item :format "%[( )%]" nil)) - -(defun widget-radio-button-notify (widget child &optional event) - ;; Notify the parent. - (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)) - (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 (widget-create-child-and-convert - widget 'radio-button - :value (not (null chosen))))) - ((eq escape ?v) - (setq child (if chosen - (widget-create-child-value - widget type value) - (widget-create-child widget type)))) - (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 - (widget-value-set current value)) - (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-value button) - (widget-value-set button nil))))))) - ;; 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" - :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" - :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. - -(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. - (cond ((eq escape ?i) - (and (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (widget-create-child-and-convert widget 'insert-button)) - (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-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))) - 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 (widget-create-child-and-convert - widget 'insert-button))) - ((eq escape ?d) - (setq delete (widget-create-child-and-convert - widget 'delete-button))) - ((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 "Push me to toggle the 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 ": (defalt `" 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") - -;;; The `color' Widget. - -(define-widget 'color-item 'choice-item - "A color name (with sample)." - :format "%v (%[sample%])\n" - :button-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 "default" - :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 'widget-edit) - -;; widget-edit.el ends here
--- a/lisp/gnus/widget.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -;;; widget.el --- a library of user interface components. -;; -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.20 -;; 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 `widget-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 :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) - -;; These autoloads should be deleted when the file is added to Emacs. -(autoload 'widget-create "widget-edit") -(autoload 'widget-insert "widget-edit") - -;;;###autoload -(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
--- a/lisp/modes/make-mode.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/modes/make-mode.el Mon Aug 13 08:49:43 2007 +0200 @@ -946,12 +946,11 @@ target makefile-target-colon)) (defun makefile-browser-format-macro-line (macro selected) - (format (concat (make-string makefile-browser-leftmost-column ?\ ) (if selected makefile-browser-selected-mark makefile-browser-unselected-mark) - (makefile-format-macro-ref macro)))) + (makefile-format-macro-ref macro))) (defun makefile-browser-fill (targets macros) (let ((inhibit-read-only t))
--- a/lisp/modes/sendmail.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/modes/sendmail.el Mon Aug 13 08:49:43 2007 +0200 @@ -1241,6 +1241,7 @@ ;;; Do not execute these when sendmail.el is loaded, ;;; only in loaddefs.el. +;;; Do not autoload, this package is obsolete. -sb ;;;###autoload (define-key ctl-x-map "m" 'mail) ;;;###autoload (define-key ctl-x-4-map "m" 'mail-other-window) ;;;###autoload (define-key ctl-x-5-map "m" 'mail-other-frame)
--- a/lisp/mu/mu-cite.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/mu/mu-cite.el Mon Aug 13 08:49:43 2007 +0200 @@ -6,7 +6,7 @@ ;; MINOURA Makoto <minoura@netlaputa.or.jp> ;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> ;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Version: $Revision: 1.4 $ +;; Version: $Revision: 1.5 $ ;; Keywords: mail, news, citation ;; This file is part of MU (Message Utilities). @@ -54,14 +54,14 @@ ;;; (defconst mu-cite/RCS-ID - "$Id: mu-cite.el,v 1.4 1997/02/02 05:05:45 steve Exp $") + "$Id: mu-cite.el,v 1.5 1997/02/04 02:36:02 steve Exp $") (defconst mu-cite/version (get-version-string mu-cite/RCS-ID)) ;;; @ formats ;;; -(defvar mu-cite/cited-prefix-regexp "\\(^[^ \t\n>]+>+[ \t]*\\|^[ \t]*$\\)" +(defvar mu-cite/cited-prefix-regexp "\\(^[^ \t\n<>]+>+[ \t]*\\|^[ \t]*$\\)" "*Regexp to match the citation prefix. If match, mu-cite doesn't insert citation prefix.") @@ -390,10 +390,13 @@ ;;; @ message editing utilities ;;; - + (defvar citation-mark-chars ">}|" "*String of characters for citation delimiter. [mu-cite.el]") +(defvar citation-disable-chars "<{" + "*String of characters not allowed as citation-prefix.") + (defun detect-paragraph-cited-prefix () (save-excursion (goto-char (point-min)) @@ -435,8 +438,10 @@ prefix))) ((progn (goto-char (point-max)) - (re-search-backward (concat "[" citation-mark-chars "]") - nil t) + (re-search-backward + (concat "[" citation-disable-chars "]") nil t) + (re-search-backward + (concat "[" citation-mark-chars "]") nil t) ) (goto-char (match-end 0)) (if (looking-at "[ \t]+")
--- a/lisp/prim/auto-autoloads.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 08:49:43 2007 +0200 @@ -855,6 +855,202 @@ ;;;*** +;;;### (autoloads (custom-make-dependencies custom-menu-update custom-buffer-create customize-apropos customize-customized customize-face customize-variable customize) "custom-edit" "custom/custom-edit.el") + +(autoload 'customize "custom-edit" "\ +Customize SYMBOL, which must be a customization group." t nil) + +(autoload 'customize-variable "custom-edit" "\ +Customize SYMBOL, which must be a variable." t nil) + +(autoload 'customize-face "custom-edit" "\ +Customize FACE." t nil) + +(autoload 'customize-customized "custom-edit" "\ +Customize all already customized user options." t nil) + +(autoload 'customize-apropos "custom-edit" "\ +Customize all user options matching REGEXP. +If ALL (e.g., started with a prefix key), include options which are not +user-settable." t nil) + +(autoload 'custom-buffer-create "custom-edit" "\ +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." nil nil) + +(autoload 'custom-menu-update "custom-edit" "\ +Update customize menu." t nil) + +(autoload 'custom-make-dependencies "custom-edit" "\ +Batch function to extract custom dependencies from .el files. +Usage: emacs -batch *.el -f custom-make-dependencies > deps.el" nil nil) + +;;;*** + +;;;### (autoloads (custom-set-faces custom-set-variables custom-initialize-faces custom-add-to-group defgroup custom-declare-group defface custom-declare-face defcustom custom-declare-variable) "custom" "custom/custom.el") + +(autoload 'custom-declare-variable "custom" "\ +Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments." nil nil) + +(autoload 'defcustom "custom" "\ +Declare SYMBOL as a customizable variable that defaults to VALUE. +DOC is the variable documentation. + +Neither SYMBOL nor VALUE needs to be quoted. +If SYMBOL is not already bound, initialize it to VALUE. +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:type VALUE should be a widget type. +:options VALUE should be a list of valid members of the widget type. +:group VALUE should be a customization group. + Add SYMBOL to that group. + +Read the section about customization in the emacs lisp manual for more +information." nil 'macro) + +(autoload 'custom-declare-face "custom" "\ +Like `defface', but FACE is evaluated as a normal argument." nil nil) + +(autoload 'defface "custom" "\ +Declare FACE as a customizable face that defaults to SPEC. +FACE does not need to be quoted. + +Third argument DOC is the face documentation. + +If FACE has been set with `custom-set-face', set the face attributes +as specified by that function, otherwise set the face attributes +according to SPEC. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:group VALUE should be a customization group. + Add FACE to that group. + +SPEC should be an alist of the form ((DISPLAY ATTS)...). + +ATTS is a list of face attributes and their values. The possible +attributes are defined in the variable `custom-face-attributes'. +Alternatively, ATTS can be a face in which case the attributes of that +face is used. + +The ATTS of the first entry in SPEC where the DISPLAY matches the +frame should take effect in that frame. DISPLAY can either be the +symbol `t', which will match all frames, or an alist of the form +\((REQ ITEM...)...) + +For the DISPLAY to match a FRAME, the REQ property of the frame must +match one of the ITEM. The following REQ are defined: + +`type' (the value of (window-system)) + Should be one of `x' or `tty'. + +`class' (the frame's color support) + Should be one of `color', `grayscale', or `mono'. + +`background' (what color is used for the background text) + Should be one of `light' or `dark'. + +Read the section about customization in the emacs lisp manual for more +information." nil 'macro) + +(autoload 'custom-declare-group "custom" "\ +Like `defgroup', but SYMBOL is evaluated as a normal argument." nil nil) + +(autoload 'defgroup "custom" "\ +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." nil 'macro) + +(autoload 'custom-add-to-group "custom" "\ +To existing GROUP add a new OPTION of type WIDGET, +If there already is an entry for that option, overwrite it." nil nil) + +(autoload 'custom-initialize-faces "custom" "\ +Initialize all custom faces for FRAME. +If FRAME is nil or omitted, initialize them for all frames." nil nil) + +(autoload 'custom-set-variables "custom" "\ +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." nil nil) + +(autoload 'custom-set-faces "custom" "\ +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." nil nil) + +;;;*** + +;;;### (autoloads (widget-delete widget-create) "widget-edit" "custom/widget-edit.el") + +(autoload 'widget-create "widget-edit" "\ +Create widget of TYPE. +The optional ARGS are additional keyword arguments." nil nil) + +(autoload 'widget-delete "widget-edit" "\ +Delete WIDGET." nil nil) + +;;;*** + +;;;### (autoloads (define-widget) "widget" "custom/widget.el") + +(autoload 'define-widget "widget" "\ +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." nil nil) + +;;;*** + ;;;### (autoloads (ange-ftp-hook-function) "ange-ftp" "dired/ange-ftp.el") (defvar ange-ftp-path-format '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*\\):\\(.*\\)" 3 2 4) "\ @@ -1814,172 +2010,6 @@ ;;;*** -;;;### (autoloads (custom-make-dependencies custom-menu-update custom-buffer-create customize-apropos customize-customized customize-face customize-variable customize) "custom-edit" "gnus/custom-edit.el") - -(autoload 'customize "custom-edit" "\ -Customize SYMBOL, which must be a customization group." t nil) - -(autoload 'customize-variable "custom-edit" "\ -Customize SYMBOL, which must be a variable." t nil) - -(autoload 'customize-face "custom-edit" "\ -Customize FACE." t nil) - -(autoload 'customize-customized "custom-edit" "\ -Customize all already customized user options." t nil) - -(autoload 'customize-apropos "custom-edit" "\ -Customize all user options matching REGEXP. -If ALL (e.g., started with a prefix key), include options which are not -user-settable." t nil) - -(autoload 'custom-buffer-create "custom-edit" "\ -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." nil nil) - -(autoload 'custom-menu-update "custom-edit" "\ -Update customize menu." t nil) - -(autoload 'custom-make-dependencies "custom-edit" "\ -Batch function to extract custom dependencies from .el files. -Usage: emacs -batch *.el -f custom-make-dependencies > deps.el" nil nil) - -;;;*** - -;;;### (autoloads (custom-set-faces custom-set-variables custom-initialize-faces custom-add-to-group defgroup custom-declare-group defface custom-declare-face defcustom custom-declare-variable) "custom" "gnus/custom.el") - -(autoload 'custom-declare-variable "custom" "\ -Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments." nil nil) - -(autoload 'defcustom "custom" "\ -Declare SYMBOL as a customizable variable that defaults to VALUE. -DOC is the variable documentation. - -Neither SYMBOL nor VALUE needs to be quoted. -If SYMBOL is not already bound, initialize it to VALUE. -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following KEYWORD's are defined: - -:type VALUE should be a widget type. -:options VALUE should be a list of valid members of the widget type. -:group VALUE should be a customization group. - Add SYMBOL to that group. - -Read the section about customization in the emacs lisp manual for more -information." nil 'macro) - -(autoload 'custom-declare-face "custom" "\ -Like `defface', but FACE is evaluated as a normal argument." nil nil) - -(autoload 'defface "custom" "\ -Declare FACE as a customizable face that defaults to SPEC. -FACE does not need to be quoted. - -Third argument DOC is the face documentation. - -If FACE has been set with `custom-set-face', set the face attributes -as specified by that function, otherwise set the face attributes -according to SPEC. - -The remaining arguments should have the form - - [KEYWORD VALUE]... - -The following KEYWORD's are defined: - -:group VALUE should be a customization group. - Add FACE to that group. - -SPEC should be an alist of the form ((DISPLAY ATTS)...). - -ATTS is a list of face attributes and their values. The possible -attributes are defined in the variable `custom-face-attributes'. -Alternatively, ATTS can be a face in which case the attributes of that -face is used. - -The ATTS of the first entry in SPEC where the DISPLAY matches the -frame should take effect in that frame. DISPLAY can either be the -symbol `t', which will match all frames, or an alist of the form -\((REQ ITEM...)...) - -For the DISPLAY to match a FRAME, the REQ property of the frame must -match one of the ITEM. The following REQ are defined: - -`type' (the value of (window-system)) - Should be one of `x' or `tty'. - -`class' (the frame's color support) - Should be one of `color', `grayscale', or `mono'. - -`background' (what color is used for the background text) - Should be one of `light' or `dark'. - -Read the section about customization in the emacs lisp manual for more -information." nil 'macro) - -(autoload 'custom-declare-group "custom" "\ -Like `defgroup', but SYMBOL is evaluated as a normal argument." nil nil) - -(autoload 'defgroup "custom" "\ -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." nil 'macro) - -(autoload 'custom-add-to-group "custom" "\ -To existing GROUP add a new OPTION of type WIDGET, -If there already is an entry for that option, overwrite it." nil nil) - -(autoload 'custom-initialize-faces "custom" "\ -Initialize all custom faces for FRAME. -If FRAME is nil or omitted, initialize them for all frames." nil nil) - -(autoload 'custom-set-variables "custom" "\ -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." nil nil) - -(autoload 'custom-set-faces "custom" "\ -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." nil nil) - -;;;*** - ;;;### (autoloads (gnus-earcon-display) "earcon" "gnus/earcon.el") (autoload 'gnus-earcon-display "earcon" "\ @@ -2039,13 +2069,6 @@ ;;;*** -;;;### (autoloads (gnus-sound-play) "gnus-sound" "gnus/gnus-sound.el") - -(autoload 'gnus-sound-play "gnus-sound" "\ -Play a sound through the speaker." t nil) - -;;;*** - ;;;### (autoloads (gnus-batch-brew-soup) "gnus-soup" "gnus/gnus-soup.el") (autoload 'gnus-batch-brew-soup "gnus-soup" "\ @@ -2113,7 +2136,7 @@ ;;;### (autoloads (unbold-region bold-region message-news-other-frame message-news-other-window message-mail-other-frame message-mail-other-window message-bounce message-resend message-forward message-recover message-supersede message-cancel-news message-followup message-wide-reply message-reply message-news message-mail message-mode) "message" "gnus/message.el") -(defcustom message-fcc-handler-function 'message-output "*A function called to save outgoing articles.\nThis function will be called with the name of the file to store the\narticle in. The default function is `rmail-output' which saves in Unix\nmailbox format." :type '(radio (function-item rmail-output) (function :tag "Other")) :group 'message-sending) +(defcustom message-fcc-handler-function 'message-output "*A function called to save outgoing articles.\nThis function will be called with the name of the file to store the\narticle in. The default function is `message-output' which saves in Unix\nmailbox format." :type '(radio (function-item message-output) (function :tag "Other")) :group 'message-sending) (defcustom message-from-style 'default "*Specifies how \"From\" headers look.\n\nIf `nil', they contain just the return address like:\n king@grassland.com\nIf `parens', they look like:\n king@grassland.com (Elvis Parsley)\nIf `angles', they look like:\n Elvis Parsley <king@grassland.com>\n\nOtherwise, most addresses look like `angles', but they look like\n`parens' if `angles' would need quoting and `parens' would not." :type '(choice (const :tag "simple" nil) (const parens) (const angles) (const default)) :group 'message-headers) @@ -3651,7 +3674,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.4 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.5 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -4868,7 +4891,7 @@ (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.4 $ +vhdl-mode $Revision: 1.5 $ To submit a problem report, enter `\\[vhdl-submit-bug-report]' from a vhdl-mode buffer. This automatically sets up a mail buffer with version information already added. You just need to add a description of the @@ -9503,36 +9526,6 @@ ;;;*** -;;;### (autoloads (widget-delete widget-create) "widget-edit" "w3/widget-edit.el") - -(autoload 'widget-create "widget-edit" "\ -Create widget of TYPE. -The optional ARGS are additional keyword arguments." nil nil) - -(autoload 'widget-delete "widget-edit" "\ -Delete WIDGET." nil nil) - -;;;*** - -;;;### (autoloads (define-widget) "widget" "w3/widget.el") - -(autoload 'define-widget "widget" "\ -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." nil nil) - -;;;*** - ;;;### (autoloads (font-menu-weight-constructor font-menu-size-constructor font-menu-family-constructor reset-device-font-menus) "x-font-menu" "x11/x-font-menu.el") (defvar font-menu-ignore-scaled-fonts t "\
--- a/lisp/prim/keydefs.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/prim/keydefs.el Mon Aug 13 08:49:43 2007 +0200 @@ -134,7 +134,7 @@ (define-key global-map "\C-x50" 'delete-frame) (define-key global-map "\C-x5o" 'other-frame) ;; XEmacs addition: -(define-key global-map "\C-x5m" 'mail-other-frame) +;;(define-key global-map "\C-x5m" 'mail-other-frame) ;; FSFmacs help.el
--- a/lisp/prim/loadup.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/prim/loadup.el Mon Aug 13 08:49:43 2007 +0200 @@ -103,6 +103,12 @@ (load-gc "list-mode") (load-gc "modeline") ; after simple.el so it can reference functions ; defined there. + (load-gc "help") + (load-gc "buff-menu") + (load-gc "w3-sysdp") + (load-gc "font") ; required by widget + (load-gc "widget") + (load-gc "custom") ; Before loaddefs so that defcustom exists. ;; If SparcWorks support is included some additional packages are ;; dumped which would normally have autoloads. To avoid ;; duplicate doc string warnings, SparcWorks uses a separate @@ -113,7 +119,6 @@ (load-gc "loaddefs") (load-gc "misc") (load-gc "profile") - (load-gc "help") ;; (load-gc "hyper-apropos") Soon... (load-gc "files") (load-gc "lib-complete") @@ -121,7 +126,6 @@ (load-gc "indent") (load-gc "isearch-mode") (load-gc "buffer") - (load-gc "buff-menu") (load-gc "undo-stack") (load-gc "window") (load-gc "paths.el") ; don't get confused if paths compiled.
--- a/lisp/tl/mu-bbdb.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,128 +0,0 @@ -;;; mu-bbdb.el --- `attribution' function for mu-cite with BBDB. - -;; Copyright (C) 1996 Shuhei KOBAYASHI - -;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Version: $Id: mu-bbdb.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; - How to use -;; 1. bytecompile this file and copy it to the apropriate directory. -;; 2. put the following lines to your ~/.emacs: -;; (require 'tl-misc) -;; (call-after-loaded 'mu-cite -;; (function -;; (lambda () -;; (require 'mu-bbdb) -;; ))) - - -;;; Code: - -(require 'mu-cite) -(require 'bbdb) - -(defvar mu-bbdb-load-hook nil - "*List of functions called after mu-bbdb is loaded.") - -;;; @@ prefix and registration using BBDB -;;; - -(defun mu-cite/get-bbdb-prefix-method () - (or (mu-cite/get-bbdb-attr (mu-cite/get-value 'address)) - ">") - ) - -(defun mu-cite/get-bbdb-attr (addr) - "Extract attribute information from BBDB." - (let ((record (bbdb-search-simple nil addr))) - (and record - (bbdb-record-getprop record 'attribution)) - )) - -(defun mu-cite/set-bbdb-attr (attr addr) - "Add attribute information to BBDB." - (let* ((bbdb-notice-hook nil) - (record (bbdb-annotate-message-sender - addr t - (bbdb-invoke-hook-for-value - bbdb/mail-auto-create-p) - t))) - (if record - (progn - (bbdb-record-putprop record 'attribution attr) - (bbdb-change-record record nil)) - ))) - -(defun mu-cite/get-bbdb-prefix-register-method () - (let ((addr (mu-cite/get-value 'address))) - (or (mu-cite/get-bbdb-attr addr) - (let ((return - (read-string "Citation name? " - (or (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history) - )) - (if (and (not (string-equal return "")) - (y-or-n-p (format "Register \"%s\"? " return))) - (mu-cite/set-bbdb-attr return addr) - ) - return)))) - -(defun mu-cite/get-bbdb-prefix-register-verbose-method () - (let* ((addr (mu-cite/get-value 'address)) - (attr (mu-cite/get-bbdb-attr addr)) - (return (read-string "Citation name? " - (or attr - (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history)) - ) - (if (and (not (string-equal return "")) - (not (string-equal return attr)) - (y-or-n-p (format "Register \"%s\"? " return)) - ) - (mu-cite/set-bbdb-attr return addr) - ) - return)) - -(or (assoc 'bbdb-prefix mu-cite/default-methods-alist) - (setq mu-cite/default-methods-alist - (append mu-cite/default-methods-alist - (list - (cons 'bbdb-prefix - (function mu-cite/get-bbdb-prefix-method)) - (cons 'bbdb-prefix-register - (function mu-cite/get-bbdb-prefix-register-method)) - (cons 'bbdb-prefix-register-verbose - (function - mu-cite/get-bbdb-prefix-register-verbose-method)) - )))) - - -;;; @ end -;;; - -(provide 'mu-bbdb) - -(run-hooks 'mu-bbdb-load-hook) - -;;; mu-bbdb.el ends here
--- a/lisp/tm/tm-ftp.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/tm/tm-ftp.el Mon Aug 13 08:49:43 2007 +0200 @@ -1,35 +1,58 @@ -;;; -;;; tm-ftp: anonymous ftp processor for tm-view -;;; -;;; by MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp> (1994/11/ 5) -;;; -;;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp> (1994/11/ 8) -;;; and OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> (1994/11/11) -;;; -;;; $Id: tm-ftp.el,v 1.3 1996/12/29 00:15:13 steve Exp $ -;;; +;;; tm-ftp.el --- tm-view internal method for anonymous ftp + +;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. + +;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp> +;; MORIOKA Tomohiko <morioka@jaist.ac.jp> +;; Created: 1994/11/5 +;; Version: $Id: tm-ftp.el,v 1.4 1997/02/04 02:36:06 steve Exp $ +;; Keywords: anonymous ftp, MIME, multimedia, mail, news + +;; This file is part of tm (Tools for MIME). + +;; This program 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. + +;; This program 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. + +;;; Code: (require 'tm-view) (require 'ange-ftp) -(defvar mime/dired-function +(defvar mime-article/dired-function (if mime/use-multi-frame (function dired-other-frame) - (function dired) + (function mime-article/dired-function-for-one-frame) )) -(defun mime/decode-message/external-ftp (beg end cal) - (let ((access-type (cdr (assoc "access-type" cal))) - (site (cdr (assoc "site" cal))) - (directory (cdr (assoc "directory" cal))) - (name (cdr (assoc "name" cal))) - (mode (cdr (assoc "mode" cal))) - (pathname)) - (setq pathname - (concat "/anonymous@" site ":" directory)) - (message (concat "Accessing " pathname "/" name "...")) - (switch-to-buffer mime::article/preview-buffer) - (funcall mime/dired-function pathname) +(defun mime-article/dired-function-for-one-frame (dir) + (let ((win (or (get-buffer-window mime::article/preview-buffer) + (get-largest-window)))) + (select-window win) + (dired dir) + )) + +(defun mime-article/decode-message/external-ftp (beg end cal) + (let* ((access-type (cdr (assoc "access-type" cal))) + (site (cdr (assoc "site" cal))) + (directory (cdr (assoc "directory" cal))) + (name (cdr (assoc "name" cal))) + (mode (cdr (assoc "mode" cal))) + (pathname (concat "/anonymous@" site ":" directory)) + ) + (message (concat "Accessing " (expand-file-name name pathname) "...")) + (funcall mime-article/dired-function pathname) (goto-char (point-min)) (search-forward name) )) @@ -37,7 +60,13 @@ (set-atype 'mime/content-decoding-condition '((type . "message/external-body") ("access-type" . "anon-ftp") - (method . mime/decode-message/external-ftp) + (method . mime-article/decode-message/external-ftp) )) + +;;; @ end +;;; + (provide 'tm-ftp) + +;;; tm-ftp.el ends here
--- a/lisp/tm/tm-partial.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/tm/tm-partial.el Mon Aug 13 08:49:43 2007 +0200 @@ -1,11 +1,11 @@ ;;; tm-partial.el --- Grabbing all MIME "message/partial"s. -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: OKABE Yasuo @ Kyoto University ;; MORIOKA Tomohiko <morioka@jaist.ac.jp> ;; Version: -;; $Id: tm-partial.el,v 1.3 1996/12/29 00:15:14 steve Exp $ +;; $Id: tm-partial.el,v 1.4 1997/02/04 02:36:07 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, message/partial ;; This file is a part of tm (Tools for MIME). @@ -21,8 +21,8 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; 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. ;;; Code: @@ -34,16 +34,16 @@ ;; display Article at the cursor in Subject buffer. (defun tm-partial/preview-article (target) - (let ((f (assq target tm-partial/preview-article-method-alist))) - (if f - (funcall (cdr f)) - (error "Fatal. Unsupported mode") - ))) + (save-window-excursion + (let ((f (assq target tm-partial/preview-article-method-alist))) + (if f + (funcall (cdr f)) + (error "Fatal. Unsupported mode") + )))) (defun mime-article/grab-message/partials (beg end cal) (interactive) (let* ((id (cdr (assoc "id" cal))) - (buffer (generate-new-buffer id)) (mother mime::article/preview-buffer) (target (cdr (assq 'major-mode cal))) (article-buffer (buffer-name (current-buffer))) @@ -63,43 +63,41 @@ (if (or (file-exists-p full-file) (not (y-or-n-p "Merge partials?")) ) - (progn - (kill-buffer buffer) - (mime-article/decode-message/partial beg end cal) - ) + (mime-article/decode-message/partial beg end cal) (let (cinfo the-id parameters) (setq subject-id (std11-field-body "Subject")) (if (string-match "[0-9\n]+" subject-id) (setq subject-id (substring subject-id 0 (match-beginning 0))) ) - (pop-to-buffer subject-buf) - (while (search-backward subject-id nil t) - ) - (catch 'tag - (while t - (tm-partial/preview-article target) - (pop-to-buffer article-buffer) - (switch-to-buffer mime::article/preview-buffer) - (setq cinfo - (mime::preview-content-info/content-info - (car mime::preview/content-list))) - (setq parameters (mime::content-info/parameters cinfo)) - (setq the-id (assoc-value "id" parameters)) - (if (equal the-id id) - (progn - (switch-to-buffer article-buffer) - (mime-article/decode-message/partial - (point-min)(point-max) parameters) - (if (file-exists-p full-file) - (throw 'tag nil) - ) - )) - (if (not (progn - (pop-to-buffer subject-buf) - (end-of-line) - (search-forward subject-id nil t) - )) - (error "not found") + (save-excursion + (set-buffer subject-buf) + (while (search-backward subject-id nil t)) + (catch 'tag + (while t + (tm-partial/preview-article target) + (set-buffer article-buffer) + (set-buffer mime::article/preview-buffer) + (setq cinfo + (mime::preview-content-info/content-info + (car mime::preview/content-list))) + (setq parameters (mime::content-info/parameters cinfo)) + (setq the-id (assoc-value "id" parameters)) + (if (equal the-id id) + (progn + (set-buffer article-buffer) + (mime-article/decode-message/partial + (point-min)(point-max) parameters) + (if (file-exists-p full-file) + (throw 'tag nil) + ) + )) + (if (not (progn + (set-buffer subject-buf) + (end-of-line) + (search-forward subject-id nil t) + )) + (error "not found") + ) ) ))))))
--- a/lisp/tm/tm-play.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/tm/tm-play.el Mon Aug 13 08:49:43 2007 +0200 @@ -1,10 +1,10 @@ ;;; tm-play.el --- decoder for tm-view.el -;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> ;; Created: 1995/9/26 (separated from tm-view.el) -;; Version: $Id: tm-play.el,v 1.2 1996/12/22 00:29:41 steve Exp $ +;; Version: $Id: tm-play.el,v 1.3 1997/02/04 02:36:07 steve Exp $ ;; Keywords: mail, news, MIME, multimedia ;; This file is part of tm (Tools for MIME). @@ -269,16 +269,44 @@ ;;; (defvar mime-article/coding-system-alist - (and (boundp 'MULE) - '((mh-show-mode . *noconv*) - (t . *ctext*) - ))) + (list (cons 'mh-show-mode *noconv*) + (cons t (mime-charset-to-coding-system default-mime-charset)) + )) -(defvar mime-article/kanji-code-alist - (and (boundp 'NEMACS) - '((mh-show-mode . nil) - (t . 2) - ))) +(cond (running-mule-merged-emacs + (defun mime-article::write-region (start end file) + (let ((coding-system-for-write + (cdr + (or (assq major-mode mime-article/coding-system-alist) + (assq t mime-article/coding-system-alist) + )))) + (write-region start end file) + )) + ) + ((or (boundp 'MULE) + running-xemacs-with-mule) + (defun mime-article::write-region (start end file) + (let ((file-coding-system + (cdr + (or (assq major-mode mime-article/coding-system-alist) + (assq t mime-article/coding-system-alist) + )))) + (write-region start end file) + )) + ) + ((boundp 'NEMACS) + (defun mime-article::write-region (start end file) + (let ((kanji-fileio-code + (cdr + (or (assq major-mode mime-article/kanji-code-alist) + (assq t mime-article/kanji-code-alist) + )))) + (write-region start end file) + )) + ) + (t + (defalias 'mime-article::write-region 'write-region) + )) (defun mime-article/decode-message/partial (beg end cal) (goto-char beg) @@ -287,96 +315,108 @@ (id (cdr (assoc "id" cal))) (number (cdr (assoc "number" cal))) (total (cdr (assoc "total" cal))) - (the-buf (current-buffer)) file (mother mime::article/preview-buffer) - (win-conf (save-excursion - (set-buffer mother) - mime::preview/original-window-configuration)) - ) - (if (not (file-exists-p root-dir)) + ) + (or (file-exists-p root-dir) (make-directory root-dir) - ) + ) (setq id (replace-as-filename id)) (setq root-dir (concat root-dir "/" id)) - (if (not (file-exists-p root-dir)) + (or (file-exists-p root-dir) (make-directory root-dir) - ) + ) (setq file (concat root-dir "/FULL")) - (if (not (file-exists-p file)) - (progn - (re-search-forward "^$") - (goto-char (1+ (match-end 0))) - (setq file (concat root-dir "/" number)) - (let ((file-coding-system - (cdr - (or (assq major-mode mime-article/coding-system-alist) - (assq t mime-article/coding-system-alist) - ))) - (kanji-fileio-code - (cdr - (or (assq major-mode mime-article/kanji-code-alist) - (assq t mime-article/kanji-code-alist) - ))) - ) - (write-region (point) (point-max) file) - ) - (if (get-buffer mime/temp-buffer-name) - (kill-buffer mime/temp-buffer-name) + (if (file-exists-p file) + (let ((full-buf (get-buffer-create "FULL")) + (pwin (or (get-buffer-window mother) + (get-largest-window))) + ) + (save-window-excursion + (set-buffer full-buf) + (erase-buffer) + (as-binary-input-file (insert-file-contents file)) + (setq major-mode 'mime/show-message-mode) + (mime/viewer-mode mother) ) - (switch-to-buffer mime/temp-buffer-name) - (let ((i 1) - (max (string-to-int total)) - (file-coding-system-for-read (if (boundp 'MULE) - *noconv*)) - kanji-fileio-code) - (catch 'tag - (while (<= i max) - (setq file (concat root-dir "/" (int-to-string i))) - (if (not (file-exists-p file)) - (progn - (switch-to-buffer the-buf) - (throw 'tag nil) - )) - (insert-file-contents file) - (goto-char (point-max)) - (setq i (1+ i)) - ) - ;;(delete-other-windows) - (let ((buf (current-buffer))) - (write-file (concat root-dir "/FULL")) - (set-window-configuration win-conf) - (let ((win (get-buffer-window mother))) - (if win - (select-window win) + (set-window-buffer pwin + (save-excursion + (set-buffer full-buf) + mime::article/preview-buffer)) + (select-window pwin) + ) + (re-search-forward "^$") + (goto-char (1+ (match-end 0))) + (setq file (concat root-dir "/" number)) + (mime-article::write-region (point) (point-max) file) + (let ((total-file (concat root-dir "/CT"))) + (setq total + (if total + (progn + (or (file-exists-p total-file) + (save-excursion + (set-buffer (find-file-noselect total-file)) + (erase-buffer) + (insert total) + (save-buffer) + (kill-buffer (current-buffer)) + )) + (string-to-number total) + ) + (and (file-exists-p total-file) + (save-excursion + (set-buffer (find-file-noselect total-file)) + (and (re-search-forward "[0-9]+" nil t) + (string-to-number + (buffer-substring (match-beginning 0) + (match-end 0))) + ) + (kill-buffer (current-buffer)) + )) + ))) + (if (and total (> total 0)) + (catch 'tag + (save-excursion + (set-buffer (get-buffer-create mime/temp-buffer-name)) + (let ((full-buf (current-buffer))) + (erase-buffer) + (let ((i 1)) + (while (<= i total) + (setq file (concat root-dir "/" (int-to-string i))) + (if (not (file-exists-p file)) + (throw 'tag nil) + ) + (as-binary-input-file (insert-file-contents file)) + (goto-char (point-max)) + (setq i (1+ i)) )) - (set-window-buffer (selected-window) buf) - ;;(set-window-buffer buf) - (setq major-mode 'mime/show-message-mode) - ) - (mime/viewer-mode mother) - (pop-to-buffer (current-buffer)) - )) - ) - (progn - ;;(delete-other-windows) - (set-window-configuration win-conf) - (select-window (or (get-buffer-window mother) - (get-buffer-window - (save-excursion - (set-buffer mother) - mime::preview/article-buffer)) - (get-largest-window) + (as-binary-output-file (write-file (concat root-dir "/FULL"))) + (let ((i 1)) + (while (<= i total) + (let ((file (format "%s/%d" root-dir i))) + (and (file-exists-p file) + (delete-file file) )) - (as-binary-input-file - (set-buffer (get-buffer-create "FULL")) - (insert-file-contents file) - ) - (setq major-mode 'mime/show-message-mode) - (mime/viewer-mode mother) - ;;(pop-to-buffer (current-buffer)) - )) - )) + (setq i (1+ i)) + )) + (let ((file (expand-file-name "CT" root-dir))) + (and (file-exists-p file) + (delete-file file) + )) + (save-window-excursion + (setq major-mode 'mime/show-message-mode) + (mime/viewer-mode mother) + ) + (let ((pwin (or (get-buffer-window mother) + (get-largest-window) + )) + (pbuf (save-excursion + (set-buffer full-buf) + mime::article/preview-buffer))) + (set-window-buffer pwin pbuf) + (select-window pwin) + ))))) + ))) ;;; @ rot13-47
--- a/lisp/tm/tm-rich.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ -;;; -;;; tm-rich.el --- text/enriched and text/richtext style -;;; richtext filter for tm-view -;;; -;;; Copyright (C) 1995 Free Software Foundation, Inc. -;;; Copyright (C) 1994 .. 1996 MORIOKA Tomohiko -;;; -;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;;; Version: -;;; $Id: tm-rich.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ -;;; Keywords: mail, news, MIME, multimedia, richtext, enriched -;;; -;;; This file is part of tm (Tools for MIME). -;;; -;;; This program 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. -;;; -;;; This program 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 This program. If not, write to the Free Software -;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; Code: - -(require 'tm-view) - -(defvar tm-rich/richtext-module - (if (or running-emacs-19_29-or-later - running-xemacs-20 - (and running-xemacs (>= emacs-minor-version 14))) - 'richtext - 'tinyrich)) - -(require tm-rich/richtext-module) - - -;;; @ content filters for tm-view -;;; - -(defun mime-viewer/filter-text/richtext (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) - (charset (assoc "charset" params)) - ;; 1995/9/21 (c.f. tm-eng:105), 1995/10/3 (c.f. tm-eng:121) - ;; modified by Eric Ding <ericding@San-Jose.ate.slb.com> - (beg (point-min)) (end (point-max)) - ) - (remove-text-properties beg end '(face nil)) - (mime/decode-region encoding beg end) - (if (and m (fboundp (setq m (cdr m)))) - (funcall m beg (point-max) charset encoding) - (mime-viewer/default-code-convert-region beg (point-max) - charset encoding) - ) - (richtext-decode beg (point-max)) - )) - -(defun mime-viewer/filter-text/enriched (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) - (charset (assoc "charset" params)) - ;; 1995/9/21 (c.f. tm-eng:105), 1995/10/3 (c.f. tm-eng:121) - ;; modified by Eric Ding <ericding@San-Jose.ate.slb.com> - (beg (point-min)) (end (point-max)) - ) - (remove-text-properties beg end '(face nil)) - (mime/decode-region encoding beg end) - (if (and m (fboundp (setq m (cdr m)))) - (funcall m beg (point-max) charset encoding) - (mime-viewer/default-code-convert-region beg (point-max) - charset encoding) - ) - (enriched-decode beg (point-max)) - )) - - -;;; @ setting -;;; - -(set-alist 'mime-viewer/content-filter-alist - "text/richtext" (function mime-viewer/filter-text/richtext)) - -(set-alist 'mime-viewer/content-filter-alist - "text/enriched" (function mime-viewer/filter-text/enriched)) - - -;;; @ end -;;; - -(provide 'tm-rich) - -(run-hooks 'tm-rich-load-hook) - -;;; tm-rich.el ends here
--- a/lisp/tm/tm-setup.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/tm/tm-setup.el Mon Aug 13 08:49:43 2007 +0200 @@ -3,7 +3,7 @@ ;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: tm-setup.el,v 1.3 1997/02/02 05:06:20 steve Exp $ +;; Version: $Id: tm-setup.el,v 1.4 1997/02/04 02:36:07 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word ;; This file is part of tm (Tools for MIME). @@ -19,8 +19,8 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with This program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; 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. ;;; Code: @@ -42,10 +42,10 @@ (set-atype 'mime/content-decoding-condition '((type . "message/external-body") ("access-type" . "anon-ftp") - (method . mime/decode-message/external-ftp) + (method . mime-article/decode-message/external-ftp) )) - (autoload 'mime/decode-message/external-ftp "tm-ftp") - + (autoload 'mime-article/decode-message/external-ftp "tm-ftp") + ;; for LaTeX (set-atype 'mime/content-decoding-condition '((type . "text/x-latex")
--- a/lisp/version.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/version.el Mon Aug 13 08:49:43 2007 +0200 @@ -26,7 +26,7 @@ (defconst emacs-version "19.15" "\ Version numbers of this version of Emacs.") -(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta91)"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta92)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version)
--- a/lisp/vm/vm-autoload.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/vm/vm-autoload.el Mon Aug 13 08:49:43 2007 +0200 @@ -1,6 +1,5 @@ (provide 'vm-autoload) - (autoload (quote vm-delete-message) "vm-delete" "Add the `deleted' attribute to the current message. The message will be physically deleted from the current folder the next
--- a/lisp/w3/Makefile Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/w3/Makefile Mon Aug 13 08:49:43 2007 +0200 @@ -38,7 +38,7 @@ url-pgp.el url-vars.el url-wais.el url-auth.el mm.el md5.el \ url-gw.el ssl.el base64.el url.el socks.el -CUSTOMSOURCES = widget.el widget-edit.el +CUSTOMSOURCES = # widget.el widget-edit.el CUSTOMOBJECTS = $(CUSTOMSOURCES:.el=.elc) URLOBJECTS = $(URLSOURCES:.el=.elc)
--- a/lisp/w3/w3-sysdp.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/w3/w3-sysdp.el Mon Aug 13 08:49:43 2007 +0200 @@ -231,7 +231,7 @@ (sysdep-defalias 'get-other-frame 'get-other-screen) (sysdep-defalias 'iconify-frame 'iconify-screen) (sysdep-defalias 'lower-frame 'lower-screen) -(sysdep-defalias 'mail-other-frame 'mail-other-screen) +;(sysdep-defalias 'mail-other-frame 'mail-other-screen) (sysdep-defalias 'make-frame (cond ((fboundp 'make-screen)
--- a/lisp/w3/widget-edit.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2187 +0,0 @@ -;;; widget-edit.el --- Functions for creating and using widgets. -;; -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: extensions -;; Version: 1.22 -;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ - -;;; Commentary: -;; -;; See `widget.el'. - -;;; Code: - -(require 'widget) -(require 'cl) -(autoload 'pp-to-string "pp") -(autoload 'Info-goto-node "info") - -(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. -(eval-and-compile - (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 (&rest args) nil) - (defmacro defface (&rest args) nil) - (when (fboundp 'copy-face) - (copy-face 'default 'widget-documentation-face) - (copy-face 'bold 'widget-button-face) - (copy-face 'italic 'widget-field-face)) - (defvar widget-mouse-face 'highlight) - (defvar widget-menu-max-size 40))) - -;;; Compatibility. - -(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 'emacs) - -(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. - -(defun 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 "" - (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 - (cdr (assoc (completing-read (concat title ": ") - items nil t) - items))))) - -;;; 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))) - - (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 - '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 - 'face face - '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))) - (add-text-properties from to (list 'button widget - 'mouse-face widget-mouse-face - 'start-open t - 'end-open t - 'face face)))) - -(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))) - -;;; Widget Properties. - -(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'." - (cond ((widget-plist-member (cdr widget) property) - (plist-get (cdr widget) property)) - ((car widget) - (widget-get (get (car widget) 'widget-type) property)) - (t nil))) - -(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))) - -(defun widget-apply (widget property &rest args) - "Apply the value of WIDGET's PROPERTY to the widget itself. -ARGS are passed as extra argments 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))) - -;;; 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 Comands. - -(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 "\t" 'widget-forward) - (define-key widget-keymap "\M-\t" 'widget-backward) - (define-key widget-keymap [(shift tab)] 'widget-backward) - (define-key widget-keymap [(shift tab)] 'widget-backward) - (define-key widget-keymap [backtab] 'widget-backward) - (if (string-match "XEmacs" (emacs-version)) - (define-key widget-keymap [button2] 'widget-button-click) - (define-key widget-keymap [menu-bar] 'nil) - (define-key widget-keymap [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)) - (define-key widget-field-keymap "\C-m" 'widget-field-activate) - (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)) - (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 field :action event) - (call-interactively - (lookup-key widget-global-map (this-command-keys)))))) - -(defun widget-button-click (event) - "Activate button below mouse pointer." - (interactive "@e") - (widget-button-press (event-point event) event)) - -(defun widget-button-press (pos &optional event) - "Activate button at POS." - (interactive "@d") - (let* ((button (get-text-property pos 'button))) - (if button - (widget-apply button :action event) - (call-interactively - (lookup-key widget-global-map (this-command-keys)))))) - -(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"))))))))) - (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))))) - (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))) - -;;; 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) - :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)) - (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) - (if tag - (insert tag) - (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) - (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-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. - -(define-widget 'push-button 'item - "A pushable button." - :format "%[[%t]%]") - -;;; The `link' Widget. - -(define-widget 'link 'item - "An embedded link." - :help-echo "Push me to 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 - :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-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)) - (set-marker (widget-get widget :value-from) nil) - (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 'menu-choice - "Toggle between two states." - :convert-widget 'widget-toggle-convert-widget - :format "%v" - :on "on" - :off "off") - -(defun widget-toggle-convert-widget (widget) - ;; Create the types representing the `on' and `off' states. - (let ((on-type (widget-get widget :on-type)) - (off-type (widget-get widget :off-type))) - (unless on-type - (setq on-type - (list 'choice-item - :value t - :match (lambda (widget value) value) - :tag (widget-get widget :on)))) - (unless off-type - (setq off-type - (list 'choice-item :value nil :tag (widget-get widget :off)))) - (widget-put widget :args (list on-type off-type))) - widget) - -;;; The `checkbox' Widget. - -(define-widget 'checkbox 'toggle - "A checkbox toggle." - :convert-widget 'widget-item-convert-widget - :on-type '(choice-item :format "%[[X]%]" t) - :off-type '(choice-item :format "%[[ ]%]" nil)) - -;;; 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)) - (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 (widget-create-child-and-convert - widget 'checkbox :value (not (null chosen))))) - ((eq escape ?v) - (setq child - (cond ((not chosen) - (widget-create-child widget type)) - ((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 - :on-type '(choice-item :format "%[(*)%]" t) - :off-type '(choice-item :format "%[( )%]" nil)) - -(defun widget-radio-button-notify (widget child &optional event) - ;; Notify the parent. - (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)) - (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 (widget-create-child-and-convert - widget 'radio-button - :value (not (null chosen))))) - ((eq escape ?v) - (setq child (if chosen - (widget-create-child-value - widget type value) - (widget-create-child widget type)))) - (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 - (widget-value-set current value)) - (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-value button) - (widget-value-set button nil))))))) - ;; 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" - :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" - :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. - -(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. - (cond ((eq escape ?i) - (and (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (widget-create-child-and-convert widget 'insert-button)) - (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-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))) - 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 (widget-create-child-and-convert - widget 'insert-button))) - ((eq escape ?d) - (setq delete (widget-create-child-and-convert - widget 'delete-button))) - ((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 "Push me to toggle the 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 ": (defalt `" 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") - -;;; The `color' Widget. - -(define-widget 'color-item 'choice-item - "A color name (with sample)." - :format "%v (%[sample%])\n" - :button-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 "default" - :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 'widget-edit) - -;; widget-edit.el ends here
--- a/lisp/w3/widget.el Mon Aug 13 08:49:21 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -;;; widget.el --- a library of user interface components. -;; -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen <abraham@dina.kvl.dk> -;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.22 -;; 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 `widget-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 :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) - -;; These autoloads should be deleted when the file is added to Emacs. -(autoload 'widget-create "widget-edit") -(autoload 'widget-insert "widget-edit") - -;;;###autoload -(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
--- a/lisp/x11/x-menubar.el Mon Aug 13 08:49:21 2007 +0200 +++ b/lisp/x11/x-menubar.el Mon Aug 13 08:49:43 2007 +0200 @@ -638,6 +638,7 @@ ["No Warranty" describe-no-warranty t] ["XEmacs License" describe-copying t] ["The Latest Version" describe-distribution t]) + ,custom-help-menu ) )))
--- a/man/gnus.texi Mon Aug 13 08:49:21 2007 +0200 +++ b/man/gnus.texi Mon Aug 13 08:49:43 2007 +0200 @@ -8606,8 +8606,11 @@ mail belongs in that group. The last of these groups should always be a general one, and the regular -expression should @emph{always} be @samp{} so that it matches any -mails that haven't been matched by any of the other regexps. +expression should @emph{always} be @samp{} so that it matches any mails +that haven't been matched by any of the other regexps. (These rules are +processed from the beginning of the alist toward the end. The first +rule to make a match will "win", unless you have crossposting enabled. +In that case, all matching rules will "win".) If you like to tinker with this yourself, you can set this variable to a function of your choice. This function will be called without any @@ -12649,6 +12652,10 @@ If this variable is @code{nil} (which is the default), the mode line strings won't be chopped off, and they won't be padded either. +Note that the default is unlikely to be desirable, as even the +percentage complete in the buffer may be crowded off the mode line; +the user should configure this variable appropriately for their +configuration. @node Highlighting and Menus
--- a/src/Makefile.in.in Mon Aug 13 08:49:21 2007 +0200 +++ b/src/Makefile.in.in Mon Aug 13 08:49:43 2007 +0200 @@ -23,7 +23,7 @@ @SET_MAKE@ -/* Some people use these in paths they define. We don't want their paths +/* Some people use these in paths they define. We do not want their paths getting changed on them. */ #undef sparc #undef sun @@ -61,14 +61,14 @@ in-place location, it will not get recompiled in the not-in-place location. - The GNU Make `vpath' directive continues this tradition, but at + The GNU Make "vpath" directive continues this tradition, but at least lets you restrict the classes of files that it applies to. This allows us to kludge around the problem. */ #ifdef USE_GNU_MAKE vpath %.c @srcdir@ vpath %.h @srcdir@ /* now list files that should NOT be searched in the srcdir. - This includes any .c or .h that's built from something else + This includes any .c or .h that is built from something else (e.g. a .in file). */ vpath config.h vpath paths.h @@ -95,7 +95,7 @@ #endif /* On some machines #define register is done in config; - don't let it interfere with this file. */ + do not let it interfere with this file. */ #undef register /* On some systems we may not be able to use the system make command. */ @@ -107,7 +107,7 @@ CC = C_COMPILER #endif -/* Some machines don't find the standard C libraries in the usual place. */ +/* Some machines do not find the standard C libraries in the usual place. */ #ifndef ORDINARY_LINK #ifndef LIB_STANDARD #define LIB_STANDARD -lc @@ -244,7 +244,7 @@ #define C_OPTIMIZE_SWITCH -O #endif -/* cc switches needed to make `asm' keyword work. +/* cc switches needed to make "asm" keyword work. Nothing special needed on most machines. */ #ifndef C_SWITCH_ASM #define C_SWITCH_ASM @@ -422,7 +422,7 @@ for use in Emacs. -DHAVE_CONFIG_H is needed for some other files to take advantage of - the information in `config.h'. */ + the information in "config.h". */ /* C_SWITCH_X_SITE must come before C_SWITCH_X_MACHINE and C_SWITCH_X_SYSTEM since it may have -I options that should override those two. */ @@ -600,7 +600,7 @@ #define NSOBJS console-ns.o device-ns.o DIALOG_NS_OBJS event-ns.o frame-ns.o \ glyphs-ns.o MENUBAR_NS_OBJS nsselect.o objects-ns.o \ redisplay-ns.o SCROLLBAR_NS_OBJS TOOLBAR_NS_OBJS - + #else # define NSOBJS #endif /* HAVE_NEXTSTEP */ @@ -618,18 +618,18 @@ /* Versions of GCC >= 2.0 put their library, libgcc.a, in obscure places that are difficult to figure out at make time. Fortunately, these same versions allow you to pass arbitrary flags on to the - linker, so there's no reason not to use it as a linker. + linker, so there is no reason not to use it as a linker. - Well, it's not quite perfect. The `-nostdlib' keeps GCC from + Well, it is not quite perfect. The "-nostdlib" keeps GCC from searching for libraries in its internal directories, so we have to ask GCC explicitly where to find libgcc.a. */ #ifndef LINKER #define LINKER $(CC) -nostdlib /* GCC passes any argument prefixed with -Xlinker directly to the - linker. See prefix-args.c for an explanation of why we don't do - this with the shell's `for' construct. - Note that some people don't have '.' in their paths, so we must + linker. See prefix-args.c for an explanation of why we do not do + this with the shell "for" construct. + Note that some people do not have "." in their paths, so we must use ./prefix-args. */ #define YMF_PASS_LDFLAGS(flags) `./prefix-args -Xlinker flags` #endif /* LINKER */ @@ -679,7 +679,7 @@ #endif /* not ORDINARY_LINK */ /* A macro which other sections of the makefile can redefine to munge the - flags before they're passed to LD. This is helpful if you have + flags before they are passed to LD. This is helpful if you have redefined LD to something odd, like "gcc". */ #ifndef YMF_PASS_LDFLAGS #define YMF_PASS_LDFLAGS(flags) flags @@ -916,13 +916,13 @@ # define EXTERNAL_WIDGET_OBJS ExternalShell.o extw-Xt-nonshared.o extw-Xlib-nonshared.o /* Now we try to figure out how to link a shared library. - If we can't figure it out, leave EXTW_LINK undefined and a shared + If we can not figure it out, leave EXTW_LINK undefined and a shared library will not be created. */ # ifdef USE_GCC # ifdef USG5 # define EXTW_LINK(objs, output) $(CC) -shared objs -Xlinker -z -Xlinker text -o output - /* I can't figure out how to do shared a.out libraries, so just punt. */ + /* I can not figure out how to do shared a.out libraries, so just punt. */ # elif !defined (LINUX) || defined (__ELF__) # define EXTW_LINK(objs, output) $(CC) -shared objs -o output # endif @@ -1119,10 +1119,10 @@ /* List of Lisp files loaded into the dumped Emacs. Every file that is loaded from loadup.el must be enumerated - here, or the functions won't have docstrings. + here, or the functions will not have docstrings. This is dumb - this list should be generated automatically. - [Note: "version.el" is included in the doc separately, but is not listed - here because we don't want things to appear to be out-of-date just + [Note: "version.el" is included in the doc separately, but is not listed + here because we do not want things to appear to be out-of-date just because the version number has been incremented. -- D.N.G. 8/28/93] */ /* loaddefs is now included handled by the SUNPRO_LISP define because @@ -1158,14 +1158,16 @@ ${lispdir}modes/auto-show.elc SUNPRO_LISP TTY_LISP \ ${lispdir}bytecomp/bytecomp-runtime.elc FLOAT_LISP EPOCH_LISP \ ${lispdir}prim/itimer.elc ${lispdir}ediff/ediff-hook.elc \ + ${lispdir}custom/custom.elc ${lispdir}custom/widget.elc \ + ${lispdir}w3/w3-sysdp.elc ${lispdir}w3/font.elc \ ${lispdir}packages/fontl-hooks.elc SCROLLBAR_LISP \ ${lispdir}prim/buffer.elc MENUBAR_LISP \ ${lispdir}packages/buff-menu.elc DIALOG_LISP \ ${lispdir}modes/abbrev.elc X11_LISP NS_LISP ENERGIZE_LISP TOOLTALK_LISP -/* Other Lisp files that are not dumped out but where it's convenient +/* Other Lisp files that are not dumped out but where it is convenient (or required?) for them to be byte-compiled early, before xemacs - is dumped out. Don't list them in ${lisp} because then the doc-snarfing + is dumped out. Do not list them in ${lisp} because then the doc-snarfing routines get confused. */ otherlisp= ${lispdir}bytecomp/bytecomp.elc \ ${lispdir}bytecomp/byte-optimize.elc \ @@ -1433,9 +1435,9 @@ cd ${cppdir}; ${MAKE} ${MFLAGS} EMACS=-DEMACS ln ${cppdir}cpp localcpp /* Name where ALL_CFLAGS will refer to it */ /* cc appears to be cretinous and require all of these to exist - if -B is specified -- we can't use one local pass and let the + if -B is specified -- we can not use one local pass and let the others be the standard ones. What a loser. - We can't even use ln, since they are probably + We can not even use ln, since they are probably on different disks. */ cp /lib/ccom localccom -cp /lib/optim localoptim @@ -1487,7 +1489,7 @@ cp ${srcdir}/alloca.s allocatem.c /* Remove any ^L, blank lines, and preprocessor comments, since some assemblers barf on them. Use a different basename for the - output file, since some stupid compilers (Green Hill's) use that + output file, since some stupid compilers (Green Hill) use that name for the intermediate assembler file. */ $(CPP) $(CPPFLAGS) $(ALL_CFLAGS) allocatem.c | \ sed -e 's/ //' -e 's/^#.*//' | \ @@ -1587,7 +1589,7 @@ gnu-depend: $(obj_dep) /* #### Needs a bit of work: it doesn't see the object files that - we aren't compiling */ + we are not compiling */ cat $(obj_dep) | sh ${libsrc}process-gnu-depends.sh > depend.out #endif /* GCC */