Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 652:2cf5d151eeb9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-08-26 10:25:11 by stephent] Update docs for widgets and lisp/README. <15240.52706.361788.550139@turnbull.sk.tsukuba.ac.jp>
author stephent
date Sun, 26 Aug 2001 10:25:14 +0000
parents d7a9135ec789
children 76d5a3dd827a
comparison
equal deleted inserted replaced
651:98b3721724bd 652:2cf5d151eeb9
341 (set-extent-property extent 'face face) 341 (set-extent-property extent 'face face)
342 (widget-handle-help-echo extent help-echo)) 342 (widget-handle-help-echo extent help-echo))
343 (widget-specify-secret widget)) 343 (widget-specify-secret widget))
344 344
345 (defun widget-specify-secret (field) 345 (defun widget-specify-secret (field)
346 "Replace text in FIELD with value of `:secret', if non-nil." 346 "Replace text in FIELD with value of `:secret', if non-nil.
347
348 It is an error to use this function after creating the widget but before
349 invoking `widget-setup'."
347 (let ((secret (widget-get field :secret)) 350 (let ((secret (widget-get field :secret))
348 (size (widget-get field :size))) 351 (size (widget-get field :size)))
349 (when secret 352 (when secret
350 (let ((begin (widget-field-start field)) 353 (let ((begin (widget-field-start field))
351 (end (widget-field-end field))) 354 (end (widget-field-end field)))
550 ;; Recoded in C, for efficiency: 553 ;; Recoded in C, for efficiency:
551 (when (or (not (fboundp 'widget-get)) 554 (when (or (not (fboundp 'widget-get))
552 widget-shadow-subrs) 555 widget-shadow-subrs)
553 (defun widget-get (widget property) 556 (defun widget-get (widget property)
554 "In WIDGET, get the value of PROPERTY. 557 "In WIDGET, get the value of PROPERTY.
555 The value could either be specified when the widget was created, or 558 The value may have been specified when the widget was created, or
556 later with `widget-put'." 559 later with `widget-put'."
557 (let ((missing t) 560 (let ((missing t)
558 value tmp) 561 value tmp)
559 (while missing 562 (while missing
560 (cond ((setq tmp (widget-plist-member (cdr widget) property)) 563 (cond ((setq tmp (widget-plist-member (cdr widget) property))
601 (widget-apply widget 604 (widget-apply widget
602 :value-set (widget-apply widget 605 :value-set (widget-apply widget
603 :value-to-internal value))) 606 :value-to-internal value)))
604 607
605 (defun widget-default-get (widget) 608 (defun widget-default-get (widget)
606 "Extract the defaylt value of WIDGET." 609 "Extract the default value of WIDGET."
607 (or (widget-get widget :value) 610 (or (widget-get widget :value)
608 (widget-apply widget :default-get))) 611 (widget-apply widget :default-get)))
609 612
610 (defun widget-match-inline (widget vals) 613 (defun widget-match-inline (widget vals)
611 ;; In WIDGET, match the start of VALS. 614 "In WIDGET, match the start of VALS."
612 (cond ((widget-get widget :inline) 615 (cond ((widget-get widget :inline)
613 (widget-apply widget :match-inline vals)) 616 (widget-apply widget :match-inline vals))
614 ((and (listp vals) 617 ((and (listp vals)
615 (widget-apply widget :match (car vals))) 618 (widget-apply widget :match (car vals)))
616 (cons (list (car vals)) (cdr vals))) 619 (cons (list (car vals)) (cdr vals)))
843 846
844 ;;; Creating Widgets. 847 ;;; Creating Widgets.
845 848
846 ;;;###autoload 849 ;;;###autoload
847 (defun widget-create (type &rest args) 850 (defun widget-create (type &rest args)
848 "Create widget of TYPE. 851 "Create a widget of type TYPE.
849 The optional ARGS are additional keyword arguments." 852 The optional ARGS are additional keyword arguments."
850 (let ((widget (apply 'widget-convert type args))) 853 (let ((widget (apply 'widget-convert type args)))
851 (widget-apply widget :create) 854 (widget-apply widget :create)
852 widget)) 855 widget))
853 856
854 (defun widget-create-child-and-convert (parent type &rest args) 857 (defun widget-create-child-and-convert (parent type &rest args)
855 "As part of the widget PARENT, create a child widget TYPE. 858 "As a child of widget PARENT, create a widget of type TYPE.
856 The child is converted, using the keyword arguments ARGS." 859 The child is converted, using the keyword arguments ARGS."
857 (let ((widget (apply 'widget-convert type args))) 860 (let ((widget (apply 'widget-convert type args)))
858 (widget-put widget :parent parent) 861 (widget-put widget :parent parent)
859 (unless (widget-get widget :indent) 862 (unless (widget-get widget :indent)
860 (widget-put widget :indent (+ (or (widget-get parent :indent) 0) 863 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
862 (widget-get parent :offset)))) 865 (widget-get parent :offset))))
863 (widget-apply widget :create) 866 (widget-apply widget :create)
864 widget)) 867 widget))
865 868
866 (defun widget-create-child (parent type) 869 (defun widget-create-child (parent type)
867 "Create widget of TYPE." 870 "As a child of widget PARENT, create a widget of type TYPE.
871 The child is not converted."
868 (let ((widget (copy-sequence type))) 872 (let ((widget (copy-sequence type)))
869 (widget-put widget :parent parent) 873 (widget-put widget :parent parent)
870 (unless (widget-get widget :indent) 874 (unless (widget-get widget :indent)
871 (widget-put widget :indent (+ (or (widget-get parent :indent) 0) 875 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
872 (or (widget-get widget :extra-offset) 0) 876 (or (widget-get widget :extra-offset) 0)
911 (let ((next (nth 0 args))) 915 (let ((next (nth 0 args)))
912 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) 916 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
913 (setq args (nthcdr 2 args)) 917 (setq args (nthcdr 2 args))
914 (widget-put widget :args args) 918 (widget-put widget :args args)
915 (setq args nil)))) 919 (setq args nil))))
916 ;; Then Convert the widget. 920 ;; Then convert the widget.
917 (setq type widget) 921 (setq type widget)
918 (while type 922 (while type
919 (let ((convert-widget (plist-get (cdr type) :convert-widget))) 923 (let ((convert-widget (plist-get (cdr type) :convert-widget)))
920 (if convert-widget 924 (if convert-widget
921 (setq widget (funcall convert-widget widget)))) 925 (setq widget (funcall convert-widget widget))))
944 (apply 'insert args))) 948 (apply 'insert args)))
945 949
946 (defun widget-convert-text (type from to 950 (defun widget-convert-text (type from to
947 &optional button-from button-to 951 &optional button-from button-to
948 &rest args) 952 &rest args)
949 "Return a widget of type TYPE with endpoint FROM TO. 953 "Return a widget of type TYPE with endpoints FROM and TO.
950 Optional ARGS are extra keyword arguments for TYPE. 954 No text will be inserted in the buffer. Instead the positions FROM and TO
951 and TO will be used as the widgets end points. If optional arguments 955 will be used as the widget's end points. The widget is ``wrapped around''
952 BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets 956 the text between them.
953 button end points. 957 If optional arguments BUTTON-FROM and BUTTON-TO are given, these will be
958 used as the widget's button end points.
954 Optional ARGS are extra keyword arguments for TYPE." 959 Optional ARGS are extra keyword arguments for TYPE."
955 (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) 960 (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
956 (from (copy-marker from)) 961 (from (copy-marker from))
957 (to (copy-marker to))) 962 (to (copy-marker to)))
958 (set-marker-insertion-type from t) 963 (set-marker-insertion-type from t)
962 (when button-from 967 (when button-from
963 (widget-specify-button widget button-from button-to)) 968 (widget-specify-button widget button-from button-to))
964 widget)) 969 widget))
965 970
966 (defun widget-convert-button (type from to &rest args) 971 (defun widget-convert-button (type from to &rest args)
967 "Return a widget of type TYPE with endpoint FROM TO. 972 "Return a widget of type TYPE with endpoints FROM and TO.
968 Optional ARGS are extra keyword arguments for TYPE. 973 Optional ARGS are extra keyword arguments for TYPE.
969 No text will be inserted to the buffer, instead the text between FROM 974 No text will be inserted in the buffer. Instead the positions FROM and TO
970 and TO will be used as the widgets end points, as well as the widgets 975 will be used as the widget's end points, as well as the widget's button's
971 button end points." 976 end points. The widget is ``wrapped around'' the text between them."
972 (apply 'widget-convert-text type from to from to args)) 977 (apply 'widget-convert-text type from to from to args))
973 978
974 (defun widget-leave-text (widget) 979 (defun widget-leave-text (widget)
975 "Remove markers and extents from WIDGET and its children." 980 "Remove markers and extents from WIDGET and its children."
976 (let ((from (widget-get widget :from)) 981 (let ((from (widget-get widget :from))
1052 ;;Glyph support. 1057 ;;Glyph support.
1053 (define-key widget-button-keymap [button1] 'widget-button1-click)) 1058 (define-key widget-button-keymap [button1] 'widget-button1-click))
1054 1059
1055 1060
1056 (defun widget-field-activate (pos &optional event) 1061 (defun widget-field-activate (pos &optional event)
1057 "Invoke the ediable field at point." 1062 "Invoke the editable field at point."
1058 (interactive "@d") 1063 (interactive "@d")
1059 (let ((field (widget-field-find pos))) 1064 (let ((field (widget-field-find pos)))
1060 (if field 1065 (if field
1061 (widget-apply-action field event) 1066 (widget-apply-action field event)
1062 (call-interactively 1067 (call-interactively
1310 (interactive "p") 1315 (interactive "p")
1311 (run-hooks 'widget-backward-hook) 1316 (run-hooks 'widget-backward-hook)
1312 (widget-move (- arg))) 1317 (widget-move (- arg)))
1313 1318
1314 (defun widget-beginning-of-line () 1319 (defun widget-beginning-of-line ()
1315 "Go to beginning of field or beginning of line, whichever is first." 1320 "Go to beginning of field or beginning of line, whichever is first.
1321
1322 It is an error to use this function after creating the widget but before
1323 invoking `widget-setup'."
1316 (interactive "_") 1324 (interactive "_")
1317 (let* ((field (widget-field-find (point))) 1325 (let* ((field (widget-field-find (point)))
1318 (start (and field (widget-field-start field)))) 1326 (start (and field (widget-field-start field))))
1319 (if (and start (not (eq start (point)))) 1327 (if (and start (not (eq start (point))))
1320 (goto-char start) 1328 (goto-char start)
1321 (call-interactively 'beginning-of-line)))) 1329 (call-interactively 'beginning-of-line))))
1322 1330
1323 (defun widget-end-of-line () 1331 (defun widget-end-of-line ()
1324 "Go to end of field or end of line, whichever is first." 1332 "Go to end of field or end of line, whichever is first.
1333
1334 It is an error to use this function after creating the widget but before
1335 invoking `widget-setup'."
1325 (interactive "_") 1336 (interactive "_")
1326 (let* ((field (widget-field-find (point))) 1337 (let* ((field (widget-field-find (point)))
1327 (end (and field (widget-field-end field)))) 1338 (end (and field (widget-field-end field))))
1328 (if (and end (not (eq end (point)))) 1339 (if (and end (not (eq end (point))))
1329 (goto-char end) 1340 (goto-char end)
1330 (call-interactively 'end-of-line)))) 1341 (call-interactively 'end-of-line))))
1331 1342
1332 (defun widget-kill-line () 1343 (defun widget-kill-line ()
1333 "Kill to end of field or end of line, whichever is first." 1344 "Kill to end of field or end of line, whichever is first.
1345
1346 It is an error to use this function after creating the widget but before
1347 invoking `widget-setup'."
1334 (interactive) 1348 (interactive)
1335 (let* ((field (widget-field-find (point))) 1349 (let* ((field (widget-field-find (point)))
1336 (newline (save-excursion (forward-line 1) (point))) 1350 (newline (save-excursion (forward-line 1) (point)))
1337 (end (and field (widget-field-end field)))) 1351 (end (and field (widget-field-end field))))
1338 (if (and field (> newline end)) 1352 (if (and field (> newline end))
1423 (defvar widget-field-was nil) 1437 (defvar widget-field-was nil)
1424 ;; The widget data before the change. 1438 ;; The widget data before the change.
1425 (make-variable-buffer-local 'widget-field-was) 1439 (make-variable-buffer-local 'widget-field-was)
1426 1440
1427 (defun widget-field-buffer (widget) 1441 (defun widget-field-buffer (widget)
1428 "Return the start of WIDGET's editing field." 1442 "Return the buffer containing WIDGET.
1443
1444 It is an error to use this function after creating the widget but before
1445 invoking `widget-setup'."
1429 (let ((extent (widget-get widget :field-extent))) 1446 (let ((extent (widget-get widget :field-extent)))
1430 (and extent (extent-object extent)))) 1447 (and extent (extent-object extent))))
1431 1448
1432 (defun widget-field-start (widget) 1449 (defun widget-field-start (widget)
1433 "Return the start of WIDGET's editing field." 1450 "Return the start of WIDGET's editing field.
1451
1452 It is an error to use this function after creating the widget but before
1453 invoking `widget-setup'."
1434 (let ((extent (widget-get widget :field-extent))) 1454 (let ((extent (widget-get widget :field-extent)))
1435 (and extent (extent-start-position extent)))) 1455 (and extent (extent-start-position extent))))
1436 1456
1437 (defun widget-field-end (widget) 1457 (defun widget-field-end (widget)
1438 "Return the end of WIDGET's editing field." 1458 "Return the end of WIDGET's editing field.
1459
1460 It is an error to use this function after creating the widget but before
1461 invoking `widget-setup'."
1439 (let ((extent (widget-get widget :field-extent))) 1462 (let ((extent (widget-get widget :field-extent)))
1440 ;; Don't subtract one if local-map works at the end of the extent. 1463 ;; Don't subtract one if local-map works at the end of the extent.
1441 (and extent (if (or widget-field-add-space 1464 (and extent (if (or widget-field-add-space
1442 (null (widget-get widget :size))) 1465 (null (widget-get widget :size)))
1443 (1- (extent-end-position extent)) 1466 (1- (extent-end-position extent))
1444 (extent-end-position extent))))) 1467 (extent-end-position extent)))))
1445 1468
1446 (defun widget-field-find (pos) 1469 (defun widget-field-find (pos)
1447 "Return the field at POS. 1470 "Return the field at POS.
1448 Unlike (get-char-property POS 'field) this, works with empty fields too." 1471 Unlike (get-char-property POS 'field) this, works with empty fields too.
1472
1473 Warning: using this function after creating the widget but before invoking
1474 `widget-setup' will always fail."
1449 (let ((field-extent (map-extents (lambda (extent ignore) 1475 (let ((field-extent (map-extents (lambda (extent ignore)
1450 extent) 1476 extent)
1451 nil pos pos nil nil 'field))) 1477 nil pos pos nil nil 'field)))
1452 (and field-extent 1478 (and field-extent
1453 (extent-property field-extent 'field)))) 1479 (extent-property field-extent 'field))))
1465 ; (when found 1491 ; (when found
1466 ; (debug "Overlapping fields")) 1492 ; (debug "Overlapping fields"))
1467 ; (setq found field)))) 1493 ; (setq found field))))
1468 ; found)) 1494 ; found))
1469 1495
1496 ;; Warning: using this function after creating the widget but before
1497 ;; invoking `widget-setup' will always fail.
1470 (defun widget-before-change (from to) 1498 (defun widget-before-change (from to)
1471 ;; Barf if the text changed is outside the editable fields. 1499 ;; Barf if the text changed is outside the editable fields.
1472 (unless inhibit-read-only 1500 (unless inhibit-read-only
1473 (let ((from-field (widget-field-find from)) 1501 (let ((from-field (widget-field-find from))
1474 (to-field (widget-field-find to))) 1502 (to-field (widget-field-find to)))
2964 child)) 2992 child))
2965 2993
2966 ;;; The `group' Widget. 2994 ;;; The `group' Widget.
2967 2995
2968 (define-widget 'group 'default 2996 (define-widget 'group 'default
2969 "A widget which group other widgets inside." 2997 "A widget which groups other widgets inside."
2970 :convert-widget 'widget-types-convert-widget 2998 :convert-widget 'widget-types-convert-widget
2971 :format "%v" 2999 :format "%v"
2972 :value-create 'widget-group-value-create 3000 :value-create 'widget-group-value-create
2973 :value-delete 'widget-children-value-delete 3001 :value-delete 'widget-children-value-delete
2974 :value-get 'widget-editable-list-value-get 3002 :value-get 'widget-editable-list-value-get
3516 value)) 3544 value))
3517 :match (lambda (widget value) 3545 :match (lambda (widget value)
3518 (characterp value))) 3546 (characterp value)))
3519 3547
3520 (define-widget 'list 'group 3548 (define-widget 'list 'group
3521 "A lisp list." 3549 "A Lisp list."
3522 :tag "List" 3550 :tag "List"
3523 :format "%{%t%}:\n%v") 3551 :format "%{%t%}:\n%v")
3524 3552
3525 (define-widget 'vector 'group 3553 (define-widget 'vector 'group
3526 "A lisp vector." 3554 "A Lisp vector."
3527 :tag "Vector" 3555 :tag "Vector"
3528 :format "%{%t%}:\n%v" 3556 :format "%{%t%}:\n%v"
3529 :match 'widget-vector-match 3557 :match 'widget-vector-match
3530 :value-to-internal (lambda (widget value) (append value nil)) 3558 :value-to-internal (lambda (widget value) (append value nil))
3531 :value-to-external (lambda (widget value) (vconcat value))) 3559 :value-to-external (lambda (widget value) (vconcat value)))