xemacs-beta: lisp/custom/wid-edit.el comparison

comparison lisp/custom/wid-edit.el @ 134:34a5b81f86ba r20-2b1

Import from CVS: tag r20-2b1

author	cvs
date	Mon, 13 Aug 2007 09:30:11 +0200
parents	9b50b4588a93
children	b980b6286996

comparison

equal deleted inserted replaced

-:b27e67717092
+:34a5b81f86ba
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.84
+;; Version: 1.89
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;;; Commentary:
 ;;
 ;; See `widget.el'.
 (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
 ;; We have the old custom-library, hack around it!
 (defmacro defgroup (&rest args) nil)
 (defmacro defcustom (var value doc &rest args)
-`(defvar ,var ,value ,doc))
+(` (defvar (, var) (, value) (, doc))))
 (defmacro defface (&rest args) nil)
 (define-widget-keywords :prefix :tag :load :link :options :type :group)
 (when (fboundp 'copy-face)
 (copy-face 'default 'widget-documentation-face)
 (copy-face 'bold 'widget-button-face)
 :type 'face
 :group 'widgets)
 (defface widget-field-face '((((class grayscale color)
 			       (background light))
-			      (:background "light gray"))
+			      (:background "gray85"))
 			     (((class grayscale color)
 			       (background dark))
 			      (:background "dark gray"))
 			     (t
 			      (:italic t)))
 (defun widget-choose (title items &optional event)
 "Choose an item from a list.
 First argument TITLE is the name of the list.
-Second argument ITEMS is an alist (NAME . VALUE).
+Second argument ITEMS is an list whose members are either
+(NAME . VALUE), to indicate selectable items, or just strings to
+indicate unselectable items.
 Optional third argument EVENT is an input event.
 The user is asked to choose between each NAME from the items alist,
 and the VALUE of the chosen element will be returned.  If EVENT is a
 mouse event, and the number of elements in items is less than
 	 (let ((val (get-popup-menu-response
 		     (cons title
 			   (mapcar
 			    (function
 			     (lambda (x)
-			       (vector (car x) (list (car x)) t)))
+			       (if (stringp x)
+				   (vector x nil nil)
+				 (vector (car x) (list (car x)) t))))
 			    items)))))
 	   (setq val (and val
 			  (listp (event-object val))
 			  (stringp (car-safe (event-object val)))
 			  (car (event-object val))))
 	   (cdr (assoc val items))))
 	(t
+	 (setq items (remove-if 'stringp items))
 	 (let ((val (completing-read (concat title ": ") items nil t)))
 	   (if (stringp val)
 	       (let ((try (try-completion val items)))
 		 (when (stringp try)
 		   (setq val try))
 (add-text-properties from to (list 'widget-doc widget
 				     'face 'widget-documentation-face)))
 (defmacro widget-specify-insert (&rest form)
 ;; Execute FORM without inheriting any text properties.
-`(save-restriction
+(`
+(save-restriction
 (let ((inhibit-read-only t)
 	   result
 	   after-change-functions)
 (insert "<>")
 (narrow-to-region (- (point) 2) (point))
 (widget-specify-none (point-min) (point-max))
 (goto-char (1+ (point-min)))
-(setq result (progn ,@form))
+(setq result (progn (,@ form)))
 (delete-region (point-min) (1+ (point-min)))
 (delete-region (1- (point-max)) (point-max))
 (goto-char (point-max))
-result)))
+result))))
 (defface widget-inactive-face '((((class grayscale color)
 				  (background dark))
 				 (:foreground "light gray"))
 				(((class grayscale color)
 (defun widget-specify-inactive (widget from to)
 "Make WIDGET inactive for user modifications."
 (unless (widget-get widget :inactive)
 (let ((overlay (make-overlay from to nil t nil)))
 (overlay-put overlay 'face 'widget-inactive-face)
-(overlay-put overlay 'evaporate 't)
+(overlay-put overlay 'evaporate t)
+(overlay-put overlay 'priority 100)
 (overlay-put overlay (if (string-match "XEmacs" emacs-version)
 			       'read-only
 			     'modification-hooks) '(widget-overlay-inactive))
 (widget-put widget :inactive overlay))))
 		       (button (goto-char button))
 		       (field (goto-char field))
 		       (t
 			(error "No buttons or fields found"))))))
 	(setq button (widget-at (point)))
-	(if (and button (widget-get button :tab-order)
+	(if (or (and button (widget-get button :tab-order)
-		 (< (widget-get button :tab-order) 0))
+		     (< (widget-get button :tab-order) 0))
+		(and button (not (widget-apply button :active))))
 	    (setq arg (1+ arg))))))
 (while (< arg 0)
 (if (= (point-min) (point))
 	(forward-char 1))
 (setq arg (1+ arg))
 (cond ((and button field)
 	     (goto-char (max button field)))
 	    (button (goto-char button))
 	    (field (goto-char field)))
 (setq button (widget-at (point)))
-(if (and button (widget-get button :tab-order)
+(if (or (and button (widget-get button :tab-order)
-	       (< (widget-get button :tab-order) 0))
+		   (< (widget-get button :tab-order) 0))
+	      (and button (not (widget-apply button :active))))
 	  (setq arg (1- arg)))))
 (widget-echo-help (point))
 (run-hooks 'widget-move-hook))
 (defun widget-forward (arg)
 	 (to (copy-marker (point-max))))
 (widget-specify-text from to)
 (set-marker-insertion-type from t)
 (set-marker-insertion-type to nil)
 (widget-put widget :from from)
-(widget-put widget :to to))))
+(widget-put widget :to to)))
+(widget-clear-undo))
 (defun widget-default-format-handler (widget escape)
 ;; We recognize the %h escape by default.
 (let* ((buttons (widget-get widget :buttons))
 	 (doc-property (widget-get widget :documentation-property))
 (widget-apply widget :value-delete)
 (when (< from to)
 ;; Kludge: this doesn't need to be true for empty formats.
 (delete-region from to))
 (set-marker from nil)
-(set-marker to nil)))
+(set-marker to nil))
+(widget-clear-undo))
 (defun widget-default-value-set (widget value)
 ;; Recreate widget with new value.
 (save-excursion
 (goto-char (widget-get widget :from))
 "A link to an info file."
 :action 'widget-info-link-action)
 (defun widget-info-link-action (widget &optional event)
 "Open the info node specified by WIDGET."
-(Info-goto-node (widget-value widget)))
+(Info-goto-node (widget-value widget))
+;; Steal button release event.
+(if (and (fboundp 'button-press-event-p)
+	   (fboundp 'next-command-event))
+;; XEmacs
+(and event
+	   (button-press-event-p event)
+	   (next-command-event))
+;; Emacs
+(when (memq 'down (event-modifiers event))
+(read-event))))
 ;;; The `url-link' Widget.
 (define-widget 'url-link 'link
 "A link to an www page."
 		 (widget-choose tag (reverse choices) event))))
 (when current
 (widget-value-set widget
 			(widget-apply current :value-to-external
 				      (widget-get current :value)))
 (widget-apply widget :notify widget event)
-(widget-setup)))
+(widget-setup))))
-;; Notify parent.
-(widget-apply widget :notify widget event)
-(widget-clear-undo))
 (defun widget-choice-validate (widget)
 ;; Valid if we have made a valid choice.
 (let ((void (widget-get widget :void))
 	(choice (widget-get widget :choice))
 (defun widget-toggle-action (widget &optional event)
 ;; Toggle value.
 (widget-value-set widget (not (widget-value widget)))
 (widget-apply widget :notify widget event))
 ;;; The `checkbox' Widget.
 (define-widget 'checkbox 'toggle
 "A checkbox toggle."
 :format "%[%v%]"

Mercurial > hg > xemacs-beta

comparison lisp/custom/wid-edit.el @ 134:34a5b81f86ba r20-2b1