Mercurial > emacs
comparison lisp/wid-edit.el @ 18090:2983683a278b
Synched with 1.9905
author | Per Abrahamsen <abraham@dina.kvl.dk> |
---|---|
date | Sun, 01 Jun 1997 18:03:25 +0000 |
parents | bb0e09c8ada3 |
children | fa4eb2f6b05a |
comparison
equal
deleted
inserted
replaced
18089:bb0e09c8ada3 | 18090:2983683a278b |
---|---|
2 ;; | 2 ;; |
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. | 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. |
4 ;; | 4 ;; |
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
6 ;; Keywords: extensions | 6 ;; Keywords: extensions |
7 ;; Version: 1.9904 | 7 ;; Version: 1.9905 |
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
9 | 9 |
10 ;; This file is part of GNU Emacs. | 10 ;; This file is part of GNU Emacs. |
11 | 11 |
12 ;; GNU Emacs is free software; you can redistribute it and/or modify | 12 ;; GNU Emacs is free software; you can redistribute it and/or modify |
42 (when (string-match "XEmacs" emacs-version) | 42 (when (string-match "XEmacs" emacs-version) |
43 (condition-case nil | 43 (condition-case nil |
44 (require 'overlay) | 44 (require 'overlay) |
45 (error (load-library "x-overlay")))) | 45 (error (load-library "x-overlay")))) |
46 | 46 |
47 (if (string-match "XEmacs" emacs-version) | |
48 ;; XEmacs spell `intangible' as `atomic'. | |
49 (defun widget-make-intangible (from to side) | |
50 "Make text between FROM and TO atomic with regard to movement. | |
51 Third argument should be `start-open' if it should be sticky to the rear, | |
52 and `end-open' if it should sticky to the front." | |
53 (require 'atomic-extents) | |
54 (let ((ext (make-extent from to))) | |
55 ;; XEmacs doesn't understant different kinds of read-only, so | |
56 ;; we have to use extents instead. | |
57 (put-text-property from to 'read-only nil) | |
58 (set-extent-property ext 'read-only t) | |
59 (set-extent-property ext 'start-open nil) | |
60 (set-extent-property ext 'end-open nil) | |
61 (set-extent-property ext side t) | |
62 (set-extent-property ext 'atomic t))) | |
63 (defun widget-make-intangible (from to size) | |
64 "Make text between FROM and TO intangible." | |
65 (put-text-property from to 'intangible 'front))) | |
66 | |
67 (if (string-match "XEmacs" emacs-version) | 47 (if (string-match "XEmacs" emacs-version) |
68 (defun widget-event-point (event) | 48 (defun widget-event-point (event) |
69 "Character position of the end of event if that exists, or nil." | 49 "Character position of the end of event if that exists, or nil." |
70 (if (mouse-event-p event) | 50 (if (mouse-event-p event) |
71 (event-point event) | 51 (event-point event) |
272 (set-text-properties from to nil)) | 252 (set-text-properties from to nil)) |
273 | 253 |
274 (defun widget-specify-text (from to) | 254 (defun widget-specify-text (from to) |
275 ;; Default properties. | 255 ;; Default properties. |
276 (add-text-properties from to (list 'read-only t | 256 (add-text-properties from to (list 'read-only t |
277 ;; Emacs is sticky. | |
278 'front-sticky t | 257 'front-sticky t |
279 'rear-nonsticky nil | 258 'rear-nonsticky nil |
280 ;; XEmacs is non-sticky. | 259 'start-open nil |
281 'start-open t | 260 'end-open nil))) |
282 'end-open t | |
283 ;; This is because `insert' | |
284 ;; inherit sticky text properties | |
285 ;; in XEmacs but not in Emacs. | |
286 ))) | |
287 | 261 |
288 (defun widget-specify-field (widget from to) | 262 (defun widget-specify-field (widget from to) |
289 ;; Specify editable button for WIDGET between FROM and TO. | 263 "Specify editable button for WIDGET between FROM and TO." |
290 (widget-specify-field-update widget from to) | 264 (put-text-property from to 'read-only nil) |
291 | 265 (add-text-properties (1- from) from |
292 ;; Make it possible to edit the front end of the field. | 266 '(rear-nonsticky t end-open t read-only from)) |
293 (add-text-properties (1- from) from (list 'rear-nonsticky t | 267 (add-text-properties to (1+ to) |
294 'end-open t | 268 '(front-sticky nil start-open t read-only to)) |
295 'invisible t)) | |
296 (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format)) | |
297 (widget-get widget :hide-front-space)) | |
298 ;; WARNING: This is going to lose horrible if the character just | |
299 ;; before the field can be modified (e.g. if it belongs to a | |
300 ;; choice widget). We try to compensate by checking the format | |
301 ;; string, and hope the user hasn't changed the :create method. | |
302 (widget-make-intangible (- from 2) from 'end-open)) | |
303 | |
304 ;; Make it possible to edit back end of the field. | |
305 (add-text-properties to (1+ to) (list 'front-sticky nil | |
306 'read-only t | |
307 'start-open t)) | |
308 | |
309 (cond ((widget-get widget :size) | |
310 (put-text-property to (1+ to) 'invisible t) | |
311 (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format)) | |
312 (widget-get widget :hide-rear-space)) | |
313 ;; WARNING: This is going to lose horrible if the character just | |
314 ;; after the field can be modified (e.g. if it belongs to a | |
315 ;; choice widget). We try to compensate by checking the format | |
316 ;; string, and hope the user hasn't changed the :create method. | |
317 (widget-make-intangible to (+ to 2) 'start-open))) | |
318 ((string-match "XEmacs" emacs-version) | |
319 ;; XEmacs does not allow you to insert before a read-only | |
320 ;; character, even if it is start.open. | |
321 ;; XEmacs does allow you to delete an read-only extent, so | |
322 ;; making the terminating newline read only doesn't help. | |
323 ;; I tried putting an invisible intangible read-only space | |
324 ;; before the newline, which gave really weird effects. | |
325 ;; So for now, we just have trust the user not to delete the | |
326 ;; newline. | |
327 (put-text-property to (1+ to) 'read-only nil)))) | |
328 | |
329 (defun widget-specify-field-update (widget from to) | |
330 ;; Specify editable button for WIDGET between FROM and TO. | |
331 (let ((map (widget-get widget :keymap)) | 269 (let ((map (widget-get widget :keymap)) |
332 (secret (widget-get widget :secret)) | 270 (face (or (widget-get widget :value-face) 'widget-field-face)) |
333 (secret-to to) | 271 (help-echo (widget-get widget :help-echo)) |
334 (size (widget-get widget :size)) | 272 (overlay (make-overlay from to nil nil t))) |
335 (face (or (widget-get widget :value-face) | |
336 'widget-field-face)) | |
337 (help-echo (widget-get widget :help-echo))) | |
338 (unless (or (stringp help-echo) (null help-echo)) | 273 (unless (or (stringp help-echo) (null help-echo)) |
339 (setq help-echo 'widget-mouse-help)) | 274 (setq help-echo 'widget-mouse-help)) |
340 | 275 (widget-put widget :field-overlay overlay) |
341 (when secret | 276 (overlay-put overlay 'detachable nil) |
342 (while (and size | 277 (overlay-put overlay 'field widget) |
343 (not (zerop size)) | 278 (overlay-put overlay 'local-map map) |
344 (> secret-to from) | 279 (overlay-put overlay 'keymap map) |
345 (eq (char-after (1- secret-to)) ?\ )) | 280 (overlay-put overlay 'face face) |
346 (setq secret-to (1- secret-to))) | 281 (overlay-put overlay 'balloon-help help-echo) |
347 | 282 (overlay-put overlay 'help-echo help-echo))) |
348 (save-excursion | 283 |
349 (goto-char from) | |
350 (while (< (point) secret-to) | |
351 (let ((old (get-text-property (point) 'secret))) | |
352 (when old | |
353 (subst-char-in-region (point) (1+ (point)) secret old))) | |
354 (forward-char)))) | |
355 | |
356 (set-text-properties from to (list 'field widget | |
357 'read-only nil | |
358 'keymap map | |
359 'local-map map | |
360 'balloon-help help-echo | |
361 'help-echo help-echo | |
362 'face face)) | |
363 | |
364 (when secret | |
365 (save-excursion | |
366 (goto-char from) | |
367 (while (< (point) secret-to) | |
368 (let ((old (following-char))) | |
369 (subst-char-in-region (point) (1+ (point)) old secret) | |
370 (put-text-property (point) (1+ (point)) 'secret old)) | |
371 (forward-char)))) | |
372 | |
373 (unless (widget-get widget :size) | |
374 (add-text-properties to (1+ to) (list 'field widget | |
375 'balloon-help help-echo | |
376 'help-echo help-echo | |
377 'face face))) | |
378 (add-text-properties to (1+ to) (list 'local-map map | |
379 'keymap map)))) | |
380 (defun widget-specify-button (widget from to) | 284 (defun widget-specify-button (widget from to) |
381 ;; Specify button for WIDGET between FROM and TO. | 285 "Specify button for WIDGET between FROM and TO." |
382 (let ((face (widget-apply widget :button-face-get)) | 286 (let ((face (widget-apply widget :button-face-get)) |
383 (help-echo (widget-get widget :help-echo))) | 287 (help-echo (widget-get widget :help-echo)) |
288 (overlay (make-overlay from to nil t nil))) | |
289 (widget-put widget :button-overlay overlay) | |
384 (unless (or (null help-echo) (stringp help-echo)) | 290 (unless (or (null help-echo) (stringp help-echo)) |
385 (setq help-echo 'widget-mouse-help)) | 291 (setq help-echo 'widget-mouse-help)) |
386 (add-text-properties from to (list 'button widget | 292 (overlay-put overlay 'button widget) |
387 'mouse-face widget-mouse-face | 293 (overlay-put overlay 'mouse-face widget-mouse-face) |
388 'start-open t | 294 (overlay-put overlay 'balloon-help help-echo) |
389 'end-open t | 295 (overlay-put overlay 'help-echo help-echo) |
390 'balloon-help help-echo | 296 (overlay-put overlay 'face face))) |
391 'help-echo help-echo | |
392 'face face)))) | |
393 | 297 |
394 (defun widget-mouse-help (extent) | 298 (defun widget-mouse-help (extent) |
395 "Find mouse help string for button in extent." | 299 "Find mouse help string for button in extent." |
396 (let* ((widget (widget-at (extent-start-position extent))) | 300 (let* ((widget (widget-at (extent-start-position extent))) |
397 (help-echo (and widget (widget-get widget :help-echo)))) | 301 (help-echo (and widget (widget-get widget :help-echo)))) |
530 (cons (list (car vals)) (cdr vals))) | 434 (cons (list (car vals)) (cdr vals))) |
531 (t nil))) | 435 (t nil))) |
532 | 436 |
533 (defun widget-apply-action (widget &optional event) | 437 (defun widget-apply-action (widget &optional event) |
534 "Apply :action in WIDGET in response to EVENT." | 438 "Apply :action in WIDGET in response to EVENT." |
535 (if (widget-apply widget :active) | 439 (let (after-change-functions) |
536 (widget-apply widget :action event) | 440 (if (widget-apply widget :active) |
537 (error "Attempt to perform action on inactive widget"))) | 441 (widget-apply widget :action event) |
442 (error "Attempt to perform action on inactive widget")))) | |
538 | 443 |
539 ;;; Helper functions. | 444 ;;; Helper functions. |
540 ;; | 445 ;; |
541 ;; These are widget specific. | 446 ;; These are widget specific. |
542 | 447 |
855 (set-keymap-parent widget-text-keymap global-map)) | 760 (set-keymap-parent widget-text-keymap global-map)) |
856 | 761 |
857 (defun widget-field-activate (pos &optional event) | 762 (defun widget-field-activate (pos &optional event) |
858 "Invoke the ediable field at point." | 763 "Invoke the ediable field at point." |
859 (interactive "@d") | 764 (interactive "@d") |
860 (let ((field (get-text-property pos 'field))) | 765 (let ((field (get-char-property pos 'field))) |
861 (if field | 766 (if field |
862 (widget-apply-action field event) | 767 (widget-apply-action field event) |
863 (call-interactively | 768 (call-interactively |
864 (lookup-key widget-global-map (this-command-keys)))))) | 769 (lookup-key widget-global-map (this-command-keys)))))) |
865 | 770 |
877 (cond ((and (fboundp 'event-glyph) | 782 (cond ((and (fboundp 'event-glyph) |
878 (event-glyph event)) | 783 (event-glyph event)) |
879 (widget-glyph-click event)) | 784 (widget-glyph-click event)) |
880 ((widget-event-point event) | 785 ((widget-event-point event) |
881 (let* ((pos (widget-event-point event)) | 786 (let* ((pos (widget-event-point event)) |
882 (button (get-text-property pos 'button))) | 787 (button (get-char-property pos 'button))) |
883 (if button | 788 (if button |
884 (let ((begin (previous-single-property-change (1+ pos) 'button)) | 789 (let* ((overlay (widget-get button :button-overlay)) |
885 (end (next-single-property-change pos 'button)) | 790 (face (overlay-get overlay 'face)) |
886 overlay) | 791 (mouse-face (overlay-get overlay 'face))) |
887 (unwind-protect | 792 (unwind-protect |
888 (let ((track-mouse t)) | 793 (let ((track-mouse t)) |
889 (setq overlay (make-overlay begin end)) | 794 (overlay-put overlay |
890 (overlay-put overlay 'face 'widget-button-pressed-face) | 795 'face 'widget-button-pressed-face) |
891 (overlay-put overlay | 796 (overlay-put overlay |
892 'mouse-face 'widget-button-pressed-face) | 797 'mouse-face 'widget-button-pressed-face) |
893 (unless (widget-apply button :mouse-down-action event) | 798 (unless (widget-apply button :mouse-down-action event) |
894 (while (not (button-release-event-p event)) | 799 (while (not (button-release-event-p event)) |
895 (setq event (if (fboundp 'read-event) | 800 (setq event (if (fboundp 'read-event) |
896 (read-event) | 801 (read-event) |
897 (next-event)) | 802 (next-event)) |
898 pos (widget-event-point event)) | 803 pos (widget-event-point event)) |
899 (if (and pos | 804 (if (and pos |
900 (eq (get-text-property pos 'button) | 805 (eq (get-char-property pos 'button) |
901 button)) | 806 button)) |
902 (progn | 807 (progn |
903 (overlay-put overlay | 808 (overlay-put overlay |
904 'face | 809 'face |
905 'widget-button-pressed-face) | 810 'widget-button-pressed-face) |
906 (overlay-put overlay | 811 (overlay-put overlay |
907 'mouse-face | 812 'mouse-face |
908 'widget-button-pressed-face)) | 813 'widget-button-pressed-face)) |
909 (overlay-put overlay 'face nil) | 814 (overlay-put overlay 'face face) |
910 (overlay-put overlay 'mouse-face nil)))) | 815 (overlay-put overlay 'mouse-face mouse-face)))) |
911 | |
912 (when (and pos | 816 (when (and pos |
913 (eq (get-text-property pos 'button) button)) | 817 (eq (get-char-property pos 'button) button)) |
914 (widget-apply-action button event))) | 818 (widget-apply-action button event))) |
915 (delete-overlay overlay))) | 819 (overlay-put overlay 'face face) |
820 (overlay-put overlay 'mouse-face mouse-face))) | |
916 (call-interactively | 821 (call-interactively |
917 (or (lookup-key widget-global-map [ button2 ]) | 822 (or (lookup-key widget-global-map [ button2 ]) |
918 (lookup-key widget-global-map [ down-mouse-2 ]) | 823 (lookup-key widget-global-map [ down-mouse-2 ]) |
919 (lookup-key widget-global-map [ mouse-2])))))) | 824 (lookup-key widget-global-map [ mouse-2])))))) |
920 (t | 825 (t |
956 (widget-apply-action widget event))))))) | 861 (widget-apply-action widget event))))))) |
957 | 862 |
958 (defun widget-button-press (pos &optional event) | 863 (defun widget-button-press (pos &optional event) |
959 "Invoke button at POS." | 864 "Invoke button at POS." |
960 (interactive "@d") | 865 (interactive "@d") |
961 (let ((button (get-text-property pos 'button))) | 866 (let ((button (get-char-property pos 'button))) |
962 (if button | 867 (if button |
963 (widget-apply-action button event) | 868 (widget-apply-action button event) |
964 (let ((command (lookup-key widget-global-map (this-command-keys)))) | 869 (let ((command (lookup-key widget-global-map (this-command-keys)))) |
965 (when (commandp command) | 870 (when (commandp command) |
966 (call-interactively command)))))) | 871 (call-interactively command)))))) |
967 | 872 |
968 (defun widget-move (arg) | 873 (defun widget-move (arg) |
969 "Move point to the ARG next field or button. | 874 "Move point to the ARG next field or button. |
970 ARG may be negative to move backward." | 875 ARG may be negative to move backward." |
971 (while (> arg 0) | 876 (or (bobp) (> arg 0) (backward-char)) |
972 (setq arg (1- arg)) | 877 (let ((pos) |
973 (let ((next (cond ((get-text-property (point) 'button) | 878 (number arg) |
974 (next-single-property-change (point) 'button)) | 879 (old (or (get-char-property (point) 'button) |
975 ((get-text-property (point) 'field) | 880 (get-char-property (point) 'field))) |
976 (next-single-property-change (point) 'field)) | 881 new) |
977 (t | 882 ;; Forward. |
978 (point))))) | 883 (while (> arg 0) |
979 (if (null next) ; Widget extends to end. of buffer | 884 (if (eobp) |
980 (setq next (point-min))) | 885 (goto-char (point-min)) |
981 (let ((button (next-single-property-change next 'button)) | |
982 (field (next-single-property-change next 'field))) | |
983 (cond ((or (get-text-property next 'button) | |
984 (get-text-property next 'field)) | |
985 (goto-char next)) | |
986 ((and button field) | |
987 (goto-char (min button field))) | |
988 (button (goto-char button)) | |
989 (field (goto-char field)) | |
990 (t | |
991 (let ((button (next-single-property-change (point-min) 'button)) | |
992 (field (next-single-property-change (point-min) 'field))) | |
993 (cond ((and button field) (goto-char (min button field))) | |
994 (button (goto-char button)) | |
995 (field (goto-char field)) | |
996 (t | |
997 (error "No buttons or fields found")))))) | |
998 (setq button (widget-at (point))) | |
999 (if (or (and button (widget-get button :tab-order) | |
1000 (< (widget-get button :tab-order) 0)) | |
1001 (and button (not (widget-apply button :active)))) | |
1002 (setq arg (1+ arg)))))) | |
1003 (while (< arg 0) | |
1004 (if (= (point-min) (point)) | |
1005 (forward-char 1)) | 886 (forward-char 1)) |
1006 (setq arg (1+ arg)) | 887 (and (eq pos (point)) |
1007 (let ((previous (cond ((get-text-property (1- (point)) 'button) | 888 (eq arg number) |
1008 (previous-single-property-change (point) 'button)) | 889 (error "No buttons or fields found")) |
1009 ((get-text-property (1- (point)) 'field) | 890 (let ((new (or (get-char-property (point) 'button) |
1010 (previous-single-property-change (point) 'field)) | 891 (get-char-property (point) 'field)))) |
1011 (t | 892 (when new |
1012 (point))))) | 893 (unless (eq new old) |
1013 (if (null previous) ; Widget extends to beg. of buffer | 894 (unless (and (widget-get new :tab-order) |
1014 (setq previous (point-max))) | 895 (< (widget-get new :tab-order) 0)) |
1015 (let ((button (previous-single-property-change previous 'button)) | 896 (setq arg (1- arg))) |
1016 (field (previous-single-property-change previous 'field))) | 897 (setq old new))))) |
1017 (cond ((and button field) | 898 ;; Backward. |
1018 (goto-char (max button field))) | 899 (while (< arg 0) |
1019 (button (goto-char button)) | 900 (if (bobp) |
1020 (field (goto-char field)) | 901 (goto-char (point-max)) |
1021 (t | 902 (backward-char 1)) |
1022 (let ((button (previous-single-property-change | 903 (and (eq pos (point)) |
1023 (point-max) 'button)) | 904 (eq arg number) |
1024 (field (previous-single-property-change | 905 (error "No buttons or fields found")) |
1025 (point-max) 'field))) | 906 (let ((new (or (get-char-property (point) 'button) |
1026 (cond ((and button field) (goto-char (max button field))) | 907 (get-char-property (point) 'field)))) |
1027 (button (goto-char button)) | 908 (when new |
1028 (field (goto-char field)) | 909 (unless (eq new old) |
1029 (t | 910 (unless (and (widget-get new :tab-order) |
1030 (error "No buttons or fields found")))))))) | 911 (< (widget-get new :tab-order) 0)) |
1031 (let ((button (previous-single-property-change (point) 'button)) | 912 (setq arg (1+ arg))))))) |
1032 (field (previous-single-property-change (point) 'field))) | 913 (while (or (get-char-property (point) 'button) |
1033 (cond ((and button field) | 914 (get-char-property (point) 'field)) |
1034 (goto-char (max button field))) | 915 (backward-char)) |
1035 (button (goto-char button)) | 916 (forward-char))) |
1036 (field (goto-char field))) | |
1037 (setq button (widget-at (point))) | |
1038 (if (or (and button (widget-get button :tab-order) | |
1039 (< (widget-get button :tab-order) 0)) | |
1040 (and button (not (widget-apply button :active)))) | |
1041 (setq arg (1- arg))))) | |
1042 (widget-echo-help (point)) | |
1043 (run-hooks 'widget-move-hook)) | |
1044 | 917 |
1045 (defun widget-forward (arg) | 918 (defun widget-forward (arg) |
1046 "Move point to the next field or button. | 919 "Move point to the next field or button. |
1047 With optional ARG, move across that many fields." | 920 With optional ARG, move across that many fields." |
1048 (interactive "p") | 921 (interactive "p") |
1071 (goto-char (min bol (or prev bol))))) | 944 (goto-char (min bol (or prev bol))))) |
1072 | 945 |
1073 (defun widget-kill-line () | 946 (defun widget-kill-line () |
1074 "Kill to end of field or end of line, whichever is first." | 947 "Kill to end of field or end of line, whichever is first." |
1075 (interactive) | 948 (interactive) |
1076 (let ((field (get-text-property (point) 'field)) | 949 (let ((field (get-char-property (point) 'field)) |
1077 (newline (save-excursion (forward-line 1))) | 950 (newline (save-excursion (forward-line 1))) |
1078 (next (next-single-property-change (point) 'field))) | 951 (next (next-single-property-change (point) 'field))) |
1079 (if (and field (> newline next)) | 952 (if (and field (> newline next)) |
1080 (kill-region (point) next) | 953 (kill-region (point) next) |
1081 (call-interactively 'kill-line)))) | 954 (call-interactively 'kill-line)))) |
1097 field) | 970 field) |
1098 (while widget-field-new | 971 (while widget-field-new |
1099 (setq field (car widget-field-new) | 972 (setq field (car widget-field-new) |
1100 widget-field-new (cdr widget-field-new) | 973 widget-field-new (cdr widget-field-new) |
1101 widget-field-list (cons field widget-field-list)) | 974 widget-field-list (cons field widget-field-list)) |
1102 (let ((from (widget-get field :value-from)) | 975 (let ((from (car (widget-get field :field-overlay))) |
1103 (to (widget-get field :value-to))) | 976 (to (cdr (widget-get field :field-overlay)))) |
1104 (widget-specify-field field from to) | 977 (widget-specify-field field from to) |
1105 (move-marker from (1- from)) | 978 (set-marker from nil) |
1106 (move-marker to (1+ to))))) | 979 (set-marker to nil)))) |
1107 (widget-clear-undo) | 980 (widget-clear-undo) |
1108 ;; We need to maintain text properties and size of the editing fields. | 981 ;; We need to maintain text properties and size of the editing fields. |
1109 (make-local-variable 'after-change-functions) | 982 (make-local-variable 'after-change-functions) |
1110 (if widget-field-list | 983 (if (and widget-field-list) |
1111 (setq after-change-functions '(widget-after-change)) | 984 (setq after-change-functions '(widget-after-change)) |
1112 (setq after-change-functions nil))) | 985 (setq after-change-functions nil))) |
1113 | 986 |
1114 (defvar widget-field-last nil) | 987 (defvar widget-field-last nil) |
1115 ;; Last field containing point. | 988 ;; Last field containing point. |
1117 | 990 |
1118 (defvar widget-field-was nil) | 991 (defvar widget-field-was nil) |
1119 ;; The widget data before the change. | 992 ;; The widget data before the change. |
1120 (make-variable-buffer-local 'widget-field-was) | 993 (make-variable-buffer-local 'widget-field-was) |
1121 | 994 |
995 (defun widget-field-buffer (widget) | |
996 "Return the start of WIDGET's editing field." | |
997 (overlay-buffer (widget-get widget :field-overlay))) | |
998 | |
999 (defun widget-field-start (widget) | |
1000 "Return the start of WIDGET's editing field." | |
1001 (overlay-start (widget-get widget :field-overlay))) | |
1002 | |
1003 (defun widget-field-end (widget) | |
1004 "Return the end of WIDGET's editing field." | |
1005 (overlay-end (widget-get widget :field-overlay))) | |
1006 | |
1122 (defun widget-field-find (pos) | 1007 (defun widget-field-find (pos) |
1123 ;; Find widget whose editing field is located at POS. | 1008 "Return the field at POS. |
1124 ;; Return nil if POS is not inside and editing field. | 1009 Unlike (get-char-property POS 'field) this, works with empty fields too." |
1125 ;; | |
1126 ;; This is only used in `widget-field-modified', since ordinarily | |
1127 ;; you would just test the field property. | |
1128 (let ((fields widget-field-list) | 1010 (let ((fields widget-field-list) |
1129 field found) | 1011 field found) |
1130 (while fields | 1012 (while fields |
1131 (setq field (car fields) | 1013 (setq field (car fields) |
1132 fields (cdr fields)) | 1014 fields (cdr fields)) |
1133 (let ((from (widget-get field :value-from)) | 1015 (let ((start (widget-field-start field)) |
1134 (to (widget-get field :value-to))) | 1016 (end (widget-field-end field))) |
1135 (if (and from to (< from pos) (> to pos)) | 1017 (when (and (<= start pos) (<= pos end)) |
1136 (setq fields nil | 1018 (when found |
1137 found field)))) | 1019 (debug "Overlapping fields")) |
1020 (setq found field)))) | |
1138 found)) | 1021 found)) |
1139 | 1022 |
1140 (defun widget-after-change (from to old) | 1023 (defun widget-after-change (from to old) |
1141 ;; Adjust field size and text properties. | 1024 ;; Adjust field size and text properties. |
1142 (condition-case nil | 1025 (condition-case nil |
1143 (let ((field (widget-field-find from)) | 1026 (let ((field (widget-field-find from)) |
1144 (inhibit-read-only t)) | 1027 (other (widget-field-find to))) |
1145 (cond ((null field)) | 1028 (when field |
1146 ((not (eq field (widget-field-find to))) | 1029 (unless (eq field other) |
1147 (debug) | 1030 (debug "Change in different fields")) |
1148 (message "Error: `widget-after-change' called on two fields")) | 1031 (let ((size (widget-get field :size))) |
1149 (t | 1032 (when size |
1150 (let ((size (widget-get field :size))) | 1033 (let ((begin (widget-field-start field)) |
1151 (if size | 1034 (end (widget-field-end field))) |
1152 (let ((begin (1+ (widget-get field :value-from))) | 1035 (cond ((< (- end begin) size) |
1153 (end (1- (widget-get field :value-to)))) | 1036 ;; Field too small. |
1154 (widget-specify-field-update field begin end) | 1037 (save-excursion |
1155 (cond ((< (- end begin) size) | 1038 (goto-char end) |
1156 ;; Field too small. | 1039 (insert-char ?\ (- (+ begin size) end)))) |
1157 (save-excursion | 1040 ((> (- end begin) size) |
1158 (goto-char end) | 1041 ;; Field too large and |
1159 (insert-char ?\ (- (+ begin size) end)) | 1042 (if (or (< (point) (+ begin size)) |
1160 (widget-specify-field-update field | 1043 (> (point) end)) |
1161 begin | 1044 ;; Point is outside extra space. |
1162 (+ begin size)))) | 1045 (setq begin (+ begin size)) |
1163 ((> (- end begin) size) | 1046 ;; Point is within the extra space. |
1164 ;; Field too large and | 1047 (setq begin (point))) |
1165 (if (or (< (point) (+ begin size)) | 1048 (save-excursion |
1166 (> (point) end)) | 1049 (goto-char end) |
1167 ;; Point is outside extra space. | 1050 (while (and (eq (preceding-char) ?\ ) |
1168 (setq begin (+ begin size)) | 1051 (> (point) begin)) |
1169 ;; Point is within the extra space. | 1052 (delete-backward-char 1)))))))) |
1170 (setq begin (point))) | 1053 (widget-apply field :notify field))) |
1171 (save-excursion | 1054 (error (debug "After Change")))) |
1172 (goto-char end) | |
1173 (while (and (eq (preceding-char) ?\ ) | |
1174 (> (point) begin)) | |
1175 (delete-backward-char 1)))))) | |
1176 (widget-specify-field-update field from to))) | |
1177 (widget-apply field :notify field)))) | |
1178 (error (debug)))) | |
1179 | 1055 |
1180 ;;; Widget Functions | 1056 ;;; Widget Functions |
1181 ;; | 1057 ;; |
1182 ;; These functions are used in the definition of multiple widgets. | 1058 ;; These functions are used in the definition of multiple widgets. |
1183 | 1059 |
1368 ;; Remove widget from the buffer. | 1244 ;; Remove widget from the buffer. |
1369 (let ((from (widget-get widget :from)) | 1245 (let ((from (widget-get widget :from)) |
1370 (to (widget-get widget :to)) | 1246 (to (widget-get widget :to)) |
1371 (inactive-overlay (widget-get widget :inactive)) | 1247 (inactive-overlay (widget-get widget :inactive)) |
1372 (button-overlay (widget-get widget :button-overlay)) | 1248 (button-overlay (widget-get widget :button-overlay)) |
1373 (inhibit-read-only t) | 1249 after-change-functions |
1374 after-change-functions) | 1250 (inhibit-read-only t)) |
1375 (widget-apply widget :value-delete) | 1251 (widget-apply widget :value-delete) |
1376 (when inactive-overlay | 1252 (when inactive-overlay |
1377 (delete-overlay inactive-overlay)) | 1253 (delete-overlay inactive-overlay)) |
1378 (when button-overlay | 1254 (when button-overlay |
1379 (delete-overlay button-overlay)) | 1255 (delete-overlay button-overlay)) |
1467 (cons head (widget-sublist values (length value)))))))) | 1343 (cons head (widget-sublist values (length value)))))))) |
1468 | 1344 |
1469 (defun widget-sublist (list start &optional end) | 1345 (defun widget-sublist (list start &optional end) |
1470 "Return the sublist of LIST from START to END. | 1346 "Return the sublist of LIST from START to END. |
1471 If END is omitted, it defaults to the length of LIST." | 1347 If END is omitted, it defaults to the length of LIST." |
1472 (let (len) | 1348 (if (> start 0) (setq list (nthcdr start list))) |
1473 (if (> start 0) (setq list (nthcdr start list))) | 1349 (if end |
1474 (if end | 1350 (if (<= end start) |
1475 (if (<= end start) | 1351 nil |
1476 nil | 1352 (setq list (copy-sequence list)) |
1477 (setq list (copy-sequence list)) | 1353 (setcdr (nthcdr (- end start 1) list) nil) |
1478 (setcdr (nthcdr (- end start 1) list) nil) | 1354 list) |
1479 list) | 1355 (copy-sequence list))) |
1480 (copy-sequence list)))) | |
1481 | 1356 |
1482 (defun widget-item-action (widget &optional event) | 1357 (defun widget-item-action (widget &optional event) |
1483 ;; Just notify itself. | 1358 ;; Just notify itself. |
1484 (widget-apply widget :notify widget event)) | 1359 (widget-apply widget :notify widget event)) |
1485 | 1360 |
1629 (let ((prompt (concat (widget-apply widget :menu-tag-get) ": ")) | 1504 (let ((prompt (concat (widget-apply widget :menu-tag-get) ": ")) |
1630 (value (unless invalid | 1505 (value (unless invalid |
1631 (widget-value widget)))) | 1506 (widget-value widget)))) |
1632 (let ((answer (widget-apply widget :prompt-value prompt value invalid) )) | 1507 (let ((answer (widget-apply widget :prompt-value prompt value invalid) )) |
1633 (widget-value-set widget answer))) | 1508 (widget-value-set widget answer))) |
1634 (widget-apply widget :notify widget event) | 1509 (widget-setup) |
1635 (widget-setup))) | 1510 (widget-apply widget :notify widget event))) |
1636 | 1511 |
1637 (defun widget-field-validate (widget) | 1512 (defun widget-field-validate (widget) |
1638 ;; Valid if the content matches `:valid-regexp'. | 1513 ;; Valid if the content matches `:valid-regexp'. |
1639 (save-excursion | 1514 (save-excursion |
1640 (let ((value (widget-apply widget :value-get)) | 1515 (let ((value (widget-apply widget :value-get)) |
1643 nil | 1518 nil |
1644 widget)))) | 1519 widget)))) |
1645 | 1520 |
1646 (defun widget-field-value-create (widget) | 1521 (defun widget-field-value-create (widget) |
1647 ;; Create an editable text field. | 1522 ;; Create an editable text field. |
1648 (insert " ") | |
1649 (let ((size (widget-get widget :size)) | 1523 (let ((size (widget-get widget :size)) |
1650 (value (widget-get widget :value)) | 1524 (value (widget-get widget :value)) |
1651 (from (point))) | 1525 (from (point)) |
1526 (overlay (cons (make-marker) (make-marker)))) | |
1527 (widget-put widget :field-overlay overlay) | |
1652 (insert value) | 1528 (insert value) |
1653 (and size | 1529 (and size |
1654 (< (length value) size) | 1530 (< (length value) size) |
1655 (insert-char ?\ (- size (length value)))) | 1531 (insert-char ?\ (- size (length value)))) |
1656 (unless (memq widget widget-field-list) | 1532 (unless (memq widget widget-field-list) |
1657 (setq widget-field-new (cons widget widget-field-new))) | 1533 (setq widget-field-new (cons widget widget-field-new))) |
1658 (widget-put widget :value-to (copy-marker (point))) | 1534 (move-marker (cdr overlay) (point)) |
1659 (set-marker-insertion-type (widget-get widget :value-to) nil) | 1535 (set-marker-insertion-type (cdr overlay) nil) |
1660 (if (null size) | 1536 (when (null size) |
1661 (insert ?\n) | 1537 (insert ?\n)) |
1662 (insert ?\ )) | 1538 (move-marker (car overlay) from) |
1663 (widget-put widget :value-from (copy-marker from)) | 1539 (set-marker-insertion-type (car overlay) t))) |
1664 (set-marker-insertion-type (widget-get widget :value-from) t))) | |
1665 | 1540 |
1666 (defun widget-field-value-delete (widget) | 1541 (defun widget-field-value-delete (widget) |
1667 ;; Remove the widget from the list of active editing fields. | 1542 ;; Remove the widget from the list of active editing fields. |
1668 (setq widget-field-list (delq widget widget-field-list)) | 1543 (setq widget-field-list (delq widget widget-field-list)) |
1669 ;; These are nil if the :format string doesn't contain `%v'. | 1544 ;; These are nil if the :format string doesn't contain `%v'. |
1670 (when (widget-get widget :value-from) | 1545 (let ((overlay (widget-get widget :field-overlay))) |
1671 (set-marker (widget-get widget :value-from) nil)) | 1546 (when overlay |
1672 (when (widget-get widget :value-from) | 1547 (delete-overlay overlay)))) |
1673 (set-marker (widget-get widget :value-to) nil)) | |
1674 (when (widget-get widget :field-overlay) | |
1675 (delete-overlay (widget-get widget :field-overlay)))) | |
1676 | 1548 |
1677 (defun widget-field-value-get (widget) | 1549 (defun widget-field-value-get (widget) |
1678 ;; Return current text in editing field. | 1550 ;; Return current text in editing field. |
1679 (let ((from (widget-get widget :value-from)) | 1551 (let ((from (widget-field-start widget)) |
1680 (to (widget-get widget :value-to)) | 1552 (to (widget-field-end widget)) |
1553 (buffer (widget-field-buffer widget)) | |
1681 (size (widget-get widget :size)) | 1554 (size (widget-get widget :size)) |
1682 (secret (widget-get widget :secret)) | 1555 (secret (widget-get widget :secret)) |
1683 (old (current-buffer))) | 1556 (old (current-buffer))) |
1684 (if (and from to) | 1557 (if (and from to) |
1685 (progn | 1558 (progn |
1686 (set-buffer (marker-buffer from)) | 1559 (set-buffer buffer) |
1687 (setq from (1+ from) | |
1688 to (1- to)) | |
1689 (while (and size | 1560 (while (and size |
1690 (not (zerop size)) | 1561 (not (zerop size)) |
1691 (> to from) | 1562 (> to from) |
1692 (eq (char-after (1- to)) ?\ )) | 1563 (eq (char-after (1- to)) ?\ )) |
1693 (setq to (1- to))) | 1564 (setq to (1- to))) |
1694 (let ((result (buffer-substring-no-properties from to))) | 1565 (let ((result (buffer-substring-no-properties from to))) |
1695 (when secret | 1566 (when secret |
1696 (let ((index 0)) | 1567 (let ((index 0)) |
1697 (while (< (+ from index) to) | 1568 (while (< (+ from index) to) |
1698 (aset result index | 1569 (aset result index |
1699 (get-text-property (+ from index) 'secret)) | 1570 (get-char-property (+ from index) 'secret)) |
1700 (setq index (1+ index))))) | 1571 (setq index (1+ index))))) |
1701 (set-buffer old) | 1572 (set-buffer old) |
1702 result)) | 1573 result)) |
1703 (widget-get widget :value)))) | 1574 (widget-get widget :value)))) |
1704 | 1575 |
1828 (widget-choose tag (reverse choices) event)))) | 1699 (widget-choose tag (reverse choices) event)))) |
1829 (when current | 1700 (when current |
1830 (widget-value-set widget | 1701 (widget-value-set widget |
1831 (widget-apply current :value-to-external | 1702 (widget-apply current :value-to-external |
1832 (widget-get current :value))) | 1703 (widget-get current :value))) |
1833 (widget-apply widget :notify widget event) | 1704 (widget-setup) |
1834 (widget-setup)))) | 1705 (widget-apply widget :notify widget event)))) |
1835 | 1706 |
1836 (defun widget-choice-validate (widget) | 1707 (defun widget-choice-validate (widget) |
1837 ;; Valid if we have made a valid choice. | 1708 ;; Valid if we have made a valid choice. |
1838 (let ((void (widget-get widget :void)) | 1709 (let ((void (widget-get widget :void)) |
1839 (choice (widget-get widget :choice)) | 1710 (choice (widget-get widget :choice)) |
2378 (widget-put widget :children (cons child children)) | 2249 (widget-put widget :children (cons child children)) |
2379 (while (not (eq (car (cdr children)) before)) | 2250 (while (not (eq (car (cdr children)) before)) |
2380 (setq children (cdr children))) | 2251 (setq children (cdr children))) |
2381 (setcdr children (cons child (cdr children))))))) | 2252 (setcdr children (cons child (cdr children))))))) |
2382 (widget-setup) | 2253 (widget-setup) |
2383 widget (widget-apply widget :notify widget)) | 2254 (widget-apply widget :notify widget)) |
2384 | 2255 |
2385 (defun widget-editable-list-delete-at (widget child) | 2256 (defun widget-editable-list-delete-at (widget child) |
2386 ;; Delete child from list of children. | 2257 ;; Delete child from list of children. |
2387 (save-excursion | 2258 (save-excursion |
2388 (let ((buttons (copy-sequence (widget-get widget :buttons))) | 2259 (let ((buttons (copy-sequence (widget-get widget :buttons))) |
2665 (menu-tag (widget-apply widget :menu-tag-get)) | 2536 (menu-tag (widget-apply widget :menu-tag-get)) |
2666 (must-match (widget-get widget :must-match)) | 2537 (must-match (widget-get widget :must-match)) |
2667 (answer (read-file-name (concat menu-tag ": (default `" value "') ") | 2538 (answer (read-file-name (concat menu-tag ": (default `" value "') ") |
2668 dir nil must-match file))) | 2539 dir nil must-match file))) |
2669 (widget-value-set widget (abbreviate-file-name answer)) | 2540 (widget-value-set widget (abbreviate-file-name answer)) |
2670 (widget-apply widget :notify widget event) | 2541 (widget-setup) |
2671 (widget-setup))) | 2542 (widget-apply widget :notify widget event))) |
2672 | 2543 |
2673 (define-widget 'directory 'file | 2544 (define-widget 'directory 'file |
2674 "A directory widget. | 2545 "A directory widget. |
2675 It will read a directory name from the minibuffer when invoked." | 2546 It will read a directory name from the minibuffer when invoked." |
2676 :tag "Directory") | 2547 :tag "Directory") |
3011 nil nil nil 'widget-color-history)) | 2882 nil nil nil 'widget-color-history)) |
3012 (t | 2883 (t |
3013 (read-string prompt (widget-value widget)))))) | 2884 (read-string prompt (widget-value widget)))))) |
3014 (unless (zerop (length answer)) | 2885 (unless (zerop (length answer)) |
3015 (widget-value-set widget answer) | 2886 (widget-value-set widget answer) |
3016 (widget-apply widget :notify widget event) | 2887 (widget-setup) |
3017 (widget-setup)))) | 2888 (widget-apply widget :notify widget event)))) |
3018 | 2889 |
3019 ;;; The Help Echo | 2890 ;;; The Help Echo |
3020 | 2891 |
3021 (defun widget-echo-help-mouse () | 2892 (defun widget-echo-help-mouse () |
3022 "Display the help message for the widget under the mouse. | 2893 "Display the help message for the widget under the mouse. |
3050 (remove-hook 'post-command-hook 'widget-stop-mouse-tracking) | 2921 (remove-hook 'post-command-hook 'widget-stop-mouse-tracking) |
3051 (setq track-mouse nil)) | 2922 (setq track-mouse nil)) |
3052 | 2923 |
3053 (defun widget-at (pos) | 2924 (defun widget-at (pos) |
3054 "The button or field at POS." | 2925 "The button or field at POS." |
3055 (or (get-text-property pos 'button) | 2926 (or (get-char-property pos 'button) |
3056 (get-text-property pos 'field))) | 2927 (get-char-property pos 'field))) |
3057 | 2928 |
3058 (defun widget-echo-help (pos) | 2929 (defun widget-echo-help (pos) |
3059 "Display the help echo for widget at POS." | 2930 "Display the help echo for widget at POS." |
3060 (let* ((widget (widget-at pos)) | 2931 (let* ((widget (widget-at pos)) |
3061 (help-echo (and widget (widget-get widget :help-echo)))) | 2932 (help-echo (and widget (widget-get widget :help-echo)))) |