Commit 25ac13b5 authored by Per Abrahamsen's avatar Per Abrahamsen

Synched with version 1.9900.

parent eedc2336
This diff is collapsed.
......@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
;; Version: 1.97
;; Version: 1.9900
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
......@@ -56,7 +56,7 @@ the car of that and used as the default binding for symbol.
Otherwise, VALUE will be evaluated and used as the default binding for
symbol."
(unless (default-boundp symbol)
;; Use the saved value if it exists, otherwise the factory setting.
;; Use the saved value if it exists, otherwise the standard setting.
(set-default symbol (if (get symbol 'saved-value)
(eval (car (get symbol 'saved-value)))
(eval value)))))
......@@ -89,7 +89,7 @@ Like `custom-initialize-set', but use the function specified by
(defun custom-initialize-changed (symbol value)
"Initialize SYMBOL with VALUE.
Like `custom-initialize-reset', but only use the `:set' function if the
not using the factory setting. Otherwise, use the `set-default'."
not using the standard setting. Otherwise, use the `set-default'."
(cond ((default-boundp symbol)
(funcall (or (get symbol 'custom-set) 'set-default)
symbol
......@@ -104,8 +104,8 @@ not using the factory setting. Otherwise, use the `set-default'."
(defun custom-declare-variable (symbol value doc &rest args)
"Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
;; Remember the factory setting.
(put symbol 'factory-value (list value))
;; Remember the standard setting.
(put symbol 'standard-value (list value))
;; Maybe this option was rogue in an earlier version. It no longer is.
(when (get symbol 'force-value)
;; It no longer is.
......
......@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
;; Version: 1.97
;; Version: 1.9900
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
......@@ -31,8 +31,7 @@
;;; Code:
(require 'widget)
(eval-when-compile (require 'cl))
(require 'cl)
;;; Compatibility.
......@@ -146,7 +145,7 @@ and `end-open' if it should sticky to the front."
(:background "gray85"))
(((class grayscale color)
(background dark))
(:background "dark gray"))
(:background "dim gray"))
(t
(:italic t)))
"Face used for editable fields."
......@@ -542,7 +541,7 @@ This is only meaningful for radio buttons or checkboxes in a list."
(defcustom widget-glyph-directory (concat data-directory "custom/")
"Where widget glyphs are located.
If this variable is nil, widget will try to locate the directory
automatically. This does not work yet."
automatically."
:group 'widgets
:type 'directory)
......@@ -551,47 +550,75 @@ automatically. This does not work yet."
:group 'widgets
:type 'boolean)
(defcustom widget-image-conversion
'((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
(xbm ".xbm"))
"Conversion alist from image formats to file name suffixes."
:group 'widgets
:type '(repeat (cons :format "%v"
(symbol :tag "Image Format" unknown)
(repeat :tag "Suffixes"
(string :format "%v")))))
(defun widget-glyph-insert (widget tag image)
"In WIDGET, insert the text TAG or, if supported, IMAGE.
IMAGE should either be a glyph, or a name sans extension of an xpm or
xbm file located in `widget-glyph-directory'.
IMAGE should either be a glyph, an image instantiator, or an image file
name sans extension (xpm, xbm, gif, jpg, or png) located in
`widget-glyph-directory'.
WARNING: If you call this with a glyph, and you want the user to be
able to activate the glyph, make sure it is unique. If you use the
same glyph for multiple widgets, activating any of the glyphs will
cause the last created widget to be activated."
able to invoke the glyph, make sure it is unique. If you use the
same glyph for multiple widgets, invoking any of the glyphs will
cause the last created widget to be invoked."
(cond ((not (and (string-match "XEmacs" emacs-version)
widget-glyph-enable
(fboundp 'make-glyph)
(fboundp 'locate-file)
image))
;; We don't want or can't use glyphs.
(insert tag))
((and (fboundp 'glyphp)
(glyphp image))
;; Already a glyph. Insert it.
(widget-glyph-insert-glyph widget tag image))
(widget-glyph-insert-glyph widget image))
((stringp image)
;; A string. Look it up in relevant directories.
(let* ((dirlist (list (or widget-glyph-directory
(concat data-directory
"custom/"))
data-directory))
(formats widget-image-conversion)
file)
(while (and formats (not file))
(if (valid-image-instantiator-format-p (car (car formats)))
(setq file (locate-file image dirlist
(mapconcat 'identity (cdr (car formats))
":")))
(setq formats (cdr formats))))
;; We create a glyph with the file as the default image
;; instantiator, and the TAG fallback
(widget-glyph-insert-glyph
widget
(make-glyph (if file
(list (vector (car (car formats)) ':file file)
(vector 'string ':data tag))
(vector 'string ':data tag))))))
((valid-instantiator-p image 'image)
;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
(widget-glyph-insert-glyph
widget
(make-glyph (list image
(vector 'string ':data tag)))))
(t
;; A string. Look it up in.
(let ((file (concat widget-glyph-directory
(if (string-match "/\\'" widget-glyph-directory)
""
"/")
image
(if (featurep 'xpm) ".xpm" ".xbm"))))
(if (file-readable-p file)
(widget-glyph-insert-glyph widget tag (make-glyph file))
;; File not readable, give up.
(insert tag))))))
(defun widget-glyph-insert-glyph (widget tag glyph &optional down inactive)
;; Oh well.
(insert tag))))
(defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
"In WIDGET, with alternative text TAG, insert GLYPH."
(set-glyph-image glyph (cons 'tty tag))
(set-glyph-property glyph 'widget widget)
(when down
(set-glyph-image down (cons 'tty tag))
(set-glyph-property down 'widget widget))
(when inactive
(set-glyph-image inactive (cons 'tty tag))
(set-glyph-property inactive 'widget widget))
(insert "*")
(add-text-properties (1- (point)) (point)
......@@ -610,6 +637,30 @@ cause the last created widget to be activated."
help-echo
'widget-mouse-help))))))
;;; Buttons.
(defgroup widget-button nil
"The look of various kinds of buttons."
:group 'widgets)
(defcustom widget-button-prefix ""
"String used as prefix for buttons."
:type 'string
:group 'widgets)
(defcustom widget-button-suffix ""
"String used as suffix for buttons."
:type 'string
:group 'widgets)
(defun widget-button-insert-indirect (widget key)
"Insert value of WIDGET's KEY property."
(let ((val (widget-get widget key)))
(while (and val (symbolp val))
(setq val (symbol-value val)))
(when val
(insert val))))
;;; Creating Widgets.
;;;###autoload
......@@ -762,7 +813,7 @@ Recommended as a parent keymap for modes using widgets.")
(set-keymap-parent widget-text-keymap global-map))
(defun widget-field-activate (pos &optional event)
"Activate the ediable field at point."
"Invoke the ediable field at point."
(interactive "@d")
(let ((field (get-text-property pos 'field)))
(if field
......@@ -779,7 +830,7 @@ Recommended as a parent keymap for modes using widgets.")
:group 'widgets)
(defun widget-button-click (event)
"Activate button below mouse pointer."
"Invoke button below mouse pointer."
(interactive "@e")
(cond ((and (fboundp 'event-glyph)
(event-glyph event))
......@@ -828,7 +879,7 @@ Recommended as a parent keymap for modes using widgets.")
(message "You clicked somewhere weird."))))
(defun widget-button1-click (event)
"Activate glyph below mouse pointer."
"Invoke glyph below mouse pointer."
(interactive "@e")
(if (and (fboundp 'event-glyph)
(event-glyph event))
......@@ -863,7 +914,7 @@ Recommended as a parent keymap for modes using widgets.")
(widget-apply-action widget event)))))))
(defun widget-button-press (pos &optional event)
"Activate button at POS."
"Invoke button at POS."
(interactive "@d")
(let ((button (get-text-property pos 'button)))
(if button
......@@ -1136,6 +1187,8 @@ Optional EVENT is the event that triggered the action."
"Basic widget other widgets are derived from."
:value-to-internal (lambda (widget value) value)
:value-to-external (lambda (widget value) value)
:button-prefix 'widget-button-prefix
:button-suffix 'widget-button-suffix
:create 'widget-default-create
:indent nil
:offset 0
......@@ -1159,9 +1212,6 @@ Optional EVENT is the event that triggered the action."
"Create WIDGET at point in the current buffer."
(widget-specify-insert
(let ((from (point))
(tag (widget-get widget :tag))
(glyph (widget-get widget :tag-glyph))
(doc (widget-get widget :doc))
button-begin button-end
sample-begin sample-end
doc-begin doc-end
......@@ -1175,8 +1225,10 @@ Optional EVENT is the event that triggered the action."
(cond ((eq escape ?%)
(insert "%"))
((eq escape ?\[)
(setq button-begin (point)))
(setq button-begin (point))
(widget-button-insert-indirect widget :button-prefix))
((eq escape ?\])
(widget-button-insert-indirect widget :button-suffix)
(setq button-end (point)))
((eq escape ?\{)
(setq sample-begin (point)))
......@@ -1187,21 +1239,24 @@ Optional EVENT is the event that triggered the action."
(insert "\n")
(insert-char ? (widget-get widget :indent))))
((eq escape ?t)
(cond (glyph
(widget-glyph-insert widget (or tag "image") glyph))
(tag
(insert tag))
(t
(let ((standard-output (current-buffer)))
(princ (widget-get widget :value))))))
(let ((glyph (widget-get widget :tag-glyph))
(tag (widget-get widget :tag)))
(cond (glyph
(widget-glyph-insert widget (or tag "image") glyph))
(tag
(insert tag))
(t
(let ((standard-output (current-buffer)))
(princ (widget-get widget :value)))))))
((eq escape ?d)
(when doc
(setq doc-begin (point))
(insert doc)
(while (eq (preceding-char) ?\n)
(delete-backward-char 1))
(insert "\n")
(setq doc-end (point))))
(let ((doc (widget-get widget :doc)))
(when doc
(setq doc-begin (point))
(insert doc)
(while (eq (preceding-char) ?\n)
(delete-backward-char 1))
(insert "\n")
(setq doc-end (point)))))
((eq escape ?v)
(if (and button-begin (not button-end))
(widget-apply widget :value-create)
......@@ -1386,17 +1441,29 @@ Optional EVENT is the event that triggered the action."
;; Cache already created GUI objects.
(defvar widget-push-button-cache nil)
(defcustom widget-push-button-prefix "["
"String used as prefix for buttons."
:type 'string
:group 'widget-button)
(defcustom widget-push-button-suffix "]"
"String used as suffix for buttons."
:type 'string
:group 'widget-button)
(define-widget 'push-button 'item
"A pushable button."
:button-prefix ""
:button-suffix ""
:value-create 'widget-push-button-value-create
:text-format "[%s]"
:format "%[%v%]")
(defun widget-push-button-value-create (widget)
;; Insert text representing the `on' and `off' states.
(let* ((tag (or (widget-get widget :tag)
(widget-get widget :value)))
(text (format (widget-get widget :text-format) tag))
(text (concat widget-push-button-prefix
tag widget-push-button-suffix))
(gui (cdr (assoc tag widget-push-button-cache))))
(if (and (fboundp 'make-gui-button)
(fboundp 'make-glyph)
......@@ -1408,10 +1475,16 @@ Optional EVENT is the event that triggered the action."
(unless gui
(setq gui (make-gui-button tag 'widget-gui-action widget))
(push (cons tag gui) widget-push-button-cache))
(widget-glyph-insert-glyph widget text
(make-glyph (nth 0 (aref gui 1)))
(make-glyph (nth 1 (aref gui 1)))
(make-glyph (nth 2 (aref gui 1)))))
(widget-glyph-insert-glyph widget
(make-glyph
(list (nth 0 (aref gui 1))
(vector 'string ':data text)))
(make-glyph
(list (nth 1 (aref gui 1))
(vector 'string ':data text)))
(make-glyph
(list (nth 2 (aref gui 1))
(vector 'string ':data text)))))
(insert text))))
(defun widget-gui-action (widget)
......@@ -1420,10 +1493,22 @@ Optional EVENT is the event that triggered the action."
;;; The `link' Widget.
(defcustom widget-link-prefix "["
"String used as prefix for links."
:type 'string
:group 'widget-button)
(defcustom widget-link-suffix "]"
"String used as suffix for links."
:type 'string
:group 'widget-button)
(define-widget 'link 'item
"An embedded link."
:button-prefix 'widget-link-prefix
:button-suffix 'widget-link-suffix
:help-echo "Follow the link."
:format "%[_%t_%]")
:format "%[%t%]")
;;; The `info-link' Widget.
......@@ -1627,7 +1712,7 @@ Optional EVENT is the event that triggered the action."
(defcustom widget-choice-toggle nil
"If non-nil, a binary choice will just toggle between the values.
Otherwise, the user will explicitly have to choose between the values
when he activate the menu."
when he invoked the menu."
:type 'boolean
:group 'widgets)
......@@ -1756,6 +1841,8 @@ when he activate the menu."
(define-widget 'checkbox 'toggle
"A checkbox toggle."
:button-suffix ""
:button-prefix ""
:format "%[%v%]"
:on "[X]"
:on-glyph "check1"
......@@ -1940,6 +2027,8 @@ when he activate the menu."
"A radio button for use in the `radio' widget."
:notify 'widget-radio-button-notify
:format "%[%v%]"
:button-suffix ""
:button-prefix ""
:on "(*)"
:on-glyph "radio1"
:off "( )"
......@@ -2376,7 +2465,7 @@ when he activate the menu."
(define-widget 'widget-help 'push-button
"The widget documentation button."
:format "%[[%t]%] %d"
:format "%[%v%] %d"
:help-echo "Toggle display of documentation."
:action 'widget-help-action)
......@@ -2446,7 +2535,7 @@ when he activate the menu."
(define-widget 'file 'string
"A file widget.
It will read a file name from the minibuffer when activated."
It will read a file name from the minibuffer when invoked."
:prompt-value 'widget-file-prompt-value
:format "%{%t%}: %v"
:tag "File"
......@@ -2478,7 +2567,7 @@ It will read a file name from the minibuffer when activated."
(define-widget 'directory 'file
"A directory widget.
It will read a directory name from the minibuffer when activated."
It will read a directory name from the minibuffer when invoked."
:tag "Directory")
(defvar widget-symbol-prompt-value-history nil
......@@ -2755,11 +2844,14 @@ It will read a directory name from the minibuffer when activated."
:sample-face-get 'widget-color-item-button-face-get)
(defun widget-color-item-button-face-get (widget)
;; We create a face from the value.
(require 'facemenu)
(condition-case nil
(facemenu-get-face (intern (concat "fg:" (widget-value widget))))
(error 'default)))
(let ((symbol (intern (concat "fg:" (widget-value widget)))))
(if (string-match "XEmacs" emacs-version)
(prog1 symbol
(or (find-face symbol)
(set-face-foreground (make-face symbol) (widget-value widget))))
(condition-case nil
(facemenu-get-face symbol)
(error 'default)))))
(define-widget 'color 'push-button
"Choose a color name (with sample)."
......
......@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, extensions, faces, hypermedia
;; Version: 1.97
;; Version: 1.9900
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
......@@ -44,10 +44,10 @@
(set (car keywords) (car keywords)))
(setq keywords (cdr keywords)))))))
(define-widget-keywords :mouse-down-action :glyph-up :glyph-down
:glyph-inactive
(define-widget-keywords :button-prefix :button-suffix
:mouse-down-action :glyph-up :glyph-down :glyph-inactive
:prompt-internal :prompt-history :prompt-match
:prompt-value :text-format :deactivate :active
:prompt-value :deactivate :active
:inactive :activate :sibling-args :delete-button-args
:insert-button-args :append-button-args :button-args
:tag-glyph :off-glyph :on-glyph :valid-regexp
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment