Mercurial > hg > xemacs-beta

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b25
author cvs
date Mon, 13 Aug 2007 10:00:02 +0200
parents a2f645c6b9f8
children 850242ba4a81
comparison
equal deleted inserted replaced
196:58e0786448ca 197:acd284d43ca1
310 (and (or (not widget-field-add-space) 310 (and (or (not widget-field-add-space)
311 (widget-get widget :size)) 311 (widget-get widget :size))
312 (set-extent-property extent 'end-closed t)) 312 (set-extent-property extent 'end-closed t))
313 (set-extent-property extent 'detachable nil) 313 (set-extent-property extent 'detachable nil)
314 (set-extent-property extent 'field widget) 314 (set-extent-property extent 'field widget)
315 (set-extent-property extent 'tabable t)
315 (set-extent-property extent 'keymap map) 316 (set-extent-property extent 'keymap map)
316 (set-extent-property extent 'face face) 317 (set-extent-property extent 'face face)
317 (set-extent-property extent 'balloon-help help-echo) 318 (set-extent-property extent 'balloon-help help-echo)
318 (set-extent-property extent 'help-echo help-echo))) 319 (set-extent-property extent 'help-echo help-echo)))
319 320
325 (widget-put widget :button-extent extent) 326 (widget-put widget :button-extent extent)
326 (unless (or (null help-echo) (stringp help-echo)) 327 (unless (or (null help-echo) (stringp help-echo))
327 (setq help-echo 'widget-mouse-help)) 328 (setq help-echo 'widget-mouse-help))
328 (set-extent-property extent 'start-open t) 329 (set-extent-property extent 'start-open t)
329 (set-extent-property extent 'button widget) 330 (set-extent-property extent 'button widget)
331 (set-extent-property extent 'tabable t)
330 (set-extent-property extent 'mouse-face widget-mouse-face) 332 (set-extent-property extent 'mouse-face widget-mouse-face)
331 (set-extent-property extent 'balloon-help help-echo) 333 (set-extent-property extent 'balloon-help help-echo)
332 (set-extent-property extent 'help-echo help-echo) 334 (set-extent-property extent 'help-echo help-echo)
333 (set-extent-property extent 'face face))) 335 (set-extent-property extent 'face face)))
334 336
1002 (widget-apply-action button event) 1004 (widget-apply-action button event)
1003 (let ((command (lookup-key widget-global-map (this-command-keys)))) 1005 (let ((command (lookup-key widget-global-map (this-command-keys))))
1004 (when (commandp command) 1006 (when (commandp command)
1005 (call-interactively command)))))) 1007 (call-interactively command))))))
1006 1008
1007 (defun widget-tabable-at (&optional pos) 1009 (defun widget-tabable-at (&optional pos last-tab backwardp)
1008 "Return the tabable widget at POS, or nil. 1010 "Return the tabable widget at POS, or nil.
1009 POS defaults to the value of (point)." 1011 POS defaults to the value of (point)."
1010 (unless pos 1012 (unless pos
1011 (setq pos (point))) 1013 (setq pos (point)))
1012 (let ((widget (widget-at pos))) 1014 (let ((widget (widget-at pos)))
1013 (if widget 1015 (if widget
1014 (let ((order (widget-get widget :tab-order))) 1016 (let ((order (widget-get widget :tab-order)))
1015 (if order 1017 (if order
1016 (if (>= order 0) 1018 (if last-tab (and (= order (if backwardp (1- last-tab)
1017 widget 1019 (1+ last-tab)))
1018 nil) 1020 widget)
1021 (and (> order 0) widget))
1019 widget)) 1022 widget))
1020 nil))) 1023 nil)))
1021 1024
1022 ;; Return the button or field extent at point. 1025 ;; Return the button or field extent at point.
1023 (defun widget-button-or-field-extent (pos) 1026 (defun widget-button-or-field-extent (pos)
1027 (and (get-char-property pos 'field) 1030 (and (get-char-property pos 'field)
1028 (widget-get (get-char-property pos 'field) 1031 (widget-get (get-char-property pos 'field)
1029 :field-extent)))) 1032 :field-extent))))
1030 1033
1031 (defun widget-next-button-or-field (pos) 1034 (defun widget-next-button-or-field (pos)
1032 "Find the next button, or field, and return its start position. 1035 "Find the next button, or field, and return its start position, or nil.
1033 If none is found, return (point-max).
1034 Internal function, don't use it outside `wid-edit'." 1036 Internal function, don't use it outside `wid-edit'."
1035 (let* ((at-point (widget-button-or-field-extent pos)) 1037 (let* ((at-point (widget-button-or-field-extent pos))
1036 (extent (map-extents 1038 (extent (map-extents
1037 (lambda (ext ignore) 1039 (lambda (ext ignore)
1038 (if (or (extent-property ext 'button) 1040 ext)
1039 (extent-property ext 'field)) 1041 nil (if at-point (extent-end-position at-point) pos)
1040 ext 1042 nil nil 'start-open 'tabable)))
1041 nil)) 1043 (and extent
1042 nil (if at-point (extent-end-position at-point) pos) nil))) 1044 (extent-start-position extent))))
1043 (if extent
1044 (extent-start-position extent)
1045 (point-max))))
1046 1045
1047 (defun widget-previous-button-or-field (pos) 1046 (defun widget-previous-button-or-field (pos)
1048 "Find the previous button, or field, and return its start position. 1047 "Find the previous button, or field, and return its start position, or nil.
1049 If none is found, return (point-min).
1050 Internal function, don't use it outside `wid-edit'." 1048 Internal function, don't use it outside `wid-edit'."
1051 (let* ((at-point (widget-button-or-field-extent pos)) 1049 (let* ((at-point (widget-button-or-field-extent pos))
1052 previous-extent) 1050 previous-extent)
1053 (map-extents 1051 (map-extents
1054 (lambda (ext ignore) 1052 (lambda (ext ignore)
1055 (when (or (extent-property ext 'button) 1053 (if (eq ext at-point)
1056 (extent-property ext 'field)) 1054 previous-extent
1057 (if (eq ext at-point) 1055 (setq previous-extent ext)
1058 previous-extent 1056 nil))
1059 (setq previous-extent ext) 1057 nil nil pos nil 'start-open 'tabable)
1060 nil))) 1058 (and previous-extent
1061 nil nil pos) 1059 (extent-start-position previous-extent))))
1062 (if previous-extent
1063 (extent-start-position previous-extent)
1064 (point-min))))
1065 1060
1066 (defun widget-move (arg) 1061 (defun widget-move (arg)
1067 "Move point to the ARG next field or button. 1062 "Move point to the ARG next field or button.
1068 ARG may be negative to move backward." 1063 ARG may be negative to move backward."
1069 (let ((pos (point)) 1064 (let ((opoint (point)) (wrapped 0)
1070 (number arg) 1065 (last-tab (widget-get (widget-at (point)) :tab-order))
1071 (old (widget-tabable-at))) 1066 nextpos found)
1072 ;; Forward. 1067 ;; Movement backward
1068 (while (< arg 0)
1069 (setq nextpos (widget-previous-button-or-field (point)))
1070 (if nextpos
1071 (progn
1072 (goto-char nextpos)
1073 (when (widget-tabable-at nil last-tab t)
1074 (incf arg)
1075 (setq found t
1076 last-tab (widget-get (widget-at (point))
1077 :tab-order))))
1078 (if (and (not found) (> wrapped 1))
1079 (setq arg 0
1080 found nil)
1081 (goto-char (point-max))
1082 (incf wrapped))))
1083 ;; Movement forward
1073 (while (> arg 0) 1084 (while (> arg 0)
1074 (goto-char (if (eobp) 1085 (setq nextpos (widget-next-button-or-field (point)))
1075 (point-min) 1086 (if nextpos
1076 (widget-next-button-or-field (point)))) 1087 (progn
1077 (and (eq pos (point)) 1088 (goto-char nextpos)
1078 (eq arg number) 1089 (when (widget-tabable-at nil last-tab)
1079 (error "No buttons or fields found")) 1090 (decf arg)
1080 (let ((new (widget-tabable-at))) 1091 (setq found t
1081 (when new 1092 last-tab (widget-get (widget-at (point))
1082 (unless (eq new old) 1093 :tab-order))))
1083 (setq arg (1- arg)) 1094 (if (and (not found) (> wrapped 1))
1084 (setq old new))))) 1095 (setq arg 0
1085 ;; Backward. 1096 found nil)
1086 (while (< arg 0) 1097 (goto-char (point-min))
1087 (goto-char (if (bobp) 1098 (incf wrapped))))
1088 (point-max) 1099 (if (not found)
1089 (widget-previous-button-or-field (point)))) 1100 (goto-char opoint)
1090 (and (eq pos (point)) 1101 (widget-echo-help (point))
1091 (eq arg number) 1102 (run-hooks 'widget-move-hook))))
1092 (error "No buttons or fields found"))
1093 (let ((new (widget-tabable-at)))
1094 (when new
1095 (unless (eq new old)
1096 (incf arg)))))
1097 (let ((new (widget-tabable-at)))
1098 (goto-char (extent-start-position (or (widget-get new :button-extent)
1099 (widget-get new :field-extent))))))
1100 (widget-echo-help (point))
1101 (run-hooks 'widget-move-hook))
1102 1103
1103 (defun widget-forward (arg) 1104 (defun widget-forward (arg)
1104 "Move point to the next field or button. 1105 "Move point to the next field or button.
1105 With optional ARG, move across that many fields." 1106 With optional ARG, move across that many fields."
1106 (interactive "p") 1107 (interactive "p")
2223 (let ((greedy (widget-get widget :greedy)) 2224 (let ((greedy (widget-get widget :greedy))
2224 (args (copy-sequence (widget-get widget :args))) 2225 (args (copy-sequence (widget-get widget :args)))
2225 found rest) 2226 found rest)
2226 (while values 2227 (while values
2227 (let ((answer (widget-checklist-match-up args values))) 2228 (let ((answer (widget-checklist-match-up args values)))
2228 (cond (answer 2229 (cond (answer
2229 (let ((vals (widget-match-inline answer values))) 2230 (let ((vals (widget-match-inline answer values)))
2230 (setq found (append found (car vals)) 2231 (setq found (append found (car vals))
2231 values (cdr vals) 2232 values (cdr vals)
2232 args (delq answer args)))) 2233 args (delq answer args))))
2233 (greedy 2234 (greedy
3254 "A lisp vector." 3255 "A lisp vector."
3255 :tag "Vector" 3256 :tag "Vector"
3256 :format "%{%t%}:\n%v" 3257 :format "%{%t%}:\n%v"
3257 :match 'widget-vector-match 3258 :match 'widget-vector-match
3258 :value-to-internal (lambda (widget value) (append value nil)) 3259 :value-to-internal (lambda (widget value) (append value nil))
3259 :value-to-external (lambda (widget value) (apply 'vector value))) 3260 :value-to-external (lambda (widget value) (vconcat value)))
3260 3261
3261 (defun widget-vector-match (widget value) 3262 (defun widget-vector-match (widget value)
3262 (and (vectorp value) 3263 (and (vectorp value)
3263 (widget-group-match widget 3264 (widget-group-match widget
3264 (widget-apply widget :value-to-internal value)))) 3265 (widget-apply widget :value-to-internal value))))
3269 :format "%{%t%}:\n%v" 3270 :format "%{%t%}:\n%v"
3270 :match 'widget-cons-match 3271 :match 'widget-cons-match
3271 :value-to-internal (lambda (widget value) 3272 :value-to-internal (lambda (widget value)
3272 (list (car value) (cdr value))) 3273 (list (car value) (cdr value)))
3273 :value-to-external (lambda (widget value) 3274 :value-to-external (lambda (widget value)
3274 (cons (nth 0 value) (nth 1 value)))) 3275 (cons (car value) (cadr value))))
3275 3276
3276 (defun widget-cons-match (widget value) 3277 (defun widget-cons-match (widget value)
3277 (and (consp value) 3278 (and (consp value)
3278 (widget-group-match widget 3279 (widget-group-match widget
3279 (widget-apply widget :value-to-internal value)))) 3280 (widget-apply widget :value-to-internal value))))
3360 3361
3361 ;;; The `color' Widget. 3362 ;;; The `color' Widget.
3362 3363
3363 (define-widget 'color 'editable-field 3364 (define-widget 'color 'editable-field
3364 "Choose a color name (with sample)." 3365 "Choose a color name (with sample)."
3365 :format "%t: %v (%{sample%})\n" 3366 :format "%[%t%]: %v (%{sample%})\n"
3366 :size 10 3367 :size 10
3367 :tag "Color" 3368 :tag "Color"
3368 :value "black" 3369 :value "black"
3369 :complete 'widget-color-complete 3370 :complete 'widget-color-complete
3370 :sample-face-get 'widget-color-sample-face-get 3371 :sample-face-get 'widget-color-sample-face-get
3410 "History of entered colors") 3411 "History of entered colors")
3411 3412
3412 (defun widget-color-action (widget &optional event) 3413 (defun widget-color-action (widget &optional event)
3413 ;; Prompt for a color. 3414 ;; Prompt for a color.
3414 (let* ((tag (widget-apply widget :menu-tag-get)) 3415 (let* ((tag (widget-apply widget :menu-tag-get))
3415 (prompt (concat tag ": ")) 3416 (answer (read-color (concat tag ": "))))
3416 (value (widget-value widget))
3417 (start (widget-field-start widget))
3418 (pos (cond ((< (point) start)
3419 0)
3420 ((> (point) (+ start (length value)))
3421 (length value))
3422 (t
3423 (- (point) start))))
3424 (answer (if (commandp 'read-color)
3425 (read-color prompt)
3426 (completing-read (concat tag ": ")
3427 (widget-color-choice-list)
3428 nil nil
3429 (cons value pos)
3430 'widget-color-history))))
3431 (unless (zerop (length answer)) 3417 (unless (zerop (length answer))
3432 (widget-value-set widget answer) 3418 (widget-value-set widget answer)
3433 (widget-setup) 3419 (widget-setup)
3434 (widget-apply widget :notify widget event)))) 3420 (widget-apply widget :notify widget event))))
3435 3421