xemacs-beta: lisp/w3/widget-edit.el comparison

comparison lisp/w3/widget-edit.el @ 16:0293115a14e9 r19-15b91

Import from CVS: tag r19-15b91

author	cvs
date	Mon, 13 Aug 2007 08:49:20 +0200
parents	9ee227acff29
children

comparison

equal deleted inserted replaced

-:ad457d5f7d04
+:0293115a14e9
 ;;
 ;; Copyright (C) 1996 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.13
+;; Version: 1.22
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;;; Commentary:
 ;;
 ;; See `widget.el'.
 (defvar widget-mouse-face 'highlight)
 (defvar widget-menu-max-size 40)))
 ;;; Compatibility.
-(or (fboundp 'event-point)
+(unless (fboundp 'event-point)
 ;; XEmacs function missing in Emacs.
 (defun event-point (event)
 "Return the character position of the given mouse-motion, button-press,
 or button-release event.  If the event did not occur over a window, or did
 not occur over text, then this returns nil.  Otherwise, it returns an index
 into the buffer visible in the event's window."
 (posn-point (event-start event))))
+(unless (fboundp 'error-message-string)
+;; Emacs function missing in XEmacs.
+(defun error-message-string (obj)
+"Convert an error value to an error message."
+(let ((buf (get-buffer-create " *error-message*")))
+(erase-buffer buf)
+(display-error obj buf)
+(buffer-string buf))))
 ;;; Customization.
 (defgroup widgets nil
 "Customization support for the Widget Library."
 :link '(url-link :tag "Development Page"
 		   "http://www.dina.kvl.dk/~abraham/custom/")
 :prefix "widget-"
 :group 'emacs)
-(defface widget-documentation-face '((t ()))
+(defface widget-documentation-face '((((class color)
+				       (background dark))
+				      (:foreground "lime green"))
+				     (((class color)
+				       (background light))
+				      (:foreground "dark green"))
+				     (t nil))
 "Face used for documentation text."
 :group 'widgets)
 (defface widget-button-face '((t (:bold t)))
 "Face used for widget buttons."
 (defcustom widget-mouse-face 'highlight
 "Face used for widget buttons when the mouse is above them."
 :type 'face
 :group 'widgets)
-(defface widget-field-face '((((type x)
+(defface widget-field-face '((((class grayscale color)
-			       (class grayscale color)
 			       (background light))
 			      (:background "light gray"))
-			     (((type x)
+			     (((class grayscale color)
-			       (class grayscale color)
 			       (background dark))
 			      (:background "dark gray"))
 			     (t
 			      (:italic t)))
 "Face used for editable fields."
 :group 'widgets)
 (defcustom widget-menu-max-size 40
 "Largest number of items allowed in a popup-menu.
 Larger menus are read through the minibuffer."
+:group 'widgets
 :type 'integer)
 ;;; Utility functions.
 ;;
 ;; These are not really widget specific.
 	 (put-text-property to (1+ to) 'read-only nil))))
 (defun widget-specify-field-update (widget from to)
 ;; Specify editable button for WIDGET between FROM and TO.
 (let ((map (widget-get widget :keymap))
+	(secret (widget-get widget :secret))
+	(secret-to to)
+	(size (widget-get widget :size))
 	(face (or (widget-get widget :value-face)
 		  'widget-field-face)))
+(when secret
+(while (and size
+		  (not (zerop size))
+		  (> secret-to from)
+		  (eq (char-after (1- secret-to)) ?\ ))
+	(setq secret-to (1- secret-to)))
+(save-excursion
+	(goto-char from)
+	(while (< (point) secret-to)
+	  (let ((old (get-text-property (point) 'secret)))
+	    (when old
+	      (subst-char-in-region (point) (1+ (point)) secret old)))
+	  (forward-char))))
 (set-text-properties from to (list 'field widget
 				       'read-only nil
 				       'keymap map
 				       'local-map map
 				       'face face))
+(when secret
+(save-excursion
+	(goto-char from)
+	(while (< (point) secret-to)
+	  (let ((old (following-char)))
+	    (subst-char-in-region (point) (1+ (point)) old secret)
+	    (put-text-property (point) (1+ (point)) 'secret old))
+	  (forward-char))))
 (unless (widget-get widget :size)
-(put-text-property to (1+ to) 'face face))))
+(add-text-properties to (1+ to) (list 'field widget
+					    'face face
+					    'local-map map
+					    'keymap map)))))
 (defun widget-specify-button (widget from to)
 ;; Specify button for WIDGET between FROM and TO.
 (let ((face (widget-apply widget :button-face-get)))
 (add-text-properties from to (list 'button widget
 				       'mouse-face widget-mouse-face
 				       'start-open t
 				       'end-open t
 				       'face face))))
+(defun widget-specify-sample (widget from to)
+;; Specify sample for WIDGET between FROM and TO.
+(let ((face (widget-apply widget :sample-face-get)))
+(when face
+(add-text-properties from to (list 'start-open t
+					 'end-open t
+					 'face face)))))
 (defun widget-specify-doc (widget from to)
 ;; Specify documentation for WIDGET between FROM and TO.
 (add-text-properties from to (list 'widget-doc widget
 				     'face 'widget-documentation-face)))
 (defvar widget-keymap nil
 "Keymap containing useful binding for buffers containing widgets.
 Recommended as a parent keymap for modes using widgets.")
-(if widget-keymap
+(unless widget-keymap
-()
 (setq widget-keymap (make-sparse-keymap))
-(set-keymap-parent widget-keymap global-map)
 (define-key widget-keymap "\t" 'widget-forward)
 (define-key widget-keymap "\M-\t" 'widget-backward)
 (define-key widget-keymap [(shift tab)] 'widget-backward)
 (define-key widget-keymap [(shift tab)] 'widget-backward)
 (define-key widget-keymap [backtab] 'widget-backward)
 (defvar widget-global-map global-map
 "Keymap used for events the widget does not handle themselves.")
 (make-variable-buffer-local 'widget-global-map)
+(defvar widget-field-keymap nil
+"Keymap used inside an editable field.")
+(unless widget-field-keymap
+(setq widget-field-keymap (copy-keymap widget-keymap))
+(define-key widget-field-keymap "\C-m" 'widget-field-activate)
+(set-keymap-parent widget-field-keymap global-map))
+(defvar widget-text-keymap nil
+"Keymap used inside a text field.")
+(unless widget-text-keymap
+(setq widget-text-keymap (copy-keymap widget-keymap))
+(set-keymap-parent widget-text-keymap global-map))
+(defun widget-field-activate (pos &optional event)
+"Activate the ediable field at point."
+(interactive "@d")
+(let* ((field (get-text-property pos 'field)))
+(if field
+	(widget-apply field :action event)
+(call-interactively
+(lookup-key widget-global-map (this-command-keys))))))
 (defun widget-button-click (event)
 "Activate button below mouse pointer."
 (interactive "@e")
 (widget-button-press (event-point event) event))
 (if button
 	(widget-apply button :action event)
 (call-interactively
 (lookup-key widget-global-map (this-command-keys))))))
-(defun widget-forward (arg)
+(defun widget-move (arg)
-"Move point to the next field or button.
+"Move point to the ARG next field or button.
-With optional ARG, move across that many fields."
+ARG may be negative to move backward."
-(interactive "p")
 (while (> arg 0)
 (setq arg (1- arg))
 (let ((next (cond ((get-text-property (point) 'button)
 		       (next-single-property-change (point) 'button))
 		      ((get-text-property (point) 'field)
 	  (field (previous-single-property-change (point) 'field)))
 (cond ((and button field)
 	     (goto-char (max button field)))
 	    (button (goto-char button))
 	    (field (goto-char field)))))
-(widget-echo-help (point)))
+(widget-echo-help (point))
+(run-hooks 'widget-move-hook))
+(defun widget-forward (arg)
+"Move point to the next field or button.
+With optional ARG, move across that many fields."
+(interactive "p")
+(run-hooks 'widget-forward-hook)
+(widget-move arg))
 (defun widget-backward (arg)
 "Move point to the previous field or button.
 With optional ARG, move across that many fields."
 (interactive "p")
-(widget-forward (- arg)))
+(run-hooks 'widget-backward-hook)
+(widget-move (- arg)))
 ;;; Setting up the buffer.
 (defvar widget-field-new nil)
 ;; List of all newly created editable fields in the buffer.
 :create 'widget-default-create
 :indent nil
 :offset 0
 :format-handler 'widget-default-format-handler
 :button-face-get 'widget-default-button-face-get
+:sample-face-get 'widget-default-sample-face-get
 :delete 'widget-default-delete
 :value-set 'widget-default-value-set
 :value-inline 'widget-default-value-inline
 :menu-tag-get 'widget-default-menu-tag-get
 :validate (lambda (widget) nil)
 (widget-specify-insert
 (let ((from (point))
 	 (tag (widget-get widget :tag))
 	 (doc (widget-get widget :doc))
 	 button-begin button-end
+	 sample-begin sample-end
 	 doc-begin doc-end
 	 value-pos)
 (insert (widget-get widget :format))
 (goto-char from)
 ;; Parse % escapes in format.
 		(insert "%"))
 	       ((eq escape ?\[)
 		(setq button-begin (point)))
 	       ((eq escape ?\])
 		(setq button-end (point)))
+	       ((eq escape ?\{)
+		(setq sample-begin (point)))
+	       ((eq escape ?\})
+		(setq sample-end (point)))
 	       ((eq escape ?n)
 		(when (widget-get widget :indent)
 		  (insert "\n")
 		  (insert-char ?  (widget-get widget :indent))))
 	       ((eq escape ?t)
 		(if (and button-begin (not button-end))
 		    (widget-apply widget :value-create)
 		  (setq value-pos (point))))
 	       (t
 		(widget-apply widget :format-handler escape)))))
-;; Specify button and doc, and insert value.
+;; Specify button, sample, and doc, and insert value.
 (and button-begin button-end
 	  (widget-specify-button widget button-begin button-end))
+(and sample-begin sample-end
+	  (widget-specify-sample widget sample-begin sample-end))
 (and doc-begin doc-end
 	  (widget-specify-doc widget doc-begin doc-end))
 (when value-pos
 (goto-char value-pos)
 (widget-apply widget :value-create)))
 (defun widget-default-button-face-get (widget)
 ;; Use :button-face or widget-button-face
 (or (widget-get widget :button-face) 'widget-button-face))
+(defun widget-default-sample-face-get (widget)
+;; Use :sample-face.
+(widget-get widget :sample-face))
 (defun widget-default-delete (widget)
 ;; Remove widget from the buffer.
 (let ((from (widget-get widget :from))
 	(to (widget-get widget :to))
 	(inhibit-read-only t)
 ;;; The `link' Widget.
 (define-widget 'link 'item
 "An embedded link."
+:help-echo "Push me to follow the link."
 :format "%[_%t_%]")
 ;;; The `info-link' Widget.
 (define-widget 'info-link 'link
 ;;; The `editable-field' Widget.
 (define-widget 'editable-field 'default
 "An editable text field."
 :convert-widget 'widget-item-convert-widget
+:keymap widget-field-keymap
 :format "%v"
 :value ""
 :action 'widget-field-action
 :value-create 'widget-field-value-create
 :value-delete 'widget-field-value-delete
 (defun widget-field-value-get (widget)
 ;; Return current text in editing field.
 (let ((from (widget-get widget :value-from))
 	(to (widget-get widget :value-to))
 	(size (widget-get widget :size))
+	(secret (widget-get widget :secret))
 	(old (current-buffer)))
 (if (and from to)
 	(progn
 	  (set-buffer (marker-buffer from))
 	  (setq from (1+ from)
 	  (while (and size
 		      (not (zerop size))
 		      (> to from)
 		      (eq (char-after (1- to)) ?\ ))
 	    (setq to (1- to)))
-	  (prog1 (buffer-substring-no-properties from to)
+	  (let ((result (buffer-substring-no-properties from to)))
-	    (set-buffer old)))
+	    (when secret
+	      (let ((index 0))
+		(while (< (+ from index) to)
+		  (aset result index
+			(get-text-property (+ from index) 'secret))
+		  (setq index (1+ index)))))
+	    (set-buffer old)
+	    result))
 (widget-get widget :value))))
 (defun widget-field-match (widget value)
 ;; Match any string.
 (stringp value))
 ;;; The `text' Widget.
 (define-widget 'text 'editable-field
+:keymap widget-text-keymap
 "A multiline text area.")
 ;;; The `menu-choice' Widget.
 (define-widget 'menu-choice 'default
 (define-widget 'character 'string
 "An character."
 :tag "Character"
 :value 0
 :size 1
-:format "%t: %v\n"
+:format "%{%t%}: %v\n"
 :type-error "This field should contain a character"
 :value-to-internal (lambda (widget value)
 		       (if (integerp value)
 			   (char-to-string value)
 			 value))
 :match (lambda (widget value) (numberp value)))
 (define-widget 'list 'group
 "A lisp list."
 :tag "List"
-:format "%t:\n%v")
+:format "%{%t%}:\n%v")
 (define-widget 'vector 'group
 "A lisp vector."
 :tag "Vector"
-:format "%t:\n%v"
+:format "%{%t%}:\n%v"
 :match 'widget-vector-match
 :value-to-internal (lambda (widget value) (append value nil))
 :value-to-external (lambda (widget value) (apply 'vector value)))
 (defun widget-vector-match (widget value)
 			   (widget-apply :value-to-internal widget value))))
 (define-widget 'cons 'group
 "A cons-cell."
 :tag "Cons-cell"
-:format "%t:\n%v"
+:format "%{%t%}:\n%v"
 :match 'widget-cons-match
 :value-to-internal (lambda (widget value)
 		       (list (car value) (cdr value)))
 :value-to-external (lambda (widget value)
 		       (cons (nth 0 value) (nth 1 value))))
 :format "%[%t%]: %v")
 (define-widget 'radio 'radio-button-choice
 "A union of several sexp types."
 :tag "Choice"
-:format "%t:\n%v")
+:format "%{%t%}:\n%v")
 (define-widget 'repeat 'editable-list
 "A variable length homogeneous list."
 :tag "Repeat"
-:format "%t:\n%v%i\n")
+:format "%{%t%}:\n%v%i\n")
 (define-widget 'set 'checklist
 "A list of members from a fixed set."
 :tag "Set"
-:format "%t:\n%v")
+:format "%{%t%}:\n%v")
 (define-widget 'boolean 'toggle
 "To be nil or non-nil, that is the question."
 :tag "Boolean"
-:format "%t: %v")
+:format "%{%t%}: %v")
 ;;; The `color' Widget.
 (define-widget 'color-item 'choice-item
 "A color name (with sample)."

Mercurial > hg > xemacs-beta

comparison lisp/w3/widget-edit.el @ 16:0293115a14e9 r19-15b91