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

comparison lisp/custom/widget-edit.el @ 20:859a2309aef8 r19-15b93

Import from CVS: tag r19-15b93

author	cvs
date	Mon, 13 Aug 2007 08:50:05 +0200
parents	d95e72db5c07
children	8fc7fe29b841

comparison

equal deleted inserted replaced

-:ac1f612d5250
+:859a2309aef8
 ;;
 ;; Copyright (C) 1996 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.24
+;; Version: 1.30
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;;; Commentary:
 ;;
 ;; See `widget.el'.
 	(t
 	 (cdr (assoc (completing-read (concat title ": ")
 				      items nil t)
 		     items)))))
+(defun widget-get-sibling (widget)
+"Get the item WIDGET is assumed to toggle.
+This is only meaningful for radio buttons or checkboxes in a list."
+(let* ((parent (widget-get widget :parent))
+	 (children (widget-get parent :children))
+	 child)
+(catch 'child
+(while children
+	(setq child (car children)
+	      children (cdr children))
+	(when (eq (widget-get child :button) widget)
+	  (throw 'child child)))
+nil)))
 ;;; Widget text specifications.
 ;;
 ;; These functions are for specifying text properties.
 (defun widget-specify-none (from to)
 	    (put-text-property (point) (1+ (point)) 'secret old))
 	  (forward-char))))
 (unless (widget-get widget :size)
 (add-text-properties to (1+ to) (list 'field widget
-					    'face face
+					    'face face)))
-					    'local-map map
+(add-text-properties to (1+ to) (list 'local-map map
-					    'keymap 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
 (delete-region (1- (point-max)) (point-max))
 (goto-char (point-max))
 result)))
 ;;; Widget Properties.
+(defsubst widget-name (widget)
+"Return the name of WIDGET, asymbol."
+(car widget))
 (defun widget-put (widget property value)
 "In WIDGET set PROPERTY to VALUE.
 The value can later be retrived with `widget-get'."
 (setcdr widget (plist-put (cdr widget) property value)))
 "Keymap containing useful binding for buffers containing widgets.
 Recommended as a parent keymap for modes using widgets.")
 (unless widget-keymap
 (setq widget-keymap (make-sparse-keymap))
+(define-key widget-keymap "\C-k" 'widget-kill-line)
 (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)
 "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)
+(define-key widget-field-keymap "\C-a" 'widget-beginning-of-line)
+(define-key widget-field-keymap "\C-e" 'widget-end-of-line)
 (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))
+(define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
+(define-key widget-text-keymap "\C-e" 'widget-end-of-line)
 (set-keymap-parent widget-text-keymap global-map))
 (defun widget-field-activate (pos &optional event)
 "Activate the ediable field at point."
 (interactive "@d")
 With optional ARG, move across that many fields."
 (interactive "p")
 (run-hooks 'widget-backward-hook)
 (widget-move (- arg)))
+(defun widget-beginning-of-line ()
+"Go to beginning of field or beginning of line, whichever is first."
+(interactive)
+(let ((bol (save-excursion (beginning-of-line) (point)))
+	(prev (previous-single-property-change (point) 'field)))
+(goto-char (max bol (or prev bol)))))
+(defun widget-end-of-line ()
+"Go to end of field or end of line, whichever is first."
+(interactive)
+(let ((bol (save-excursion (end-of-line) (point)))
+	(prev (next-single-property-change (point) 'field)))
+(goto-char (min bol (or prev bol)))))
+(defun widget-kill-line ()
+"Kill to end of field or end of line, whichever is first."
+(interactive)
+(let ((field (get-text-property (point) 'field))
+	(newline (save-excursion (search-forward "\n")))
+	(next (next-single-property-change (point) 'field)))
+(if (and field (> newline next))
+	(kill-region (point) next)
+(call-interactively 'kill-line))))
+(defun widget-identify (pos)
+"Identify the widget under point."
+(interactive "d")
+(let* ((field (get-text-property pos 'field))
+	 (button (get-text-property pos 'button))
+	 (doc (get-text-property pos 'widget-doc))
+	 (widget (or field button doc)))
+(with-output-to-temp-buffer "*Widget Identity*"
+(princ (cond (field "This is an editable text area.\n")
+		   (button "This is an active area.\n")
+		   (doc "This is documentation text.\n")
+		   (t "This is unidentified text.\n")))
+(while widget
+	(princ "It is part of a `")
+	(princ (car widget))
+	(princ "' widget (value: ")
+	(prin1 (condition-case nil
+		   (widget-value widget)
+		 (error 'error)))
+	(princ ").\n")
+	(when (eq (car widget) 'radio-button)
+	  (let ((sibling (widget-get-sibling widget)))
+	    (if (not sibling)
+		(princ "It doesn't seem to control anything.\n")
+	      (princ "The value of its sibling is: ")
+	      (prin1 (condition-case nil
+			 (widget-value sibling)
+		       (error 'error)))
+	      (princ ".\n"))))
+	(setq widget (widget-get widget :parent))))))
 ;;; Setting up the buffer.
 (defvar widget-field-new nil)
 ;; List of all newly created editable fields in the buffer.
 (make-variable-buffer-local 'widget-field-new)
 	    found (widget-match-inline current values)))
 found))
 ;;; The `toggle' Widget.
-(define-widget 'toggle 'menu-choice
+(define-widget 'toggle 'item
 "Toggle between two states."
-:convert-widget 'widget-toggle-convert-widget
+:format "%[%v%]\n"
-:format "%v"
+:value-create 'widget-toggle-value-create
+:action 'widget-toggle-action
+:match (lambda (widget value) t)
 :on "on"
 :off "off")
-(defun widget-toggle-convert-widget (widget)
+(defun widget-toggle-value-create (widget)
-;; Create the types representing the `on' and `off' states.
+;; Insert text representing the `on' and `off' states.
-(let ((on-type (widget-get widget :on-type))
+(if (widget-value widget)
-	(off-type (widget-get widget :off-type)))
+(insert (widget-get widget :on))
-(unless on-type
+(insert (widget-get widget :off))))
-(setq on-type
-	    (list 'choice-item
+(defun widget-toggle-action (widget &optional event)
-		  :value t
+;; Toggle value.
-		  :match (lambda (widget value) value)
+(widget-value-set widget (not (widget-value widget)))
-		  :tag (widget-get widget :on))))
+(widget-apply widget :notify widget event))
-(unless off-type
-(setq off-type
-	    (list 'choice-item :value nil :tag (widget-get widget :off))))
-(widget-put widget :args (list on-type off-type)))
-widget)
 ;;; The `checkbox' Widget.
 (define-widget 'checkbox 'toggle
 "A checkbox toggle."
-:convert-widget 'widget-item-convert-widget
+:format "%[%v%]"
-:on-type '(choice-item :format "%[[X]%]" t)
+:on "[X]"
-:off-type  '(choice-item :format "%[[ ]%]" nil))
+:off "[ ]")
 ;;; The `checklist' Widget.
 (define-widget 'checklist 'default
 "A multiple choice widget."
 ;;; The `radio-button' Widget.
 (define-widget 'radio-button 'toggle
 "A radio button for use in the `radio' widget."
 :notify 'widget-radio-button-notify
-:on-type '(choice-item :format "%[(*)%]" t)
+:format "%[%v%]"
-:off-type '(choice-item :format "%[( )%]" nil))
+:on "(*)"
+:off "( )")
 (defun widget-radio-button-notify (widget child &optional event)
-;; Notify the parent.
+;; Tell daddy.
 (widget-apply (widget-get widget :parent) :action widget event))
 ;;; The `radio-button-choice' Widget.
 (define-widget 'radio-button-choice 'default
 :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/custom/widget-edit.el @ 20:859a2309aef8 r19-15b93