diff lisp/wid-edit.el @ 19022:904dcdbb8576

Synched with 1.9951.

--- a/lisp/wid-edit.el	Mon Jul 28 15:10:21 1997 +0000
+++ b/lisp/wid-edit.el	Mon Jul 28 15:46:57 1997 +0000
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <[e-mail]>
 ;; 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 @@
 ;; 
 ;; 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 @@
   :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 @@
 
 (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 @@
 	  (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 @@
 
 (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 @@
 	   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 @@
 	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 @@
   (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 @@
 	(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 @@
       (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 @@
 	    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 @@
 	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 @@
 	    (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 @@
 	 (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 @@
 	 (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 @@
 	(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 @@
 	  (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 @@
        (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 @@
 	(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 @@
       (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 @@
   "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 (< (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 @@
 				      (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 @@
   "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 @@
   :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 @@
 	   (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 @@
   ;; 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)