X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fwidget-edit.el;h=05a391f20d9722aa9b765617fc1e91c7c85df435;hb=0f995aa45fda1182fb3c0f69978cca5c689a25a8;hp=2541a6a430bc2edf90a83d2c0dfec8068054bc8c;hpb=2b93d0d6a7c0119e3c23f9ab27c52f932deea075;p=gnus diff --git a/lisp/widget-edit.el b/lisp/widget-edit.el index 2541a6a43..05a391f20 100644 --- a/lisp/widget-edit.el +++ b/lisp/widget-edit.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 0.98 +;; Version: 0.997 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -23,18 +23,17 @@ (require 'custom) (error nil)) -(eval-and-compile - (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))) +(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. @@ -174,7 +173,7 @@ minibuffer." (add-text-properties (1- from) from (list 'rear-nonsticky t 'end-open t 'invisible t)) - (when (or (string-match ".%v" (widget-get widget :format)) + (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 @@ -188,7 +187,7 @@ minibuffer." (when (widget-get widget :size) (put-text-property to (1+ to) 'invisible t) - (when (or (string-match "%v." (widget-get widget :format)) + (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 @@ -214,6 +213,8 @@ minibuffer." (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-doc (widget from to) @@ -390,6 +391,8 @@ Recommended as a parent keymap for modes using widgets.") (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) @@ -584,6 +587,22 @@ With optional ARG, move across that many fields." (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 @@ -760,7 +779,7 @@ With optional ARG, move across that many fields." :match 'widget-item-match :match-inline 'widget-item-match-inline :action 'widget-item-action - :format "%t") + :format "%t\n") (defun widget-item-convert-widget (widget) ;; Initialize :value and :tag from :args in WIDGET. @@ -861,6 +880,7 @@ With optional ARG, move across that many fields." :value-to-internal (widget-value widget)) 'widget-field-history))) + (widget-apply widget :notify widget event) (widget-setup))) (defun widget-field-value-create (widget) @@ -904,6 +924,7 @@ With optional ARG, move across that many fields." (setq from (1+ from) to (1- to)) (while (and size + (not (zerop size)) (> to from) (eq (char-after (1- to)) ?\ )) (setq to (1- to))) @@ -924,12 +945,13 @@ With optional ARG, move across that many fields." (define-widget 'menu-choice 'default "A menu of options." - :convert-widget 'widget-choice-convert-widget + :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-radio-value-delete + :value-delete 'widget-children-value-delete :value-get 'widget-choice-value-get :value-inline 'widget-choice-value-inline :action 'widget-choice-action @@ -938,17 +960,6 @@ With optional ARG, move across that many fields." :match 'widget-choice-match :match-inline 'widget-choice-match-inline) -(defun widget-choice-convert-widget (widget) - ;; Expand type args into widget objects. -; (widget-put widget :args (mapcar (lambda (child) -; (if (widget-get child ':converted) -; child -; (widget-put child ':converted t) -; (widget-convert child))) -; (widget-get widget :args))) - (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) - widget) - (defun widget-choice-value-create (widget) ;; Insert the first choice that matches the value. (let ((value (widget-get widget :value)) @@ -982,6 +993,7 @@ With optional ARG, move across that many fields." (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))) @@ -1012,7 +1024,8 @@ With optional ARG, move across that many fields." (widget-value-set widget (widget-apply current :value-to-external (widget-get current :value))) - (widget-setup))) + (widget-apply widget :notify widget event) + (widget-setup))) ;; Notify parent. (widget-apply widget :notify widget event) (widget-clear-undo)) @@ -1083,14 +1096,14 @@ With optional ARG, move across that many fields." (define-widget 'checklist 'default "A multiple choice widget." - :convert-widget 'widget-choice-convert-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-radio-value-delete + :value-delete 'widget-children-value-delete :value-get 'widget-checklist-value-get :validate 'widget-checklist-validate :match 'widget-checklist-match @@ -1253,13 +1266,13 @@ With optional ARG, move across that many fields." (define-widget 'radio-button-choice 'default "Select one of multiple options." - :convert-widget 'widget-choice-convert-widget + :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-radio-value-delete + :value-delete 'widget-children-value-delete :value-get 'widget-radio-value-get :value-inline 'widget-radio-value-inline :value-set 'widget-radio-value-set @@ -1321,13 +1334,6 @@ With optional ARG, move across that many fields." (widget-put widget :children (nconc children (list child)))) child))) -(defun widget-radio-value-delete (widget) - ;; Delete the child widgets. - (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-radio-value-get (widget) ;; Get value of the child widget. (let ((chosen (widget-radio-chosen widget))) @@ -1436,14 +1442,14 @@ With optional ARG, move across that many fields." (define-widget 'editable-list 'default "A variable list of widgets of the same type." - :convert-widget 'widget-choice-convert-widget + :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-radio-value-delete + :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get :validate 'widget-editable-list-validate :match 'widget-editable-list-match @@ -1625,10 +1631,10 @@ With optional ARG, move across that many fields." (define-widget 'group 'default "A widget which group other widgets inside." - :convert-widget 'widget-choice-convert-widget + :convert-widget 'widget-types-convert-widget :format "%v" :value-create 'widget-group-value-create - :value-delete 'widget-radio-value-delete + :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get :validate 'widget-editable-list-validate :match 'widget-group-match @@ -1710,14 +1716,14 @@ With optional ARG, move across that many fields." (condition-case nil (documentation symbol t) (error nil))) - :value-delete 'widget-radio-value-delete + :value-delete 'widget-children-value-delete :match (lambda (widget value) (symbolp value))) (define-widget 'variable-item 'item "An immutable variable name." :format "%v\n%h" :documentation-property 'variable-documentation - :value-delete 'widget-radio-value-delete + :value-delete 'widget-children-value-delete :match (lambda (widget value) (symbolp value))) (define-widget 'string 'editable-field @@ -1726,8 +1732,9 @@ With optional ARG, move across that many fields." :format "%[%t%]: %v") (define-widget 'regexp 'string + "A regular expression." ;; Should do validation. - "A regular expression.") + :tag "Regexp") (define-widget 'file 'string "A file widget. @@ -1746,6 +1753,7 @@ It will read a file name from the minibuffer when activated." (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 @@ -1767,7 +1775,7 @@ It will read a directory name from the minibuffer when activated." (intern value) value))) -(define-widget 'function 'symbol +(define-widget 'function 'sexp ;; Should complete on functions. "A lisp function." :tag "Function") @@ -1829,6 +1837,23 @@ It will read a directory name from the minibuffer when activated." 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" @@ -1840,10 +1865,6 @@ It will read a directory name from the minibuffer when activated." value)) :match (lambda (widget value) (numberp value))) -(define-widget 'hook 'sexp - "A emacs lisp hook" - :tag "Hook") - (define-widget 'list 'group "A lisp list." :tag "List" @@ -1922,7 +1943,7 @@ It will read a directory name from the minibuffer when activated." :tag "Color" :value "default" :value-create 'widget-color-value-create - :value-delete 'widget-radio-value-delete + :value-delete 'widget-children-value-delete :value-get 'widget-color-value-get :value-set 'widget-color-value-set :action 'widget-color-action @@ -1968,13 +1989,15 @@ It will read a directory name from the minibuffer when activated." (t (read-string prompt (widget-value widget)))))) (unless (zerop (length answer)) - (widget-value-set widget 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 2 t 'widget-echo-help-mouse)" +Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)" (let* ((pos (mouse-position)) (frame (car pos)) (x (car (cdr pos)))