diff options
Diffstat (limited to 'lisp/wid-edit.el')
| -rw-r--r-- | lisp/wid-edit.el | 185 |
1 files changed, 96 insertions, 89 deletions
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index ba431611815..9cb5f1ffd24 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: extensions -;; Version: 1.9945 +;; Version: 1.9951 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -38,6 +38,7 @@ (eval-and-compile (autoload 'pp-to-string "pp") (autoload 'Info-goto-node "info") + (autoload 'finder-commentary "finder" nil t) (when (string-match "XEmacs" emacs-version) (condition-case nil @@ -101,27 +102,6 @@ (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 @@ -352,18 +332,6 @@ minibuffer." ;; ;; 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 - 'rear-nonsticky nil - 'start-open nil - 'end-open nil))) - (defcustom widget-field-add-space (or (< emacs-major-version 20) (and (eq emacs-major-version 20) @@ -378,9 +346,9 @@ size field." :group 'widgets) (defcustom widget-field-use-before-change - (or (> emacs-minor-version 34) - (>= emacs-major-version 20) - (string-match "XEmacs" emacs-version)) + (and (or (> emacs-minor-version 34) + (> emacs-major-version 19)) + (not (string-match "XEmacs" emacs-version))) "Non-nil means use `before-change-functions' to track editable fields. This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. Using before hooks also means that the :notify function can't know the @@ -390,7 +358,6 @@ new value." (defun widget-specify-field (widget from 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. @@ -401,14 +368,6 @@ new value." (widget-field-add-space (insert-and-inherit " "))) (setq to (point))) - (if (or widget-field-add-space - (null (widget-get widget :size))) - (add-text-properties (1- to) to - '(front-sticky nil start-open t read-only to)) - (add-text-properties 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)) (face (or (widget-get widget :value-face) 'widget-field-face)) (help-echo (widget-get widget :help-echo)) @@ -461,8 +420,10 @@ new value." (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))) + (let ((overlay (make-overlay from to nil t nil))) + (overlay-put overlay 'widget-doc widget) + (overlay-put overlay 'face widget-documentation-face) + (widget-put widget :doc-overlay overlay))) (defmacro widget-specify-insert (&rest form) ;; Execute FORM without inheriting any text properties. @@ -474,7 +435,6 @@ new value." 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))) @@ -887,8 +847,7 @@ The optional ARGS are additional keyword arguments." before-change-functions after-change-functions (from (point))) - (apply 'insert args) - (widget-specify-text from (point)))) + (apply 'insert args))) (defun widget-convert-text (type from to &optional button-from button-to @@ -902,7 +861,6 @@ Optional ARGS are extra keyword arguments for TYPE." (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) (from (copy-marker from)) (to (copy-marker to))) - (widget-specify-text from to) (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) @@ -925,6 +883,7 @@ button end points." (to (widget-get widget :to)) (button (widget-get widget :button-overlay)) (sample (widget-get widget :sample-overlay)) + (doc (widget-get widget :doc-overlay)) (field (widget-get widget :field-overlay)) (children (widget-get widget :children))) (set-marker from nil) @@ -933,6 +892,8 @@ button end points." (delete-overlay button)) (when sample (delete-overlay sample)) + (when doc + (delete-overlay doc)) (when field (delete-overlay field)) (mapcar 'widget-leave-text children))) @@ -1126,6 +1087,12 @@ POS defaults to the value of (point)." widget)) nil))) +(defcustom widget-use-overlay-change (string-match "XEmacs" emacs-version) + "If non-nil, use overlay change functions to tab around in the buffer. +This is much faster, but doesn't work reliably on Emacs 19.34." + :type 'boolean + :group 'widgets) + (defun widget-move (arg) "Move point to the ARG next field or button. ARG may be negative to move backward." @@ -1136,9 +1103,12 @@ ARG may be negative to move backward." new) ;; Forward. (while (> arg 0) - (if (eobp) - (goto-char (point-min)) - (forward-char 1)) + (cond ((eobp) + (goto-char (point-min))) + (widget-use-overlay-change + (goto-char (next-overlay-change (point)))) + (t + (forward-char 1))) (and (eq pos (point)) (eq arg number) (error "No buttons or fields found")) @@ -1149,9 +1119,12 @@ ARG may be negative to move backward." (setq old new))))) ;; Backward. (while (< arg 0) - (if (bobp) - (goto-char (point-max)) - (backward-char 1)) + (cond ((bobp) + (goto-char (point-max))) + (widget-use-overlay-change + (goto-char (previous-overlay-change (point)))) + (t + (backward-char 1))) (and (eq pos (point)) (eq arg number) (error "No buttons or fields found")) @@ -1187,7 +1160,9 @@ With optional ARG, move across that many fields." (start (and field (widget-field-start field)))) (if (and start (not (eq start (point)))) (goto-char start) - (call-interactively 'beginning-of-line)))) + (call-interactively 'beginning-of-line))) + ;; XEmacs: preserve the region + (setq zmacs-region-stays t)) (defun widget-end-of-line () "Go to end of field or end of line, whichever is first." @@ -1196,7 +1171,9 @@ With optional ARG, move across that many fields." (end (and field (widget-field-end field)))) (if (and end (not (eq end (point)))) (goto-char end) - (call-interactively 'end-of-line)))) + (call-interactively 'end-of-line))) + ;; XEmacs: preserve the region + (setq zmacs-region-stays t)) (defun widget-kill-line () "Kill to end of field or end of line, whichever is first." @@ -1250,14 +1227,7 @@ When not inside a field, move to the previous button or field." (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) - (setq after-change-functions - (if widget-field-list '(widget-after-change) nil)) - (when widget-field-use-before-change - (make-local-variable 'before-change-functions) - (setq before-change-functions - (if widget-field-list '(widget-before-change) nil)))) + (widget-add-change)) (defvar widget-field-last nil) ;; Last field containing point. @@ -1302,13 +1272,29 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (setq found field)))) found)) -(defun widget-before-change (from &rest ignore) +(defun widget-before-change (from to) ;; This is how, for example, a variable changes its state to `modified'. ;; when it is being edited. - (condition-case nil - (let ((field (widget-field-find from))) - (widget-apply field :notify field)) - (error (debug "Before Change")))) + (let ((from-field (widget-field-find from)) + (to-field (widget-field-find to))) + (cond ((not (eq from-field to-field)) + (add-hook 'post-command-hook 'widget-add-change nil t) + (error "Change should be restricted to a single field")) + ((null from-field) + (add-hook 'post-command-hook 'widget-add-change nil t) + (error "Attempt to change text outside editable field")) + (widget-field-use-before-change + (condition-case nil + (widget-apply from-field :notify from-field) + (error (debug "Before Change"))))))) + +(defun widget-add-change () + (make-local-hook 'post-command-hook) + (remove-hook 'post-command-hook 'widget-add-change t) + (make-local-hook 'before-change-functions) + (add-hook 'before-change-functions 'widget-before-change nil t) + (make-local-hook 'after-change-functions) + (add-hook 'after-change-functions 'widget-after-change nil t)) (defun widget-after-change (from to old) ;; Adjust field size and text properties. @@ -1504,7 +1490,6 @@ If that does not exists, call the value of `widget-complete-field'." (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) @@ -1570,6 +1555,7 @@ If that does not exists, call the value of `widget-complete-field'." (inactive-overlay (widget-get widget :inactive)) (button-overlay (widget-get widget :button-overlay)) (sample-overlay (widget-get widget :sample-overlay)) + (doc-overlay (widget-get widget :doc-overlay)) before-change-functions after-change-functions (inhibit-read-only t)) @@ -1580,6 +1566,8 @@ If that does not exists, call the value of `widget-complete-field'." (delete-overlay button-overlay)) (when sample-overlay (delete-overlay sample-overlay)) + (when doc-overlay + (delete-overlay doc-overlay)) (when (< from to) ;; Kludge: this doesn't need to be true for empty formats. (delete-region from to)) @@ -1822,6 +1810,16 @@ If END is omitted, it defaults to the length of LIST." "Find the Emacs Library file specified by WIDGET." (find-file (locate-library (widget-value widget)))) +;;; The `emacs-commentary-link' Widget. + +(define-widget 'emacs-commentary-link 'link + "A link to Commentary in an Emacs Lisp library file." + :action 'widget-emacs-commentary-link-action) + +(defun widget-emacs-commentary-link-action (widget &optional event) + "Find the Commentary section of the Emacs file specified by WIDGET." + (finder-commentary (widget-value widget))) + ;;; The `editable-field' Widget. (define-widget 'editable-field 'default @@ -2609,8 +2607,6 @@ when he invoked the menu." (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)) @@ -2684,7 +2680,6 @@ when he invoked the menu." (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) @@ -2943,7 +2938,8 @@ link for that string." "A regular expression." :match 'widget-regexp-match :validate 'widget-regexp-validate - :value-face 'widget-single-line-field-face + ;; Doesn't work well with terminating newline. + ;; :value-face 'widget-single-line-field-face :tag "Regexp") (defun widget-regexp-match (widget value) @@ -2969,7 +2965,8 @@ It will read a file name from the minibuffer when invoked." :complete-function 'widget-file-complete :prompt-value 'widget-file-prompt-value :format "%{%t%}: %v" - :value-face 'widget-single-line-field-face + ;; Doesn't work well with terminating newline. + ;; :value-face 'widget-single-line-field-face :tag "File") (defun widget-file-complete () @@ -3386,11 +3383,14 @@ To use this type, you must define :match or :match-alternatives." (message "Making completion list...done"))))) (defun widget-color-sample-face-get (widget) - (let ((symbol (intern (concat "fg:" (widget-value widget))))) + (let* ((value (condition-case nil + (widget-value widget) + (error (widget-get widget :value)))) + (symbol (intern (concat "fg:" value)))) (if (string-match "XEmacs" emacs-version) (prog1 symbol (or (find-face symbol) - (set-face-foreground (make-face symbol) (widget-value widget)))) + (set-face-foreground (make-face symbol) value))) (condition-case nil (facemenu-get-face symbol) (error 'default))))) @@ -3414,14 +3414,21 @@ To use this type, you must define :match or :match-alternatives." ;; 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)))))) + (value (widget-value widget)) + (start (widget-field-start widget)) + (pos (cond ((< (point) start) + 0) + ((> (point) (+ start (length value))) + (length value)) + (t + (- (point) start)))) + (answer (if (commandp 'read-color) + (read-color prompt) + (completing-read (concat tag ": ") + (widget-color-choice-list) + nil nil + (cons value pos) + 'widget-color-history)))) (unless (zerop (length answer)) (widget-value-set widget answer) (widget-setup) |