comparison lisp/wid-edit.el @ 25686:c1a7a52bbfea

Remove some compatibility code and checks. (widget-specify-field, widget-specify-button): Don't use XEmacs properties. (widget-overlay-inactive): Change error message. (widget-button-pressed-face): New variable. (widget-button-click): Use it. (widget-documentation-link-add): Specify mouse and button faces. (widget-echo-help-mouse, widget-stop-mouse-tracking): Functions removed now the functionality is built in.

25685:fc2bfab28ed7

;;; wid-edit.el --- Functions for creating and using widgets.
;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: extensions
;; Version: 1.9951
;; 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
;; it under the terms of the GNU General Public License as published by

(eval-and-compile
  (autoload 'pp-to-string "pp")
  (autoload 'Info-goto-node "info")
  (autoload 'finder-commentary "finder" nil t)

  (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))))
    (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)
      (copy-face 'italic 'widget-field-face)))

  (unless (fboundp 'button-release-event-p)
    ;; XEmacs function missing from Emacs.
    (defun button-release-event-p (event)
      "Non-nil if EVENT is a mouse-button-release event object."

  "Faces used by the widget library."
  :group 'widgets
  :group 'faces)

(defvar widget-documentation-face 'widget-documentation-face
  "Face used for documentation strings in widges.
This exists as a variable so it can be set locally in certain buffers.")

(defface widget-documentation-face '((((class color)
				       (background dark))
				      (:foreground "lime green"))

  "Face used for documentation text."
  :group 'widget-documentation
  :group 'widget-faces)

(defvar widget-button-face 'widget-button-face
  "Face used for buttons in widges.
This exists as a variable so it can be set locally in certain buffers.")

(defface widget-button-face '((t (:bold t)))
  "Face used for widget buttons."
  :group 'widget-faces)

			       nil (or (not widget-field-add-space)
				       (widget-get widget :size)))))
    (unless (or (stringp help-echo) (null help-echo))
      (setq help-echo 'widget-mouse-help))    
    (widget-put widget :field-overlay overlay)
    (overlay-put overlay 'detachable nil)
    (overlay-put overlay 'field widget)
    (overlay-put overlay 'local-map map)
    (overlay-put overlay 'keymap map)
    (overlay-put overlay 'face face)
    (overlay-put overlay 'balloon-help help-echo)
    (overlay-put overlay 'help-echo help-echo))
  (widget-specify-secret widget))

(defun widget-specify-secret (field)
  "Replace text in FIELD with value of `:secret', if non-nil."

    (widget-put widget :button-overlay overlay)
    (unless (or (null help-echo) (stringp help-echo))
      (setq help-echo 'widget-mouse-help))
    (overlay-put overlay 'button widget)
    (overlay-put overlay 'mouse-face widget-mouse-face)
    (overlay-put overlay 'balloon-help help-echo)
    (overlay-put overlay 'help-echo help-echo)
    (overlay-put overlay 'face face)))

(defun widget-mouse-help (extent)
  "Find mouse help string for button in extent."

      (overlay-put overlay '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))
      (widget-put widget :inactive overlay))))

(defun widget-overlay-inactive (&rest junk)
  "Ignoring the arguments, signal an error."
  (unless inhibit-read-only
    (error "Attempt to modify inactive widget")))


(defun widget-specify-active (widget)
  "Make WIDGET active for user modifications."
  (let ((inactive (widget-get widget :inactive)))

  "Extract the default value of WIDGET."
  (or (widget-get widget :value)
      (widget-apply widget :default-get)))

(defun widget-match-inline (widget vals)
  ;; In WIDGET, match the start of VALS.
  (cond ((widget-get widget :inline)
	 (widget-apply widget :match-inline vals))
	((and vals
	      (widget-apply widget :match (car vals)))
	 (cons (list (car vals)) (cdr vals)))

(defvar widget-field-keymap nil
  "Keymap used inside an editable field.")

(unless widget-field-keymap 
  (setq widget-field-keymap (copy-keymap widget-keymap))
  (unless (string-match "XEmacs" (emacs-version))
    (define-key widget-field-keymap [menu-bar] 'nil))
  (define-key widget-field-keymap "\C-k" 'widget-kill-line)
  (define-key widget-field-keymap "\M-\t" 'widget-complete)
  (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)

(defvar widget-text-keymap nil
  "Keymap used inside a text field.")

(unless widget-text-keymap 
  (setq widget-text-keymap (copy-keymap widget-keymap))
  (unless (string-match "XEmacs" (emacs-version))
    (define-key widget-text-keymap [menu-bar] 'nil))
  (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)

  (let ((field (get-char-property pos 'field)))
    (if field
	(widget-apply-action field event)
      (call-interactively
       (lookup-key widget-global-map (this-command-keys))))))

(defface widget-button-pressed-face 
  '((((class color))
     (:foreground "red"))
    (t

		      (face (overlay-get overlay 'face))
		      (mouse-face (overlay-get overlay 'mouse-face)))
		 (unwind-protect
		     (let ((track-mouse t))
		       (overlay-put overlay
				    'face 'widget-button-pressed-face)
		       (overlay-put overlay 
				    'mouse-face 'widget-button-pressed-face)
		       (unless (widget-apply button :mouse-down-action event)
			 (while (not (button-release-event-p event))
			   (setq event (widget-read-event)
				 pos (widget-event-point event))
			   (if (and pos
				    (eq (get-char-property pos 'button)
					button))
			       (progn 
				 (overlay-put overlay 
					      'face
					      'widget-button-pressed-face)
				 (overlay-put overlay 
					      'mouse-face 
					      'widget-button-pressed-face))
			     (overlay-put overlay 'face face)
			     (overlay-put overlay 'mouse-face mouse-face))))
		       (when (and pos 
				  (eq (get-char-property pos 'button) button))
			 (widget-apply-action button event)))

    child))

;;; The `group' Widget.

(define-widget 'group 'default
  "A widget which group other widgets inside."
  :convert-widget 'widget-types-convert-widget
  :format "%v"
  :value-create 'widget-group-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-editable-list-value-get

  (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 from)
	(while (re-search-forward regexp to t)
	  (let ((name (match-string 1))
		(begin (match-beginning 1))

	       'face (widget-apply widget :sample-face-get))
  (widget-default-notify widget child event))

;;; The Help Echo

(defun widget-echo-help-mouse ()
  "Display the help message for the widget under the mouse.
Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"
  (let* ((pos (mouse-position))
	 (frame (car pos))
	 (x (car (cdr pos)))
	 (y (cdr (cdr pos)))
	 (win (window-at x y frame))
	 (where (coordinates-in-window-p (cons x y) win)))
    (when (consp where)
      (save-window-excursion
	(progn ; save-excursion
	  (select-window win)
	  (let* ((result (compute-motion (window-start win)
					 '(0 . 0)
					 (point-max)
					 where
					 (window-width win)
					 (cons (window-hscroll) 0)
					 win)))
	    (when (and (eq (nth 1 result) x)
		       (eq (nth 2 result) y))
	      (widget-echo-help (nth 0 result))))))))
  (unless track-mouse
    (setq track-mouse t)
    (add-hook 'post-command-hook 'widget-stop-mouse-tracking)))

(defun widget-stop-mouse-tracking (&rest args)
  "Stop the mouse tracking done while idle."
  (remove-hook 'post-command-hook 'widget-stop-mouse-tracking)
  (setq track-mouse nil))

(defun widget-at (pos)
  "The button or field at POS."
  (or (get-char-property pos 'button)
      (get-char-property pos 'field)))

25686:c1a7a52bbfea

;;; wid-edit.el --- Functions for creating and using widgets.
;;
;; Copyright (C) 1996, 1997, 1999 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Maintainer: FSF
;; Keywords: extensions
;; Version: 1.9951
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ (probably obsolete)

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by

(eval-and-compile
  (autoload 'pp-to-string "pp")
  (autoload 'Info-goto-node "info")
  (autoload 'finder-commentary "finder" nil t)

  (unless (fboundp 'button-release-event-p)
    ;; XEmacs function missing from Emacs.
    (defun button-release-event-p (event)
      "Non-nil if EVENT is a mouse-button-release event object."

  "Faces used by the widget library."
  :group 'widgets
  :group 'faces)

(defvar widget-documentation-face 'widget-documentation-face
  "Face used for documentation strings in widgets.
This exists as a variable so it can be set locally in certain buffers.")

(defface widget-documentation-face '((((class color)
				       (background dark))
				      (:foreground "lime green"))

  "Face used for documentation text."
  :group 'widget-documentation
  :group 'widget-faces)

(defvar widget-button-face 'widget-button-face
  "Face used for buttons in widgets.
This exists as a variable so it can be set locally in certain buffers.")

(defface widget-button-face '((t (:bold t)))
  "Face used for widget buttons."
  :group 'widget-faces)

			       nil (or (not widget-field-add-space)
				       (widget-get widget :size)))))
    (unless (or (stringp help-echo) (null help-echo))
      (setq help-echo 'widget-mouse-help))    
    (widget-put widget :field-overlay overlay)
    ;;(overlay-put overlay 'detachable nil)
    (overlay-put overlay 'field widget)
    (overlay-put overlay 'local-map map)
    ;;(overlay-put overlay 'keymap map)
    (overlay-put overlay 'face face)
    ;;(overlay-put overlay 'balloon-help help-echo)
    (overlay-put overlay 'help-echo help-echo))
  (widget-specify-secret widget))

(defun widget-specify-secret (field)
  "Replace text in FIELD with value of `:secret', if non-nil."

    (widget-put widget :button-overlay overlay)
    (unless (or (null help-echo) (stringp help-echo))
      (setq help-echo 'widget-mouse-help))
    (overlay-put overlay 'button widget)
    (overlay-put overlay 'mouse-face widget-mouse-face)
    ;;(overlay-put overlay 'balloon-help help-echo)
    (overlay-put overlay 'help-echo help-echo)
    (overlay-put overlay 'face face)))

(defun widget-mouse-help (extent)
  "Find mouse help string for button in extent."

      (overlay-put overlay '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 'modification-hooks '(widget-overlay-inactive))
      (widget-put widget :inactive overlay))))

(defun widget-overlay-inactive (&rest junk)
  "Ignoring the arguments, signal an error."
  (unless inhibit-read-only
    (error "The widget here is not active")))


(defun widget-specify-active (widget)
  "Make WIDGET active for user modifications."
  (let ((inactive (widget-get widget :inactive)))

  "Extract the default value of WIDGET."
  (or (widget-get widget :value)
      (widget-apply widget :default-get)))

(defun widget-match-inline (widget vals)
  "In WIDGET, match the start of VALS."
  (cond ((widget-get widget :inline)
	 (widget-apply widget :match-inline vals))
	((and vals
	      (widget-apply widget :match (car vals)))
	 (cons (list (car vals)) (cdr vals)))

(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 [menu-bar] 'nil)
  (define-key widget-field-keymap "\C-k" 'widget-kill-line)
  (define-key widget-field-keymap "\M-\t" 'widget-complete)
  (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)

(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 [menu-bar] 'nil)
  (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)

  (let ((field (get-char-property pos 'field)))
    (if field
	(widget-apply-action field event)
      (call-interactively
       (lookup-key widget-global-map (this-command-keys))))))

(defvar widget-button-pressed-face 'widget-button-pressed-face
  "Face used for pressed buttons in widgets.
This exists as a variable so it can be set locally in certain buffers.")

(defface widget-button-pressed-face 
  '((((class color))
     (:foreground "red"))
    (t

		      (face (overlay-get overlay 'face))
		      (mouse-face (overlay-get overlay 'mouse-face)))
		 (unwind-protect
		     (let ((track-mouse t))
		       (overlay-put overlay
				    'face widget-button-pressed-face)
		       (overlay-put overlay 
				    'mouse-face widget-button-pressed-face)
		       (unless (widget-apply button :mouse-down-action event)
			 (while (not (button-release-event-p event))
			   (setq event (widget-read-event)
				 pos (widget-event-point event))
			   (if (and pos
				    (eq (get-char-property pos 'button)
					button))
			       (progn 
				 (overlay-put overlay 
					      'face
					      widget-button-pressed-face)
				 (overlay-put overlay 
					      'mouse-face 
					      widget-button-pressed-face))
			     (overlay-put overlay 'face face)
			     (overlay-put overlay 'mouse-face mouse-face))))
		       (when (and pos 
				  (eq (get-char-property pos 'button) button))
			 (widget-apply-action button event)))

    child))

;;; The `group' Widget.

(define-widget 'group 'default
  "A widget which groups other widgets inside."
  :convert-widget 'widget-types-convert-widget
  :format "%v"
  :value-create 'widget-group-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-editable-list-value-get

  (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))
	  (widget-mouse-face (default-value 'widget-mouse-face))
	  (widget-button-face widget-documentation-face)
	  (widget-button-pressed-face widget-documentation-face))
      (save-excursion
	(goto-char from)
	(while (re-search-forward regexp to t)
	  (let ((name (match-string 1))
		(begin (match-beginning 1))

	       'face (widget-apply widget :sample-face-get))
  (widget-default-notify widget child event))

;;; The Help Echo

(defun widget-at (pos)
  "The button or field at POS."
  (or (get-char-property pos 'button)
      (get-char-property pos 'field)))