Mercurial > hg > xemacs-beta
diff lisp/custom/wid-edit.el @ 155:43dd3413c7c7 r20-3b4
Import from CVS: tag r20-3b4
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:39:39 +0200 |
| parents | 25f70ba0133c |
| children | 6b37e6ddd302 |
line wrap: on
line diff
--- a/lisp/custom/wid-edit.el Mon Aug 13 09:38:27 2007 +0200 +++ b/lisp/custom/wid-edit.el Mon Aug 13 09:39:39 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: extensions -;; Version: 1.98 +;; Version: 1.9907 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -31,7 +31,7 @@ ;;; Code: (require 'widget) -(require 'cl) +(eval-when-compile (require 'cl)) ;;; Compatibility. @@ -45,26 +45,6 @@ (error (load-library "x-overlay")))) (if (string-match "XEmacs" emacs-version) - ;; XEmacs spell `intangible' as `atomic'. - (defun widget-make-intangible (from to side) - "Make text between FROM and TO atomic with regard to movement. -Third argument should be `start-open' if it should be sticky to the rear, -and `end-open' if it should sticky to the front." - (require 'atomic-extents) - (let ((ext (make-extent from to))) - ;; XEmacs doesn't understant different kinds of read-only, so - ;; we have to use extents instead. - (put-text-property from to 'read-only nil) - (set-extent-property ext 'read-only t) - (set-extent-property ext 'start-open nil) - (set-extent-property ext 'end-open nil) - (set-extent-property ext side t) - (set-extent-property ext 'atomic t))) - (defun widget-make-intangible (from to size) - "Make text between FROM and TO intangible." - (put-text-property from to 'intangible 'front))) - - (if (string-match "XEmacs" emacs-version) (defun widget-event-point (event) "Character position of the end of event if that exists, or nil." (if (mouse-event-p event) @@ -74,7 +54,11 @@ "Character position of the end of event if that exists, or nil." (posn-point (event-end event)))) -;; The following should go away when bundled with Emacs. +(defalias 'widget-read-event (if (string-match "XEmacs" emacs-version) + 'next-event + 'read-event)) + + ;; The following should go away when bundled with Emacs. (condition-case () (require 'custom) (error nil)) @@ -109,6 +93,27 @@ (display-error obj buf) (buffer-string buf))))) +(when (let ((a "foo")) + (put-text-property 1 2 'foo 1 a) + (put-text-property 1 2 'bar 2 a) + (set-text-properties 1 2 nil a) + (text-properties-at 1 a)) + ;; XEmacs 20.2 and earlier had a buggy set-text-properties. + (defun set-text-properties (start end props &optional buffer-or-string) + "Completely replace properties of text from START to END. +The third argument PROPS is the new property list. +The optional fourth argument, BUFFER-OR-STRING, +is the string or buffer containing the text." + (map-extents #'(lambda (extent ignored) + (remove-text-properties + start end + (list (extent-property extent 'text-prop) + nil) + buffer-or-string) + nil) + buffer-or-string start end nil nil 'text-prop) + (add-text-properties start end props buffer-or-string))) + ;;; Customization. (defgroup widgets nil @@ -121,16 +126,6 @@ :group 'faces :group 'hypermedia) -(defface widget-documentation-face '((((class color) - (background dark)) - (:foreground "lime green")) - (((class color) - (background light)) - (:foreground "dark green")) - (t nil)) - "Face used for documentation text." - :group 'widgets) - (defface widget-button-face '((t (:bold t))) "Face used for widget buttons." :group 'widgets) @@ -225,7 +220,7 @@ (car (event-object val)))) (cdr (assoc val items)))) (t - (setq items (remove-if 'stringp items)) + (setq items (widget-remove-if 'stringp items)) (let ((val (completing-read (concat title ": ") items nil t))) (if (stringp val) (let ((try (try-completion val items))) @@ -234,6 +229,14 @@ (cdr (assoc val items))) nil))))) +(defun widget-remove-if (predictate list) + (let (result (tail list)) + (while tail + (or (funcall predictate (car tail)) + (setq result (cons (car tail) result))) + (setq tail (cdr tail))) + (nreverse result))) + ;;; Widget text specifications. ;; ;; These functions are for specifying text properties. @@ -246,119 +249,52 @@ ;; Default properties. (add-text-properties from to (list 'read-only t 'front-sticky t - 'start-open t - 'end-open t - 'rear-nonsticky nil))) + 'rear-nonsticky nil + 'start-open nil + 'end-open 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. + "Specify editable button for WIDGET between FROM and TO." + (put-text-property from to 'read-only nil) + ;; Terminating space is not part of the field, but necessary in + ;; order for local-map to work. Remove next sexp if local-map works + ;; at the end of the overlay. + (save-excursion + (goto-char to) + (insert-and-inherit " ") + (setq to (point))) + (add-text-properties (1- to) to ;to (1+ to) + '(front-sticky nil start-open t read-only to)) + (add-text-properties (1- from) from + '(rear-nonsticky t end-open t read-only from)) (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)) + (face (or (widget-get widget :value-face) 'widget-field-face)) (help-echo (widget-get widget :help-echo)) - (help-property (if (featurep 'balloon-help) - 'balloon-help - 'help-echo))) + (overlay (make-overlay from to nil nil t))) (unless (or (stringp help-echo) (null help-echo)) - (setq help-echo 'widget-mouse-help)) - - (when secret - (while (and size - (not (zerop size)) - (> secret-to from) - (eq (char-after (1- secret-to)) ?\ )) - (setq secret-to (1- secret-to))) - - (save-excursion - (goto-char from) - (while (< (point) secret-to) - (let ((old (get-text-property (point) 'secret))) - (when old - (subst-char-in-region (point) (1+ (point)) secret old))) - (forward-char)))) - - (set-text-properties from to (list 'field widget - 'read-only nil - 'keymap map - 'local-map map - help-property help-echo - 'face face)) - - (when secret - (save-excursion - (goto-char from) - (while (< (point) secret-to) - (let ((old (following-char))) - (subst-char-in-region (point) (1+ (point)) old secret) - (put-text-property (point) (1+ (point)) 'secret old)) - (forward-char)))) - - (unless (widget-get widget :size) - (add-text-properties to (1+ to) (list 'field widget - help-property help-echo - 'face face))) - (add-text-properties to (1+ to) (list 'local-map map - 'keymap map)))) + (setq help-echo 'widget-mouse-help)) + (widget-put widget :field-overlay overlay) + (overlay-put overlay 'detachable nil) + (overlay-put overlay 'field widget) + (overlay-put overlay 'local-map map) + (overlay-put overlay 'keymap map) + (overlay-put overlay 'face face) + (overlay-put overlay 'balloon-help help-echo) + (overlay-put overlay 'help-echo help-echo))) (defun widget-specify-button (widget from to) - ;; Specify button for WIDGET between FROM and TO. + "Specify button for WIDGET between FROM and TO." (let ((face (widget-apply widget :button-face-get)) (help-echo (widget-get widget :help-echo)) - (help-property (if (featurep 'balloon-help) - 'balloon-help - 'help-echo))) + (overlay (make-overlay from to nil t nil))) + (widget-put widget :button-overlay overlay) (unless (or (null help-echo) (stringp help-echo)) (setq help-echo 'widget-mouse-help)) - (add-text-properties from to (list 'button widget - 'mouse-face widget-mouse-face - 'start-open t - 'end-open t - help-property help-echo - 'face face)))) + (overlay-put overlay 'button widget) + (overlay-put overlay 'mouse-face widget-mouse-face) + (overlay-put overlay 'balloon-help help-echo) + (overlay-put overlay 'help-echo help-echo) + (overlay-put overlay 'face face))) (defun widget-mouse-help (extent) "Find mouse help string for button in extent." @@ -418,6 +354,7 @@ (unless (widget-get widget :inactive) (let ((overlay (make-overlay from to nil t nil))) (overlay-put overlay 'face 'widget-inactive-face) + (overlay-put overlay 'mouse-face 'widget-inactive-face) (overlay-put overlay 'evaporate t) (overlay-put overlay 'priority 100) (overlay-put overlay (if (string-match "XEmacs" emacs-version) @@ -501,9 +438,10 @@ (defun widget-apply-action (widget &optional event) "Apply :action in WIDGET in response to EVENT." - (if (widget-apply widget :active) - (widget-apply widget :action event) - (error "Attempt to perform action on inactive widget"))) + (let (after-change-functions) + (if (widget-apply widget :active) + (widget-apply widget :action event) + (error "Attempt to perform action on inactive widget")))) ;;; Helper functions. ;; @@ -560,27 +498,23 @@ (repeat :tag "Suffixes" (string :format "%v"))))) -(defun widget-glyph-insert (widget tag image) - "In WIDGET, insert the text TAG or, if supported, IMAGE. -IMAGE should either be a glyph, an image instantiator, or an image file -name sans extension (xpm, xbm, gif, jpg, or png) located in -`widget-glyph-directory'. - -WARNING: If you call this with a glyph, and you want the user to be -able to activate the glyph, make sure it is unique. If you use the -same glyph for multiple widgets, activating any of the glyphs will -cause the last created widget to be activated." - (cond ((not (and (string-match "XEmacs" emacs-version) +(defun widget-glyph-find (image tag) + "Create a glyph corresponding to IMAGE with string TAG as fallback. +IMAGE should either already be a glyph, or be a file name sans +extension (xpm, xbm, gif, jpg, or png) located in +`widget-glyph-directory'." + (cond ((not (and image + (string-match "XEmacs" emacs-version) widget-glyph-enable (fboundp 'make-glyph) (fboundp 'locate-file) image)) ;; We don't want or can't use glyphs. - (insert tag)) + nil) ((and (fboundp 'glyphp) (glyphp image)) - ;; Already a glyph. Insert it. - (widget-glyph-insert-glyph widget image)) + ;; Already a glyph. Use it. + image) ((stringp image) ;; A string. Look it up in relevant directories. (let* ((dirlist (list (or widget-glyph-directory @@ -592,49 +526,72 @@ (while (and formats (not file)) (when (valid-image-instantiator-format-p (car (car formats))) (setq file (locate-file image dirlist - (mapconcat 'identity (cdr (car formats)) + (mapconcat 'identity + (cdr (car formats)) ":")))) - (setq formats (cdr formats))) - ;; We create a glyph with the file as the default image - ;; instantiator, and the TAG fallback - (widget-glyph-insert-glyph - widget - (make-glyph (if file - (list (vector (car (car formats)) ':file file) - (vector 'string ':data tag)) - (vector 'string ':data tag)))))) + (unless file + (setq formats (cdr formats)))) + (and file + ;; We create a glyph with the file as the default image + ;; instantiator, and the TAG fallback + (make-glyph (list (vector (car (car formats)) ':file file) + (vector 'string ':data tag)))))) ((valid-instantiator-p image 'image) - ;; A valid image instantiator (e.g. [gif ':file "somefile"] etc.) - (widget-glyph-insert-glyph widget - (list image - (vector 'string ':data tag)))) + ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) + (make-glyph (list image + (vector 'string ':data tag)))) + ((consp image) + ;; This could be virtually anything. Let `make-glyph' sort it out. + (make-glyph image)) (t ;; Oh well. - (insert tag)))) + nil))) + +(defun widget-glyph-insert (widget tag image &optional down inactive) + "In WIDGET, insert the text TAG or, if supported, IMAGE. +IMAGE should either be a glyph, an image instantiator, or an image file +name sans extension (xpm, xbm, gif, jpg, or png) located in +`widget-glyph-directory'. + +Optional arguments DOWN and INACTIVE is used instead of IMAGE when the +glyph is pressed or inactive, respectively. + +WARNING: If you call this with a glyph, and you want the user to be +able to invoke the glyph, make sure it is unique. If you use the +same glyph for multiple widgets, invoking any of the glyphs will +cause the last created widget to be invoked. + +Instead of an instantiator, you can also use a list of instantiators, +or whatever `make-glyph' will accept. However, in that case you must +provide the fallback TAG as a part of the instantiator yourself." + (let ((glyph (widget-glyph-find image tag))) + (if glyph + (widget-glyph-insert-glyph widget + glyph + (widget-glyph-find down tag) + (widget-glyph-find inactive tag)) + (insert tag)))) (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) - "In WIDGET, with alternative text TAG, insert GLYPH." + "In WIDGET, insert GLYPH. +If optional arguments DOWN and INACTIVE are given, they should be +glyphs used when the widget is pushed and inactive, respectively." (set-glyph-property glyph 'widget widget) (when down (set-glyph-property down 'widget widget)) (when inactive (set-glyph-property inactive 'widget widget)) (insert "*") - (add-text-properties (1- (point)) (point) - (list 'invisible t - 'end-glyph glyph)) + (let ((ext (make-extent (point) (1- (point)))) + (help-echo (widget-get widget :help-echo))) + (set-extent-property ext 'invisible t) + (set-extent-end-glyph ext glyph) + (when help-echo + (set-extent-property ext 'balloon-help help-echo) + (set-extent-property ext 'help-echo help-echo))) (widget-put widget :glyph-up glyph) (when down (widget-put widget :glyph-down down)) - (when inactive (widget-put widget :glyph-inactive inactive)) - (let ((help-echo (widget-get widget :help-echo))) - (when help-echo - (let ((extent (extent-at (1- (point)) nil 'end-glyph)) - (help-property (if (featurep 'balloon-help) - 'balloon-help - 'help-echo))) - (set-extent-property extent help-property (if (stringp help-echo) - help-echo - 'widget-mouse-help)))))) + (when inactive (widget-put widget :glyph-inactive inactive))) ;;; Buttons. @@ -645,12 +602,12 @@ (defcustom widget-button-prefix "" "String used as prefix for buttons." :type 'string - :group 'widgets) + :group 'widget-button) (defcustom widget-button-suffix "" "String used as suffix for buttons." :type 'string - :group 'widgets) + :group 'widget-button) (defun widget-button-insert-indirect (widget key) "Insert value of WIDGET's KEY property." @@ -771,9 +728,7 @@ (unless widget-keymap (setq widget-keymap (make-sparse-keymap)) - (define-key widget-keymap "\C-k" 'widget-kill-line) (define-key widget-keymap "\t" 'widget-forward) - (define-key widget-keymap "\M-\t" 'widget-backward) (define-key widget-keymap [(shift tab)] 'widget-backward) (define-key widget-keymap [backtab] 'widget-backward) (if (string-match "XEmacs" emacs-version) @@ -795,6 +750,8 @@ (setq widget-field-keymap (copy-keymap widget-keymap)) (unless (string-match "XEmacs" (emacs-version)) (define-key widget-field-keymap [menu-bar] 'nil)) + (define-key widget-field-keymap "\C-k" 'widget-kill-line) + (define-key widget-field-keymap "\M-\t" 'widget-complete) (define-key widget-field-keymap "\C-m" 'widget-field-activate) (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line) (define-key widget-field-keymap "\C-e" 'widget-end-of-line) @@ -812,9 +769,9 @@ (set-keymap-parent widget-text-keymap global-map)) (defun widget-field-activate (pos &optional event) - "Activate the ediable field at point." + "Invoke the ediable field at point." (interactive "@d") - (let ((field (get-text-property pos 'field))) + (let ((field (get-char-property pos 'field))) (if field (widget-apply-action field event) (call-interactively @@ -829,32 +786,30 @@ :group 'widgets) (defun widget-button-click (event) - "Activate button below mouse pointer." + "Invoke button below mouse pointer." (interactive "@e") (cond ((and (fboundp 'event-glyph) (event-glyph event)) (widget-glyph-click event)) ((widget-event-point event) (let* ((pos (widget-event-point event)) - (button (get-text-property pos 'button))) + (button (get-char-property pos 'button))) (if button - (let ((begin (previous-single-property-change (1+ pos) 'button)) - (end (next-single-property-change pos 'button)) - overlay) + (let* ((overlay (widget-get button :button-overlay)) + (face (overlay-get overlay 'face)) + (mouse-face (overlay-get overlay 'mouse-face))) (unwind-protect (let ((track-mouse t)) - (setq overlay (make-overlay begin end)) - (overlay-put overlay 'face 'widget-button-pressed-face) + (overlay-put overlay + 'face 'widget-button-pressed-face) (overlay-put overlay 'mouse-face 'widget-button-pressed-face) (unless (widget-apply button :mouse-down-action event) (while (not (button-release-event-p event)) - (setq event (if (fboundp 'read-event) - (read-event) - (next-event)) + (setq event (widget-read-event) pos (widget-event-point event)) (if (and pos - (eq (get-text-property pos 'button) + (eq (get-char-property pos 'button) button)) (progn (overlay-put overlay @@ -863,22 +818,37 @@ (overlay-put overlay 'mouse-face 'widget-button-pressed-face)) - (overlay-put overlay 'face nil) - (overlay-put overlay 'mouse-face nil)))) - + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face)))) (when (and pos - (eq (get-text-property pos 'button) button)) + (eq (get-char-property pos 'button) button)) (widget-apply-action button event))) - (delete-overlay overlay))) - (call-interactively - (or (lookup-key widget-global-map [ button2 ]) - (lookup-key widget-global-map [ down-mouse-2 ]) - (lookup-key widget-global-map [ mouse-2])))))) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face))) + (let (command up) + ;; Find the global command to run, and check whether it + ;; is bound to an up event. + (cond ((setq command ;down event + (lookup-key widget-global-map [ button2 ]))) + ((setq command ;down event + (lookup-key widget-global-map [ down-mouse-2 ]))) + ((setq command ;up event + (lookup-key widget-global-map [ button2up ])) + (setq up t)) + ((setq command ;up event + (lookup-key widget-global-map [ mouse-2])) + (setq up t))) + (when command + ;; Don't execute up events twice. + (when up + (while (not (button-release-event-p event)) + (setq event (widget-read-event)))) + (call-interactively command)))))) (t (message "You clicked somewhere weird.")))) (defun widget-button1-click (event) - "Activate glyph below mouse pointer." + "Invoke glyph below mouse pointer." (interactive "@e") (if (and (fboundp 'event-glyph) (event-glyph event)) @@ -913,9 +883,9 @@ (widget-apply-action widget event))))))) (defun widget-button-press (pos &optional event) - "Activate button at POS." + "Invoke button at POS." (interactive "@d") - (let ((button (get-text-property pos 'button))) + (let ((button (get-char-property pos 'button))) (if button (widget-apply-action button event) (let ((command (lookup-key widget-global-map (this-command-keys)))) @@ -925,77 +895,47 @@ (defun widget-move (arg) "Move point to the ARG next field or button. ARG may be negative to move backward." - (while (> arg 0) - (setq arg (1- arg)) - (let ((next (cond ((get-text-property (point) 'button) - (next-single-property-change (point) 'button)) - ((get-text-property (point) 'field) - (next-single-property-change (point) 'field)) - (t - (point))))) - (if (null next) ; Widget extends to end. of buffer - (setq next (point-min))) - (let ((button (next-single-property-change next 'button)) - (field (next-single-property-change next 'field))) - (cond ((or (get-text-property next 'button) - (get-text-property next 'field)) - (goto-char next)) - ((and button field) - (goto-char (min button field))) - (button (goto-char button)) - (field (goto-char field)) - (t - (let ((button (next-single-property-change (point-min) 'button)) - (field (next-single-property-change (point-min) 'field))) - (cond ((and button field) (goto-char (min button field))) - (button (goto-char button)) - (field (goto-char field)) - (t - (error "No buttons or fields found")))))) - (setq button (widget-at (point))) - (if (or (and button (widget-get button :tab-order) - (< (widget-get button :tab-order) 0)) - (and button (not (widget-apply button :active)))) - (setq arg (1+ arg)))))) - (while (< arg 0) - (if (= (point-min) (point)) + (or (bobp) (> arg 0) (backward-char)) + (let ((pos (point)) + (number arg) + (old (or (get-char-property (point) 'button) + (get-char-property (point) 'field))) + new) + ;; Forward. + (while (> arg 0) + (if (eobp) + (goto-char (point-min)) (forward-char 1)) - (setq arg (1+ arg)) - (let ((previous (cond ((get-text-property (1- (point)) 'button) - (previous-single-property-change (point) 'button)) - ((get-text-property (1- (point)) 'field) - (previous-single-property-change (point) 'field)) - (t - (point))))) - (if (null previous) ; Widget extends to beg. of buffer - (setq previous (point-max))) - (let ((button (previous-single-property-change previous 'button)) - (field (previous-single-property-change previous 'field))) - (cond ((and button field) - (goto-char (max button field))) - (button (goto-char button)) - (field (goto-char field)) - (t - (let ((button (previous-single-property-change - (point-max) 'button)) - (field (previous-single-property-change - (point-max) 'field))) - (cond ((and button field) (goto-char (max button field))) - (button (goto-char button)) - (field (goto-char field)) - (t - (error "No buttons or fields found")))))))) - (let ((button (previous-single-property-change (point) 'button)) - (field (previous-single-property-change (point) 'field))) - (cond ((and button field) - (goto-char (max button field))) - (button (goto-char button)) - (field (goto-char field))) - (setq button (widget-at (point))) - (if (or (and button (widget-get button :tab-order) - (< (widget-get button :tab-order) 0)) - (and button (not (widget-apply button :active)))) - (setq arg (1- arg))))) + (and (eq pos (point)) + (eq arg number) + (error "No buttons or fields found")) + (let ((new (or (get-char-property (point) 'button) + (get-char-property (point) 'field)))) + (when new + (unless (eq new old) + (unless (and (widget-get new :tab-order) + (< (widget-get new :tab-order) 0)) + (setq arg (1- arg))) + (setq old new))))) + ;; Backward. + (while (< arg 0) + (if (bobp) + (goto-char (point-max)) + (backward-char 1)) + (and (eq pos (point)) + (eq arg number) + (error "No buttons or fields found")) + (let ((new (or (get-char-property (point) 'button) + (get-char-property (point) 'field)))) + (when new + (unless (eq new old) + (unless (and (widget-get new :tab-order) + (< (widget-get new :tab-order) 0)) + (setq arg (1+ arg))))))) + (while (or (get-char-property (point) 'button) + (get-char-property (point) 'field)) + (backward-char)) + (forward-char)) (widget-echo-help (point)) (run-hooks 'widget-move-hook)) @@ -1016,27 +956,46 @@ (defun widget-beginning-of-line () "Go to beginning of field or beginning of line, whichever is first." (interactive) - (let ((bol (save-excursion (beginning-of-line) (point))) - (prev (previous-single-property-change (point) 'field))) - (goto-char (max bol (or prev bol))))) + (let* ((field (widget-field-find (point))) + (start (and field (widget-field-start field)))) + (if (and start (not (eq start (point)))) + (goto-char start) + (call-interactively 'beginning-of-line)))) (defun widget-end-of-line () "Go to end of field or end of line, whichever is first." (interactive) - (let ((bol (save-excursion (end-of-line) (point))) - (prev (next-single-property-change (point) 'field))) - (goto-char (min bol (or prev bol))))) + (let* ((field (widget-field-find (point))) + (end (and field (widget-field-end field)))) + (if (and end (not (eq end (point)))) + (goto-char end) + (call-interactively 'end-of-line)))) (defun widget-kill-line () "Kill to end of field or end of line, whichever is first." (interactive) - (let ((field (get-text-property (point) 'field)) - (newline (save-excursion (search-forward "\n"))) + (let ((field (get-char-property (point) 'field)) + (newline (save-excursion (forward-line 1))) (next (next-single-property-change (point) 'field))) (if (and field (> newline next)) (kill-region (point) next) (call-interactively 'kill-line)))) +(defcustom widget-complete-field (lookup-key global-map "\M-\t") + "Default function to call for completion inside fields." + :options '(ispell-complete-word complete-tag lisp-complete-symbol) + :type 'function + :group 'widgets) + +(defun widget-complete () + "Complete content of editable field from point. +When not inside a field, move to the previous button or field." + (interactive) + (let ((field (widget-field-find (point)))) + (if field + (widget-apply field :complete) + (error "Not in an editable field")))) + ;;; Setting up the buffer. (defvar widget-field-new nil) @@ -1056,15 +1015,15 @@ (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))) + (let ((from (car (widget-get field :field-overlay))) + (to (cdr (widget-get field :field-overlay)))) (widget-specify-field field from to) - (move-marker from (1- from)) - (move-marker to (1+ to))))) + (set-marker from nil) + (set-marker to nil)))) (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 + (if (and widget-field-list) (setq after-change-functions '(widget-after-change)) (setq after-change-functions nil))) @@ -1076,63 +1035,67 @@ ;; The widget data before the change. (make-variable-buffer-local 'widget-field-was) +(defun widget-field-buffer (widget) + "Return the start of WIDGET's editing field." + (overlay-buffer (widget-get widget :field-overlay))) + +(defun widget-field-start (widget) + "Return the start of WIDGET's editing field." + (overlay-start (widget-get widget :field-overlay))) + +(defun widget-field-end (widget) + "Return the end of WIDGET's editing field." + ;; Don't subtract one if local-map works at the end of the overlay. + (1- (overlay-end (widget-get widget :field-overlay)))) + (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. + "Return the field at POS. +Unlike (get-char-property POS 'field) this, works with empty fields too." (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)))) + (let ((start (widget-field-start field)) + (end (widget-field-end field))) + (when (and (<= start pos) (<= pos end)) + (when found + (debug "Overlapping fields")) + (setq 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)))) + (other (widget-field-find to))) + (when field + (unless (eq field other) + (debug "Change in different fields")) + (let ((size (widget-get field :size))) + (when size + (let ((begin (widget-field-start field)) + (end (widget-field-end field))) + (cond ((< (- end begin) size) + ;; Field too small. + (save-excursion + (goto-char end) + (insert-char ?\ (- (+ begin size) end)))) + ((> (- 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-apply field :notify field))) + (error (debug "After Change")))) ;;; Widget Functions ;; @@ -1188,6 +1151,7 @@ :value-to-external (lambda (widget value) value) :button-prefix 'widget-button-prefix :button-suffix 'widget-button-suffix + :complete 'widget-default-complete :create 'widget-default-create :indent nil :offset 0 @@ -1207,6 +1171,12 @@ :notify 'widget-default-notify :prompt-value 'widget-default-prompt-value) +(defun widget-default-complete (widget) + "Call the value of the :complete-function property of WIDGET. +If that does not exists, call the value of `widget-complete-field'." + (let ((fun (widget-get widget :complete-function))) + (call-interactively (or fun widget-complete-field)))) + (defun widget-default-create (widget) "Create WIDGET at point in the current buffer." (widget-specify-insert @@ -1305,18 +1275,9 @@ ;; 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)) + (push (widget-create-child-and-convert + widget 'documentation-string + doc-text) buttons))) (t (error "Unknown escape `%c'" escape))) @@ -1334,9 +1295,15 @@ ;; Remove widget from the buffer. (let ((from (widget-get widget :from)) (to (widget-get widget :to)) - (inhibit-read-only t) - after-change-functions) + (inactive-overlay (widget-get widget :inactive)) + (button-overlay (widget-get widget :button-overlay)) + after-change-functions + (inhibit-read-only t)) (widget-apply widget :value-delete) + (when inactive-overlay + (delete-overlay inactive-overlay)) + (when button-overlay + (delete-overlay button-overlay)) (when (< from to) ;; Kludge: this doesn't need to be true for empty formats. (delete-region from to)) @@ -1422,9 +1389,21 @@ (let ((value (widget-get widget :value))) (and (listp value) (<= (length value) (length values)) - (let ((head (subseq values 0 (length value)))) + (let ((head (widget-sublist values 0 (length value)))) (and (equal head value) - (cons head (subseq values (length value)))))))) + (cons head (widget-sublist values (length value)))))))) + +(defun widget-sublist (list start &optional end) + "Return the sublist of LIST from START to END. +If END is omitted, it defaults to the length of LIST." + (if (> start 0) (setq list (nthcdr start list))) + (if end + (if (<= end start) + nil + (setq list (copy-sequence list)) + (setcdr (nthcdr (- end start 1) list) nil) + list) + (copy-sequence list))) (defun widget-item-action (widget &optional event) ;; Just notify itself. @@ -1492,12 +1471,12 @@ ;;; The `link' Widget. -(defcustom widget-link-prefix "_" +(defcustom widget-link-prefix "[" "String used as prefix for links." :type 'string :group 'widget-button) -(defcustom widget-link-suffix "_" +(defcustom widget-link-suffix "]" "String used as suffix for links." :type 'string :group 'widget-button) @@ -1578,8 +1557,8 @@ (widget-value widget)))) (let ((answer (widget-apply widget :prompt-value prompt value invalid) )) (widget-value-set widget answer))) - (widget-apply widget :notify widget event) - (widget-setup))) + (widget-setup) + (widget-apply widget :notify widget event))) (defun widget-field-validate (widget) ;; Valid if the content matches `:valid-regexp'. @@ -1592,59 +1571,54 @@ (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))) + (from (point)) + (overlay (cons (make-marker) (make-marker)))) + (widget-put widget :field-overlay overlay) (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))) + (move-marker (cdr overlay) (point)) + (set-marker-insertion-type (cdr overlay) nil) + (when (null size) + (insert ?\n)) + (move-marker (car overlay) from) + (set-marker-insertion-type (car overlay) 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))) + (let ((overlay (widget-get widget :field-overlay))) + (when overlay + (delete-overlay overlay)))) (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)) + (let ((from (widget-field-start widget)) + (to (widget-field-end widget)) + (buffer (widget-field-buffer widget)) (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)) + (set-buffer buffer) (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 (string-match "XEmacs" emacs-version) - ;; XEmacs 20.1 bug: b-s-n-p doesn't clear all properties. - (setq result (format "%s" result))) (when secret (let ((index 0)) (while (< (+ from index) to) (aset result index - (get-text-property (+ from index) 'secret)) + (get-char-property (+ from index) 'secret)) (setq index (1+ index))))) (set-buffer old) result)) @@ -1711,7 +1685,7 @@ (defcustom widget-choice-toggle nil "If non-nil, a binary choice will just toggle between the values. Otherwise, the user will explicitly have to choose between the values -when he activate the menu." +when he invoked the menu." :type 'boolean :group 'widgets) @@ -1778,8 +1752,8 @@ (widget-value-set widget (widget-apply current :value-to-external (widget-get current :value))) - (widget-apply widget :notify widget event) - (widget-setup)))) + (widget-setup) + (widget-apply widget :notify widget event)))) (defun widget-choice-validate (widget) ;; Valid if we have made a valid choice. @@ -2328,7 +2302,7 @@ (setq children (cdr children))) (setcdr children (cons child (cdr children))))))) (widget-setup) - widget (widget-apply widget :notify widget)) + (widget-apply widget :notify widget)) (defun widget-editable-list-delete-at (widget child) ;; Delete child from list of children. @@ -2460,20 +2434,88 @@ (cons found vals) nil))) -;;; The `widget-help' Widget. +;;; The `visibility' Widget. + +(define-widget 'visibility 'item + "An indicator and manipulator for hidden items." + :format "%[%v%]" + :button-prefix "" + :button-suffix "" + :on "hide" + :off "show" + :value-create 'widget-visibility-value-create + :action 'widget-toggle-action + :match (lambda (widget value) t)) + +(defun widget-visibility-value-create (widget) + ;; Insert text representing the `on' and `off' states. + (let ((on (widget-get widget :on)) + (off (widget-get widget :off))) + (if on + (setq on (concat widget-push-button-prefix + on + widget-push-button-suffix)) + (setq on "")) + (if off + (setq off (concat widget-push-button-prefix + off + widget-push-button-suffix)) + (setq off "")) + (if (widget-value widget) + (widget-glyph-insert widget on "down" "down-pushed") + (widget-glyph-insert widget off "right" "right-pushed") + (insert "...")))) + +;;; The `documentation-string' Widget. -(define-widget 'widget-help 'push-button - "The widget documentation button." - :format "%[%t%] %d" - :help-echo "Toggle display of documentation." - :action 'widget-help-action) +(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) + +(define-widget 'documentation-string 'item + "A documentation string." + :format "%v" + :action 'widget-documentation-string-action + :value-delete 'widget-children-value-delete + :value-create 'widget-documentation-string-value-create) -(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)) +(defun widget-documentation-string-value-create (widget) + ;; Insert documentation string. + (let ((doc (widget-value widget)) + (shown (widget-get (widget-get widget :parent) :documentation-shown))) + (if (string-match "\n" doc) + (let ((before (substring doc 0 (match-beginning 0))) + (after (substring doc (match-beginning 0))) + (start (point)) + buttons) + (insert before " ") + (widget-specify-doc widget start (point)) + (push (widget-create-child-and-convert + widget 'visibility + :off nil + :action 'widget-parent-action + shown) + buttons) + (when shown + (setq start (point)) + (insert after) + (widget-specify-doc widget start (point))) + (widget-put widget :buttons buttons)) + (insert doc))) + (insert "\n")) + +(defun widget-documentation-string-action (widget &rest ignore) + ;; Toggle documentation. + (let ((parent (widget-get widget :parent))) + (widget-put parent :documentation-shown + (not (widget-get parent :documentation-shown)))) + ;; Redraw. (widget-value-set widget (widget-value widget))) ;;; The Sexp Widgets. @@ -2507,6 +2549,7 @@ "A string" :tag "String" :format "%{%t%}: %v" + :complete-function 'ispell-complete-word :prompt-history 'widget-string-prompt-value-history) (define-widget 'regexp 'string @@ -2534,7 +2577,7 @@ (define-widget 'file 'string "A file widget. -It will read a file name from the minibuffer when activated." +It will read a file name from the minibuffer when invoked." :prompt-value 'widget-file-prompt-value :format "%{%t%}: %v" :tag "File" @@ -2561,12 +2604,12 @@ (answer (read-file-name (concat menu-tag ": (default `" value "') ") dir nil must-match file))) (widget-value-set widget (abbreviate-file-name answer)) - (widget-apply widget :notify widget event) - (widget-setup))) + (widget-setup) + (widget-apply widget :notify widget event))) (define-widget 'directory 'file "A directory widget. -It will read a directory name from the minibuffer when activated." +It will read a directory name from the minibuffer when invoked." :tag "Directory") (defvar widget-symbol-prompt-value-history nil @@ -2605,6 +2648,7 @@ (define-widget 'function 'sexp "A lisp function." + :complete-function 'lisp-complete-symbol :prompt-value 'widget-field-prompt-value :prompt-internal 'widget-symbol-prompt-internal :prompt-match 'fboundp @@ -2636,7 +2680,9 @@ (defun widget-sexp-value-to-internal (widget value) ;; Use pp for printer representation. - (let ((pp (pp-to-string value))) + (let ((pp (if (symbolp value) + (prin1-to-string value) + (pp-to-string value)))) (while (string-match "\n\\'" pp) (setq pp (substring pp 0 -1))) (if (or (string-match "\n\\'" pp) @@ -2843,11 +2889,14 @@ :sample-face-get 'widget-color-item-button-face-get) (defun widget-color-item-button-face-get (widget) - ;; We create a face from the value. - (require 'facemenu) - (condition-case nil - (facemenu-get-face (intern (concat "fg:" (widget-value widget)))) - (error 'default))) + (let ((symbol (intern (concat "fg:" (widget-value widget))))) + (if (string-match "XEmacs" emacs-version) + (prog1 symbol + (or (find-face symbol) + (set-face-foreground (make-face symbol) (widget-value widget)))) + (condition-case nil + (facemenu-get-face symbol) + (error 'default))))) (define-widget 'color 'push-button "Choose a color name (with sample)." @@ -2902,8 +2951,8 @@ (read-string prompt (widget-value widget)))))) (unless (zerop (length answer)) (widget-value-set widget answer) - (widget-apply widget :notify widget event) - (widget-setup)))) + (widget-setup) + (widget-apply widget :notify widget event)))) ;;; The Help Echo @@ -2941,8 +2990,8 @@ (defun widget-at (pos) "The button or field at POS." - (or (get-text-property pos 'button) - (get-text-property pos 'field))) + (or (get-char-property pos 'button) + (get-char-property pos 'field))) (defun widget-echo-help (pos) "Display the help echo for widget at POS."