diff lisp/custom/wid-edit.el @ 197:acd284d43ca1 r20-3b25

Import from CVS: tag r20-3b25
author cvs
date Mon, 13 Aug 2007 10:00:02 +0200
parents a2f645c6b9f8
children 850242ba4a81
line wrap: on
line diff
--- a/lisp/custom/wid-edit.el	Mon Aug 13 09:59:07 2007 +0200
+++ b/lisp/custom/wid-edit.el	Mon Aug 13 10:00:02 2007 +0200
@@ -312,6 +312,7 @@
 	 (set-extent-property extent 'end-closed t))
     (set-extent-property extent 'detachable nil)
     (set-extent-property extent 'field widget)
+    (set-extent-property extent 'tabable t)
     (set-extent-property extent 'keymap map)
     (set-extent-property extent 'face face)
     (set-extent-property extent 'balloon-help help-echo)
@@ -327,6 +328,7 @@
       (setq help-echo 'widget-mouse-help))
     (set-extent-property extent 'start-open t)
     (set-extent-property extent 'button widget)
+    (set-extent-property extent 'tabable t)
     (set-extent-property extent 'mouse-face widget-mouse-face)
     (set-extent-property extent 'balloon-help help-echo)
     (set-extent-property extent 'help-echo help-echo)
@@ -1004,7 +1006,7 @@
 	(when (commandp command)
 	  (call-interactively command))))))
 
-(defun widget-tabable-at (&optional pos)
+(defun widget-tabable-at (&optional pos last-tab backwardp)
   "Return the tabable widget at POS, or nil.
 POS defaults to the value of (point)."
   (unless pos
@@ -1013,9 +1015,10 @@
     (if widget
 	(let ((order (widget-get widget :tab-order)))
 	  (if order
-	      (if (>= order 0)
-		  widget
-		nil)
+	      (if last-tab (and (= order (if backwardp (1- last-tab)
+					   (1+ last-tab)))
+				widget)
+		(and (> order 0) widget))
 	    widget))
       nil)))
 
@@ -1029,76 +1032,74 @@
 		       :field-extent))))
 
 (defun widget-next-button-or-field (pos)
-  "Find the next button, or field, and return its start position.
-If none is found, return (point-max).
+  "Find the next button, or field, and return its start position, or nil.
 Internal function, don't use it outside `wid-edit'."
   (let* ((at-point (widget-button-or-field-extent pos))
 	 (extent (map-extents
 		  (lambda (ext ignore)
-		    (if (or (extent-property ext 'button)
-			    (extent-property ext 'field))
-			ext
-		      nil))
-		  nil (if at-point (extent-end-position at-point) pos) nil)))
-    (if extent
-	(extent-start-position extent)
-      (point-max))))
+		    ext)
+		  nil (if at-point (extent-end-position at-point) pos)
+		  nil nil 'start-open 'tabable)))
+    (and extent
+	 (extent-start-position extent))))
 
 (defun widget-previous-button-or-field (pos)
-  "Find the previous button, or field, and return its start position.
-If none is found, return (point-min).
+  "Find the previous button, or field, and return its start position, or nil.
 Internal function, don't use it outside `wid-edit'."
   (let* ((at-point (widget-button-or-field-extent pos))
 	 previous-extent)
     (map-extents
      (lambda (ext ignore)
-       (when (or (extent-property ext 'button)
-		 (extent-property ext 'field))
-	 (if (eq ext at-point)
-	     previous-extent
-	   (setq previous-extent ext)
-	   nil)))
-     nil nil pos)
-    (if previous-extent
-	(extent-start-position previous-extent)
-    (point-min))))
+       (if (eq ext at-point)
+	   previous-extent
+	 (setq previous-extent ext)
+	 nil))
+     nil nil pos nil 'start-open 'tabable)
+    (and previous-extent
+	 (extent-start-position previous-extent))))
 
 (defun widget-move (arg)
   "Move point to the ARG next field or button.
 ARG may be negative to move backward."
-  (let ((pos (point))
-	(number arg)
-	(old (widget-tabable-at)))
-    ;; Forward.
+  (let ((opoint (point)) (wrapped 0)
+	(last-tab (widget-get (widget-at (point)) :tab-order))
+	nextpos found)
+    ;; Movement backward
+    (while (< arg 0)
+      (setq nextpos (widget-previous-button-or-field (point)))
+      (if nextpos
+	  (progn
+	    (goto-char nextpos)
+	    (when (widget-tabable-at nil last-tab t)
+	      (incf arg)
+	      (setq found t
+		    last-tab (widget-get (widget-at (point))
+					 :tab-order))))
+	(if (and (not found) (> wrapped 1))
+	    (setq arg 0
+		  found nil)
+	  (goto-char (point-max))
+	  (incf wrapped))))
+    ;; Movement forward
     (while (> arg 0)
-      (goto-char (if (eobp)
-		     (point-min)
-		   (widget-next-button-or-field (point))))
-      (and (eq pos (point))
-	   (eq arg number)
-	   (error "No buttons or fields found"))
-      (let ((new (widget-tabable-at)))
-	(when new
-	  (unless (eq new old)
-	    (setq arg (1- arg))
-	    (setq old new)))))
-    ;; Backward.
-    (while (< arg 0)
-      (goto-char (if (bobp)
-		     (point-max)
-		   (widget-previous-button-or-field (point))))
-      (and (eq pos (point))
-	   (eq arg number)
-	   (error "No buttons or fields found"))
-      (let ((new (widget-tabable-at)))
-	(when new
-	  (unless (eq new old)
-	    (incf arg)))))
-    (let ((new (widget-tabable-at)))
-      (goto-char (extent-start-position (or (widget-get new :button-extent)
-					    (widget-get new :field-extent))))))
-  (widget-echo-help (point))
-  (run-hooks 'widget-move-hook))
+      (setq nextpos (widget-next-button-or-field (point)))
+      (if nextpos
+	  (progn
+	    (goto-char nextpos)
+	    (when (widget-tabable-at nil last-tab)
+	      (decf arg)
+	      (setq found t
+		    last-tab (widget-get (widget-at (point))
+					 :tab-order))))
+	(if (and (not found) (> wrapped 1))
+	    (setq arg 0
+		  found nil)
+	  (goto-char (point-min))
+	  (incf wrapped))))
+    (if (not found)
+	(goto-char opoint)
+      (widget-echo-help (point))
+      (run-hooks 'widget-move-hook))))
 
 (defun widget-forward (arg)
   "Move point to the next field or button.
@@ -2225,7 +2226,7 @@
 	found rest)
     (while values
       (let ((answer (widget-checklist-match-up args values)))
-	(cond (answer 
+	(cond (answer
 	       (let ((vals (widget-match-inline answer values)))
 		 (setq found (append found (car vals))
 		       values (cdr vals)
@@ -3256,7 +3257,7 @@
   :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)))
+  :value-to-external (lambda (widget value) (vconcat value)))
 
 (defun widget-vector-match (widget value) 
   (and (vectorp value)
@@ -3271,7 +3272,7 @@
   :value-to-internal (lambda (widget value)
 		       (list (car value) (cdr value)))
   :value-to-external (lambda (widget value)
-		       (cons (nth 0 value) (nth 1 value))))
+		       (cons (car value) (cadr value))))
 
 (defun widget-cons-match (widget value) 
   (and (consp value)
@@ -3362,7 +3363,7 @@
 
 (define-widget 'color 'editable-field 
   "Choose a color name (with sample)."
-  :format "%t: %v (%{sample%})\n"
+  :format "%[%t%]: %v (%{sample%})\n"
   :size 10
   :tag "Color"
   :value "black"
@@ -3412,22 +3413,7 @@
 (defun widget-color-action (widget &optional event)
   ;; Prompt for a color.
   (let* ((tag (widget-apply widget :menu-tag-get))
-	 (prompt (concat tag ": "))
-	 (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))))
+	 (answer (read-color (concat tag ": "))))
     (unless (zerop (length answer))
       (widget-value-set widget answer)
       (widget-setup)