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

comparison lisp/custom/wid-edit.el @ 161:28f395d8dc7a r20-3b7

Import from CVS: tag r20-3b7

author	cvs
date	Mon, 13 Aug 2007 09:42:26 +0200
parents	3bb7ccffb0c0
children	0132846995bd

comparison

equal deleted inserted replaced

-:1c55655d6702
+:28f395d8dc7a
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.9908
+;; Version: 1.9916
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;; This file is part of GNU Emacs.
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 :link '(custom-manual "(widget)Top")
 :link '(url-link :tag "Development Page"
 		   "http://www.dina.kvl.dk/~abraham/custom/")
 :prefix "widget-"
 :group 'extensions
-:group 'faces
 :group 'hypermedia)
+(defgroup widget-documentation nil
+"Options controling the display of documentation strings."
+:group 'widgets)
+(defgroup widget-faces nil
+"Faces used by the widget library."
+:group 'widgets
+:group 'faces)
+(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 'widget-documentation
+:group 'widget-faces)
 (defface widget-button-face '((t (:bold t)))
 "Face used for widget buttons."
-:group 'widgets)
+:group 'widget-faces)
 (defcustom widget-mouse-face 'highlight
 "Face used for widget buttons when the mouse is above them."
 :type 'face
-:group 'widgets)
+:group 'widget-faces)
 (defface widget-field-face '((((class grayscale color)
 			       (background light))
 			      (:background "gray85"))
 			     (((class grayscale color)
 			       (background dark))
 			      (:background "dim gray"))
 			     (t
 			      (:italic t)))
 "Face used for editable fields."
-:group 'widgets)
+:group 'widget-faces)
 ;;; Utility functions.
 ;;
 ;; These are not really widget specific.
 				     'front-sticky t
 				     'rear-nonsticky nil
 				     'start-open nil
 				     'end-open nil)))
+(defcustom widget-field-add-space
+(or (< emacs-major-version 20)
+(and (eq emacs-major-version 20)
+	   (< emacs-minor-version 3))
+(not (string-match "XEmacs" emacs-version)))
+"Non-nil means add extra space at the end of editable text fields.
+This is needed on all versions of Emacs, and on XEmacs before 20.3.
+If you don't add the space, it will become impossible to edit a zero
+size field."
+:type 'boolean
+:group 'widgets)
 (defun widget-specify-field (widget from to)
 "Specify editable button for WIDGET between FROM and TO."
 (put-text-property from to 'read-only nil)
 ;; Terminating space is not part of the field, but necessary in
 ;; order for local-map to work.  Remove next sexp if local-map works
 ;; at the end of the overlay.
 (save-excursion
 (goto-char to)
-(insert-and-inherit " ")
+(when widget-field-add-space
+(insert-and-inherit " "))
 (setq to (point)))
 (add-text-properties (1- to) to ;to (1+ to)
 		       '(front-sticky nil start-open t read-only to))
 (add-text-properties (1- from) from
 		       '(rear-nonsticky t end-open t read-only from))
 (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)))
 				  (background light))
 				 (:foreground "dark gray"))
 				(t
 				 (:italic t)))
 "Face used for inactive widgets."
-:group 'widgets)
+:group 'widget-faces)
 (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 'mouse-face 'widget-inactive-face)
+;; This is disabled, as it makes the mouse cursor change shape.
+;; (overlay-put overlay 'mouse-face 'widget-inactive-face)
 (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))
 	(setq child (car children)
 	      children (cdr children))
 	(when (eq (widget-get child :button) widget)
 	  (throw 'child child)))
 nil)))
+(defun widget-map-buttons (function &optional buffer maparg)
+"Map FUNCTION over the buttons in BUFFER.
+FUNCTION is called with the arguments WIDGET and MAPARG.
+If FUNCTION returns non-nil, the walk is cancelled.
+The arguments MAPARG, and BUFFER default to nil and (current-buffer),
+respectively."
+(let ((cur (point-min))
+	(widget nil)
+	(parent nil)
+	(overlays (if buffer
+		      (save-excursion (set-buffer buffer) (overlay-lists))
+		    (overlay-lists))))
+(setq overlays (append (car overlays) (cdr overlays)))
+(while (setq cur (pop overlays))
+(setq widget (overlay-get cur 'button))
+(if (and widget (funcall function widget maparg))
+	  (setq overlays nil)))))
 ;;; Glyphs.
 (defcustom widget-glyph-directory (concat data-directory "custom/")
 "Where widget glyphs are located.
 	after-change-functions
 	(from (point)))
 (apply 'insert args)
 (widget-specify-text from (point))))
+(defun widget-convert-text (type from to
+				 &optional button-from button-to
+				 &rest args)
+"Return a widget of type TYPE with endpoint FROM TO.
+Optional ARGS are extra keyword arguments for TYPE.
+and TO will be used as the widgets end points. If optional arguments
+BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets
+button end points.
+Optional ARGS are extra keyword arguments for TYPE."
+(let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
+	(from (copy-marker from))
+	(to (copy-marker to)))
+(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)
+(when button-from
+(widget-specify-button widget button-from button-to))
+widget))
+(defun widget-convert-button (type from to &rest args)
+"Return a widget of type TYPE with endpoint FROM TO.
+Optional ARGS are extra keyword arguments for TYPE.
+No text will be inserted to the buffer, instead the text between FROM
+and TO will be used as the widgets end points, as well as the widgets
+button end points."
+(apply 'widget-convert-text type from to from to args))
+(defun widget-leave-text (widget)
+"Remove markers and overlays from WIDGET and its children."
+(let ((from (widget-get widget :from))
+	(to (widget-get widget :to))
+	(button (widget-get widget :button-overlay))
+	(field (widget-get widget :field-overlay))
+	(children (widget-get widget :children)))
+(set-marker from nil)
+(set-marker to nil)
+(delete-overlay button)
+(delete-overlay field)
+(mapcar 'widget-leave-text children)))
 ;;; Keymap and Commands.
 (defvar widget-keymap nil
 "Keymap containing useful binding for buffers containing widgets.
 Recommended as a parent keymap for modes using widgets.")
 '((((class color))
 (:foreground "red"))
 (t
 (:bold t :underline t)))
 "Face used for pressed buttons."
-:group 'widgets)
+:group 'widget-faces)
 (defun widget-button-click (event)
 "Invoke button below mouse pointer."
 (interactive "@e")
 (cond ((and (fboundp 'event-glyph)
 	(widget-apply-action button event)
 (let ((command (lookup-key widget-global-map (this-command-keys))))
 	(when (commandp command)
 	  (call-interactively command))))))
+(defun widget-tabable-at (&optional pos)
+"Return the tabable widget at POS, or nil.
+POS defaults to the value of (point)."
+(unless pos
+(setq pos (point)))
+(let ((widget (or (get-char-property (point) 'button)
+		    (get-char-property (point) 'field))))
+(if widget
+	(let ((order (widget-get widget :tab-order)))
+	  (if order
+	      (if (>= order 0)
+		  widget
+		nil)
+	    widget))
+nil)))
 (defun widget-move (arg)
 "Move point to the ARG next field or button.
 ARG may be negative to move backward."
 (or (bobp) (> arg 0) (backward-char))
 (let ((pos (point))
 	(number arg)
-	(old (or (get-char-property (point) 'button)
+	(old (widget-tabable-at))
-		 (get-char-property (point) 'field)))
 	new)
 ;; Forward.
 (while (> arg 0)
 (if (eobp)
 	  (goto-char (point-min))
 	(forward-char 1))
 (and (eq pos (point))
 	   (eq arg number)
 	   (error "No buttons or fields found"))
-(let ((new (or (get-char-property (point) 'button)
+(let ((new (widget-tabable-at)))
-		     (get-char-property (point) 'field))))
 	(when new
 	  (unless (eq new old)
-	    (unless (and (widget-get new :tab-order)
+	    (setq arg (1- arg))
-			 (< (widget-get new :tab-order) 0))
-	      (setq arg (1- arg)))
 	    (setq old new)))))
 ;; Backward.
 (while (< arg 0)
 (if (bobp)
 	  (goto-char (point-max))
 	(backward-char 1))
 (and (eq pos (point))
 	   (eq arg number)
 	   (error "No buttons or fields found"))
-(let ((new (or (get-char-property (point) 'button)
+(let ((new (widget-tabable-at)))
-		     (get-char-property (point) 'field))))
 	(when new
 	  (unless (eq new old)
-	    (unless (and (widget-get new :tab-order)
+	    (setq arg (1+ arg))))))
-			 (< (widget-get new :tab-order) 0))
+(let ((new (widget-tabable-at)))
-	      (setq arg (1+ arg)))))))
+(while (eq (widget-tabable-at) new)
-(while  (or (get-char-property (point) 'button)
+	(backward-char)))
-		(get-char-property (point) 'field))
-(backward-char))
 (forward-char))
 (widget-echo-help (point))
 (run-hooks 'widget-move-hook))
 (defun widget-forward (arg)
 (setq field (car widget-field-new)
 	    widget-field-new (cdr widget-field-new)
 	    widget-field-list (cons field widget-field-list))
 (let ((from (car (widget-get field :field-overlay)))
 	    (to (cdr (widget-get field :field-overlay))))
-	(widget-specify-field field from to)
+	(widget-specify-field field
+			      (marker-position from) (marker-position to))
 	(set-marker from nil)
 	(set-marker to nil))))
 (widget-clear-undo)
 ;; We need to maintain text properties and size of the editing fields.
 (make-local-variable 'after-change-functions)
 ;; The widget data before the change.
 (make-variable-buffer-local 'widget-field-was)
 (defun widget-field-buffer (widget)
 "Return the start of WIDGET's editing field."
-(overlay-buffer (widget-get widget :field-overlay)))
+(let ((overlay (widget-get widget :field-overlay)))
+(and overlay (overlay-buffer overlay))))
 (defun widget-field-start (widget)
 "Return the start of WIDGET's editing field."
-(overlay-start (widget-get widget :field-overlay)))
+(let ((overlay (widget-get widget :field-overlay)))
+(and overlay (overlay-start overlay))))
 (defun widget-field-end (widget)
 "Return the end of WIDGET's editing field."
-;; Don't subtract one if local-map works at the end of the overlay.
+(let ((overlay (widget-get widget :field-overlay)))
-(1- (overlay-end (widget-get widget :field-overlay))))
+;; Don't subtract one if local-map works at the end of the overlay.
+(and overlay (if widget-field-add-space
+		     (1- (overlay-end overlay))
+		   (overlay-end overlay)))))
 (defun widget-field-find (pos)
 "Return the field at POS.
 Unlike (get-char-property POS 'field) this, works with empty fields too."
 (let ((fields widget-field-list)
 (let ((field (widget-field-find from))
 	    (other (widget-field-find to)))
 	(when field
 	  (unless (eq field other)
 	    (debug "Change in different fields"))
-	  (let ((size (widget-get field :size)))
+	  (let ((size (widget-get field :size))
+		(secret (widget-get field :secret)))
 	    (when size
 	      (let ((begin (widget-field-start field))
 		    (end (widget-field-end field)))
 		(cond ((< (- end begin) size)
 		       ;; Field too small.
 			 (setq begin (point)))
 		       (save-excursion
 			 (goto-char end)
 			 (while (and (eq (preceding-char) ?\ )
 				     (> (point) begin))
-			   (delete-backward-char 1))))))))
+			   (delete-backward-char 1)))))))
+	    (when secret
+	      (let ((begin (widget-field-start field))
+		    (end (widget-field-end field)))
+		(when size
+		  (while (and (> end begin)
+			      (eq (char-after (1- end)) ?\ ))
+		    (setq end (1- end))))
+		(while (< begin end)
+		  (let ((old (char-after begin)))
+		    (unless (eq old secret)
+		      (subst-char-in-region begin (1+ begin) old secret)
+		      (put-text-property begin (1+ begin) 'secret old))
+		    (setq begin (1+ begin)))))))
 	  (widget-apply field :notify field)))
 (error (debug "After Change"))))
 ;;; Widget Functions
 ;;
 (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))
+(let* ((buttons (widget-get widget :buttons)))
-	 (doc-property (widget-get widget :documentation-property))
-	 (doc-try (cond ((widget-get widget :doc))
-			((symbolp doc-property)
-			 (documentation-property (widget-get widget :value)
-						 doc-property))
-			(t
-			 (funcall doc-property (widget-get widget :value)))))
-	 (doc-text (and (stringp doc-try)
-			(> (length doc-try) 1)
-			doc-try)))
 (cond ((eq escape ?h)
-	   (when doc-text
+	   (let* ((doc-property (widget-get widget :documentation-property))
-	     (and (eq (preceding-char) ?\n)
+		  (doc-try (cond ((widget-get widget :doc))
-		  (widget-get widget :indent)
+				 ((symbolp doc-property)
-		  (insert-char ?  (widget-get widget :indent)))
+				  (documentation-property
-	     ;; The `*' in the beginning is redundant.
+				   (widget-get widget :value)
-	     (when (eq (aref doc-text  0) ?*)
+				   doc-property))
-	       (setq doc-text (substring doc-text 1)))
+				 (t
-	     ;; Get rid of trailing newlines.
+				  (funcall doc-property
-	     (when (string-match "\n+\\'" doc-text)
+					   (widget-get widget :value)))))
-	       (setq doc-text (substring doc-text 0 (match-beginning 0))))
+		  (doc-text (and (stringp doc-try)
-	     (push (widget-create-child-and-convert
+				 (> (length doc-try) 1)
-		    widget 'documentation-string
+				 doc-try)))
-		    doc-text)
+	     (when doc-text
-		   buttons)))
+	       (and (eq (preceding-char) ?\n)
+		    (widget-get widget :indent)
+		    (insert-char ?  (widget-get widget :indent)))
+	       ;; The `*' in the beginning is redundant.
+	       (when (eq (aref doc-text  0) ?*)
+		 (setq doc-text (substring doc-text 1)))
+	       ;; Get rid of trailing newlines.
+	       (when (string-match "\n+\\'" doc-text)
+		 (setq doc-text (substring doc-text 0 (match-beginning 0))))
+	       (push (widget-create-child-and-convert
+		      widget 'documentation-string
+		      doc-text)
+		     buttons))))
 	  (t
 	   (error "Unknown escape `%c'" escape)))
 (widget-put widget :buttons buttons)))
 (defun widget-default-button-face-get (widget)
 (if (widget-value widget)
 	(widget-glyph-insert widget on "down" "down-pushed")
 (widget-glyph-insert widget off "right" "right-pushed")
 (insert "..."))))
+;;; The `documentation-link' Widget.
+(define-widget 'documentation-link 'link
+"Link type used in documentation strings."
+:action 'widget-documentation-link-action)
+(defun widget-documentation-link-action (widget &optional event)
+"Run apropos on WIDGET's value.  Ignore optional argument EVENT."
+(apropos (concat "\\`" (regexp-quote (widget-get widget :value)) "\\'")))
+(defcustom widget-documentation-links t
+"Add hyperlinks to documentation strings when non-nil."
+:type 'boolean
+:group 'widget-documentation)
+(defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'"
+"Regexp for matching potential links in documentation strings.
+The first group should be the link itself."
+:type 'regexp
+:group 'widget-documentation)
+(defcustom widget-documentation-link-p 'intern-soft
+"Predicate used to test if a string is useful as a link.
+The value should be a function.  The function will be called one
+argument, a string, and should return non-nil if there should be a
+link for that string."
+:type 'function
+:options '(widget-documentation-link-p)
+:group 'widget-documentation)
+(defcustom widget-documentation-link-type 'documentation-link
+"Widget type used for links in documentation strings."
+:type 'symbol
+:group 'widget-documentation)
+(defun widget-documentation-link-add (widget from to)
+(widget-specify-doc widget from to)
+(when widget-documentation-links
+(let ((regexp widget-documentation-link-regexp)
+	  (predicate widget-documentation-link-p)
+	  (type widget-documentation-link-type)
+	  (buttons (widget-get widget :buttons)))
+(save-excursion
+	(goto-char (point-min))
+	(while (re-search-forward regexp to t)
+	  (let ((name (match-string 1))
+		(begin (match-beginning 0))
+		(end (match-end 0)))
+	    (when (funcall predicate name)
+	      (push (widget-convert-button type begin end :value name)
+		    buttons)))))
+(widget-put widget :buttons buttons))))
 ;;; The `documentation-string' Widget.
-(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)
 (define-widget 'documentation-string 'item
 "A documentation string."
 :format "%v"
 :action 'widget-documentation-string-action
 :value-create 'widget-documentation-string-value-create)
 (defun widget-documentation-string-value-create (widget)
 ;; Insert documentation string.
 (let ((doc (widget-value widget))
-	(shown (widget-get (widget-get widget :parent) :documentation-shown)))
+	(shown (widget-get (widget-get widget :parent) :documentation-shown))
+	(start (point)))
 (if (string-match "\n" doc)
 	(let ((before (substring doc 0 (match-beginning 0)))
 	      (after (substring doc (match-beginning 0)))
-	      (start (point))
 	      buttons)
 	  (insert before " ")
-	  (widget-specify-doc widget start (point))
+	  (widget-documentation-link-add widget start (point))
 	  (push (widget-create-child-and-convert
 		 widget 'visibility
 		 :off nil
 		 :action 'widget-parent-action
 		 shown)
 		buttons)
 	  (when shown
 	    (setq start (point))
 	    (insert after)
-	    (widget-specify-doc widget start (point)))
+	    (widget-documentation-link-add widget start (point)))
 	  (widget-put widget :buttons buttons))
-(insert doc)))
+(insert doc)
+(widget-documentation-link-add widget start (point))))
 (insert "\n"))
 (defun widget-documentation-string-action (widget &rest ignore)
 ;; Toggle documentation.
 (let ((parent (widget-get widget :parent)))

Mercurial > hg > xemacs-beta

comparison lisp/custom/wid-edit.el @ 161:28f395d8dc7a r20-3b7