Mercurial > emacs
comparison lisp/wid-edit.el @ 18451:8eb08560287b
Synched with 1.9936.
author | Per Abrahamsen <abraham@dina.kvl.dk> |
---|---|
date | Wed, 25 Jun 1997 15:30:27 +0000 |
parents | 947c1b6ea8de |
children | 35976f73432d |
comparison
equal
deleted
inserted
replaced
18450:327eba076416 | 18451:8eb08560287b |
---|---|
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.9929 | 7 ;; Version: 1.9936 |
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 |
333 If you don't add the space, it will become impossible to edit a zero | 333 If you don't add the space, it will become impossible to edit a zero |
334 size field." | 334 size field." |
335 :type 'boolean | 335 :type 'boolean |
336 :group 'widgets) | 336 :group 'widgets) |
337 | 337 |
338 (defcustom widget-field-use-before-change | |
339 (or (> emacs-minor-version 34) | |
340 (> emacs-major-version 20) | |
341 (string-match "XEmacs" emacs-version)) | |
342 "Non-nil means use `before-change-functions' to track editable fields. | |
343 This enables the use of undo, but doesn'f work on Emacs 19.34 and earlier. | |
344 Using before hooks also means that the :notify function can't know the | |
345 new value." | |
346 :type 'boolean | |
347 :group 'widgets) | |
348 | |
338 (defun widget-specify-field (widget from to) | 349 (defun widget-specify-field (widget from to) |
339 "Specify editable button for WIDGET between FROM and TO." | 350 "Specify editable button for WIDGET between FROM and TO." |
340 (put-text-property from to 'read-only nil) | 351 (put-text-property from to 'read-only nil) |
341 ;; Terminating space is not part of the field, but necessary in | 352 ;; Terminating space is not part of the field, but necessary in |
342 ;; order for local-map to work. Remove next sexp if local-map works | 353 ;; order for local-map to work. Remove next sexp if local-map works |
689 | 700 |
690 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) | 701 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) |
691 "In WIDGET, insert GLYPH. | 702 "In WIDGET, insert GLYPH. |
692 If optional arguments DOWN and INACTIVE are given, they should be | 703 If optional arguments DOWN and INACTIVE are given, they should be |
693 glyphs used when the widget is pushed and inactive, respectively." | 704 glyphs used when the widget is pushed and inactive, respectively." |
694 (set-glyph-property glyph 'widget widget) | 705 (when widget |
695 (when down | 706 (set-glyph-property glyph 'widget widget) |
696 (set-glyph-property down 'widget widget)) | 707 (when down |
697 (when inactive | 708 (set-glyph-property down 'widget widget)) |
698 (set-glyph-property inactive 'widget widget)) | 709 (when inactive |
710 (set-glyph-property inactive 'widget widget))) | |
699 (insert "*") | 711 (insert "*") |
700 (let ((ext (make-extent (point) (1- (point)))) | 712 (let ((ext (make-extent (point) (1- (point)))) |
701 (help-echo (widget-get widget :help-echo))) | 713 (help-echo (and widget (widget-get widget :help-echo)))) |
702 (set-extent-property ext 'invisible t) | 714 (set-extent-property ext 'invisible t) |
703 (set-extent-property ext 'start-open t) | 715 (set-extent-property ext 'start-open t) |
704 (set-extent-property ext 'end-open t) | 716 (set-extent-property ext 'end-open t) |
705 (set-extent-end-glyph ext glyph) | 717 (set-extent-end-glyph ext glyph) |
706 (when help-echo | 718 (when help-echo |
707 (set-extent-property ext 'balloon-help help-echo) | 719 (set-extent-property ext 'balloon-help help-echo) |
708 (set-extent-property ext 'help-echo help-echo))) | 720 (set-extent-property ext 'help-echo help-echo))) |
709 (widget-put widget :glyph-up glyph) | 721 (when widget |
710 (when down (widget-put widget :glyph-down down)) | 722 (widget-put widget :glyph-up glyph) |
711 (when inactive (widget-put widget :glyph-inactive inactive))) | 723 (when down (widget-put widget :glyph-down down)) |
724 (when inactive (widget-put widget :glyph-inactive inactive)))) | |
712 | 725 |
713 ;;; Buttons. | 726 ;;; Buttons. |
714 | 727 |
715 (defgroup widget-button nil | 728 (defgroup widget-button nil |
716 "The look of various kinds of buttons." | 729 "The look of various kinds of buttons." |
977 (when (and pos | 990 (when (and pos |
978 (eq (get-char-property pos 'button) button)) | 991 (eq (get-char-property pos 'button) button)) |
979 (widget-apply-action button event))) | 992 (widget-apply-action button event))) |
980 (overlay-put overlay 'face face) | 993 (overlay-put overlay 'face face) |
981 (overlay-put overlay 'mouse-face mouse-face))) | 994 (overlay-put overlay 'mouse-face mouse-face))) |
982 (let (command up) | 995 (let ((up t) |
996 command) | |
983 ;; Find the global command to run, and check whether it | 997 ;; Find the global command to run, and check whether it |
984 ;; is bound to an up event. | 998 ;; is bound to an up event. |
985 (cond ((setq command ;down event | 999 (cond ((setq command ;down event |
986 (lookup-key widget-global-map [ button2 ]))) | 1000 (lookup-key widget-global-map [ button2 ])) |
1001 (setq up nil)) | |
987 ((setq command ;down event | 1002 ((setq command ;down event |
988 (lookup-key widget-global-map [ down-mouse-2 ]))) | 1003 (lookup-key widget-global-map [ down-mouse-2 ])) |
1004 (setq up nil)) | |
989 ((setq command ;up event | 1005 ((setq command ;up event |
990 (lookup-key widget-global-map [ button2up ])) | 1006 (lookup-key widget-global-map [ button2up ]))) |
991 (setq up t)) | |
992 ((setq command ;up event | 1007 ((setq command ;up event |
993 (lookup-key widget-global-map [ mouse-2])) | 1008 (lookup-key widget-global-map [ mouse-2])))) |
994 (setq up t))) | 1009 (when up |
1010 ;; Don't execute up events twice. | |
1011 (while (not (button-release-event-p event)) | |
1012 (setq event (widget-read-event)))) | |
995 (when command | 1013 (when command |
996 ;; Don't execute up events twice. | |
997 (when up | |
998 (while (not (button-release-event-p event)) | |
999 (setq event (widget-read-event)))) | |
1000 (call-interactively command)))))) | 1014 (call-interactively command)))))) |
1001 (t | 1015 (t |
1002 (message "You clicked somewhere weird.")))) | 1016 (message "You clicked somewhere weird.")))) |
1003 | 1017 |
1004 (defun widget-button1-click (event) | 1018 (defun widget-button1-click (event) |
1186 (set-marker from nil) | 1200 (set-marker from nil) |
1187 (set-marker to nil)))) | 1201 (set-marker to nil)))) |
1188 (widget-clear-undo) | 1202 (widget-clear-undo) |
1189 ;; We need to maintain text properties and size of the editing fields. | 1203 ;; We need to maintain text properties and size of the editing fields. |
1190 (make-local-variable 'after-change-functions) | 1204 (make-local-variable 'after-change-functions) |
1191 (make-local-variable 'before-change-functions) | |
1192 (setq after-change-functions | 1205 (setq after-change-functions |
1193 (if widget-field-list '(widget-after-change) nil)) | 1206 (if widget-field-list '(widget-after-change) nil)) |
1194 (setq before-change-functions | 1207 (when widget-field-use-before-change |
1195 (if widget-field-list '(widget-before-change) nil))) | 1208 (make-local-variable 'before-change-functions) |
1209 (setq before-change-functions | |
1210 (if widget-field-list '(widget-before-change) nil)))) | |
1196 | 1211 |
1197 (defvar widget-field-last nil) | 1212 (defvar widget-field-last nil) |
1198 ;; Last field containing point. | 1213 ;; Last field containing point. |
1199 (make-variable-buffer-local 'widget-field-last) | 1214 (make-variable-buffer-local 'widget-field-last) |
1200 | 1215 |
1663 | 1678 |
1664 (defun widget-push-button-value-create (widget) | 1679 (defun widget-push-button-value-create (widget) |
1665 ;; Insert text representing the `on' and `off' states. | 1680 ;; Insert text representing the `on' and `off' states. |
1666 (let* ((tag (or (widget-get widget :tag) | 1681 (let* ((tag (or (widget-get widget :tag) |
1667 (widget-get widget :value))) | 1682 (widget-get widget :value))) |
1683 (tag-glyph (widget-get widget :tag-glyph)) | |
1668 (text (concat widget-push-button-prefix | 1684 (text (concat widget-push-button-prefix |
1669 tag widget-push-button-suffix)) | 1685 tag widget-push-button-suffix)) |
1670 (gui (cdr (assoc tag widget-push-button-cache)))) | 1686 (gui (cdr (assoc tag widget-push-button-cache)))) |
1671 (if (and (fboundp 'make-gui-button) | 1687 (cond (tag-glyph |
1688 (widget-glyph-insert widget text tag-glyph)) | |
1689 ((and (fboundp 'make-gui-button) | |
1672 (fboundp 'make-glyph) | 1690 (fboundp 'make-glyph) |
1673 widget-push-button-gui | 1691 widget-push-button-gui |
1674 (fboundp 'device-on-window-system-p) | 1692 (fboundp 'device-on-window-system-p) |
1675 (device-on-window-system-p) | 1693 (device-on-window-system-p) |
1676 (string-match "XEmacs" emacs-version)) | 1694 (string-match "XEmacs" emacs-version)) |
1677 (progn | 1695 (unless gui |
1678 (unless gui | 1696 (setq gui (make-gui-button tag 'widget-gui-action widget)) |
1679 (setq gui (make-gui-button tag 'widget-gui-action widget)) | 1697 (push (cons tag gui) widget-push-button-cache)) |
1680 (push (cons tag gui) widget-push-button-cache)) | 1698 (widget-glyph-insert-glyph widget |
1681 (widget-glyph-insert-glyph widget | 1699 (make-glyph |
1682 (make-glyph | 1700 (list (nth 0 (aref gui 1)) |
1683 (list (nth 0 (aref gui 1)) | 1701 (vector 'string ':data text))) |
1684 (vector 'string ':data text))) | 1702 (make-glyph |
1685 (make-glyph | 1703 (list (nth 1 (aref gui 1)) |
1686 (list (nth 1 (aref gui 1)) | 1704 (vector 'string ':data text))) |
1687 (vector 'string ':data text))) | 1705 (make-glyph |
1688 (make-glyph | 1706 (list (nth 2 (aref gui 1)) |
1689 (list (nth 2 (aref gui 1)) | 1707 (vector 'string ':data text))))) |
1690 (vector 'string ':data text))))) | 1708 (t |
1691 (insert text)))) | 1709 (insert text))))) |
1692 | 1710 |
1693 (defun widget-gui-action (widget) | 1711 (defun widget-gui-action (widget) |
1694 "Apply :action for WIDGET." | 1712 "Apply :action for WIDGET." |
1695 (widget-apply-action widget (this-command-keys))) | 1713 (widget-apply-action widget (this-command-keys))) |
1696 | 1714 |