Mercurial > hg > xemacs-beta

comparison lisp/w3/widget-edit.el @ 82:6a378aca36af r20-0b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b91
author cvs
date Mon, 13 Aug 2007 09:07:36 +0200
parents 1ce6082ce73f
children 364816949b59
comparison
equal deleted inserted replaced
81:ebca3d831cea 82:6a378aca36af
2 ;; 2 ;;
3 ;; Copyright (C) 1996 Free Software Foundation, Inc. 3 ;; Copyright (C) 1996 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.13 7 ;; Version: 1.18
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
9 9
10 ;;; Commentary: 10 ;;; Commentary:
11 ;; 11 ;;
12 ;; See `widget.el'. 12 ;; See `widget.el'.
75 :link '(url-link :tag "Development Page" 75 :link '(url-link :tag "Development Page"
76 "http://www.dina.kvl.dk/~abraham/custom/") 76 "http://www.dina.kvl.dk/~abraham/custom/")
77 :prefix "widget-" 77 :prefix "widget-"
78 :group 'emacs) 78 :group 'emacs)
79 79
80 (defface widget-documentation-face '((t ())) 80 (defface widget-documentation-faces '((((class color)
81 (background dark))
82 (:foreground "lime green"))
83 (((class color)
84 (background light))
85 (:foreground "dark green"))
86 (t nil))
81 "Face used for documentation text." 87 "Face used for documentation text."
82 :group 'widgets) 88 :group 'widgets)
83 89
84 (defface widget-button-face '((t (:bold t))) 90 (defface widget-button-face '((t (:bold t)))
85 "Face used for widget buttons." 91 "Face used for widget buttons."
88 (defcustom widget-mouse-face 'highlight 94 (defcustom widget-mouse-face 'highlight
89 "Face used for widget buttons when the mouse is above them." 95 "Face used for widget buttons when the mouse is above them."
90 :type 'face 96 :type 'face
91 :group 'widgets) 97 :group 'widgets)
92 98
93 (defface widget-field-face '((((type x) 99 (defface widget-field-face '((((class grayscale color)
94 (class grayscale color)
95 (background light)) 100 (background light))
96 (:background "light gray")) 101 (:background "light gray"))
97 (((type x) 102 (((class grayscale color)
98 (class grayscale color)
99 (background dark)) 103 (background dark))
100 (:background "dark gray")) 104 (:background "dark gray"))
101 (t 105 (t
102 (:italic t))) 106 (:italic t)))
103 "Face used for editable fields." 107 "Face used for editable fields."
104 :group 'widgets) 108 :group 'widgets)
105 109
106 (defcustom widget-menu-max-size 40 110 (defcustom widget-menu-max-size 40
107 "Largest number of items allowed in a popup-menu. 111 "Largest number of items allowed in a popup-menu.
108 Larger menus are read through the minibuffer." 112 Larger menus are read through the minibuffer."
113 :group 'widgets
109 :type 'integer) 114 :type 'integer)
110 115
111 ;;; Utility functions. 116 ;;; Utility functions.
112 ;; 117 ;;
113 ;; These are not really widget specific. 118 ;; These are not really widget specific.
466 (if button 471 (if button
467 (widget-apply button :action event) 472 (widget-apply button :action event)
468 (call-interactively 473 (call-interactively
469 (lookup-key widget-global-map (this-command-keys)))))) 474 (lookup-key widget-global-map (this-command-keys))))))
470 475
471 (defun widget-forward (arg) 476 (defun widget-move (arg)
472 "Move point to the next field or button. 477 "Move point to the ARG next field or button.
473 With optional ARG, move across that many fields." 478 ARG may be negative to move backward."
474 (interactive "p")
475 (while (> arg 0) 479 (while (> arg 0)
476 (setq arg (1- arg)) 480 (setq arg (1- arg))
477 (let ((next (cond ((get-text-property (point) 'button) 481 (let ((next (cond ((get-text-property (point) 'button)
478 (next-single-property-change (point) 'button)) 482 (next-single-property-change (point) 'button))
479 ((get-text-property (point) 'field) 483 ((get-text-property (point) 'field)
531 (field (previous-single-property-change (point) 'field))) 535 (field (previous-single-property-change (point) 'field)))
532 (cond ((and button field) 536 (cond ((and button field)
533 (goto-char (max button field))) 537 (goto-char (max button field)))
534 (button (goto-char button)) 538 (button (goto-char button))
535 (field (goto-char field))))) 539 (field (goto-char field)))))
536 (widget-echo-help (point))) 540 (widget-echo-help (point))
541 (run-hooks 'widget-move-hook))
542
543 (defun widget-forward (arg)
544 "Move point to the next field or button.
545 With optional ARG, move across that many fields."
546 (interactive "p")
547 (run-hooks 'widget-forward-hook)
548 (widget-move arg))
537 549
538 (defun widget-backward (arg) 550 (defun widget-backward (arg)
539 "Move point to the previous field or button. 551 "Move point to the previous field or button.
540 With optional ARG, move across that many fields." 552 With optional ARG, move across that many fields."
541 (interactive "p") 553 (interactive "p")
542 (widget-forward (- arg))) 554 (run-hooks 'widget-backward-hook)
555 (widget-move (- arg)))
543 556
544 ;;; Setting up the buffer. 557 ;;; Setting up the buffer.
545 558
546 (defvar widget-field-new nil) 559 (defvar widget-field-new nil)
547 ;; List of all newly created editable fields in the buffer. 560 ;; List of all newly created editable fields in the buffer.
875 888
876 ;;; The `link' Widget. 889 ;;; The `link' Widget.
877 890
878 (define-widget 'link 'item 891 (define-widget 'link 'item
879 "An embedded link." 892 "An embedded link."
893 :help-echo "Push me to follow the link."
880 :format "%[_%t_%]") 894 :format "%[_%t_%]")
881 895
882 ;;; The `info-link' Widget. 896 ;;; The `info-link' Widget.
883 897
884 (define-widget 'info-link 'link 898 (define-widget 'info-link 'link
1833 (if (or (string-match "\n\\'" pp) 1847 (if (or (string-match "\n\\'" pp)
1834 (> (length pp) 40)) 1848 (> (length pp) 40))
1835 (concat "\n" pp) 1849 (concat "\n" pp)
1836 pp))) 1850 pp)))
1837 1851
1852 (if (not (fboundp 'error-message-string))
1853 (defun error-message-string (obj)
1854 "Convert an error value to an error message."
1855 (let ((buf (get-buffer-create " *error-message*")))
1856 (erase-buffer buf)
1857 (display-error obj buf)
1858 (buffer-string buf))))
1859
1838 (defun widget-sexp-validate (widget) 1860 (defun widget-sexp-validate (widget)
1839 ;; Valid if we can read the string and there is no junk left after it. 1861 ;; Valid if we can read the string and there is no junk left after it.
1840 (save-excursion 1862 (save-excursion
1841 (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) 1863 (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
1842 (erase-buffer) 1864 (erase-buffer)