Mercurial > emacs
diff lisp/wid-edit.el @ 18033:bccd356a3b7c
Synched with version 1.9900.
author | Per Abrahamsen <abraham@dina.kvl.dk> |
---|---|
date | Fri, 30 May 1997 00:39:40 +0000 |
parents | 0df9495348e7 |
children | 9e0c7dffc231 |
line wrap: on
line diff
--- a/lisp/wid-edit.el Thu May 29 23:27:40 1997 +0000 +++ b/lisp/wid-edit.el Fri May 30 00:39:40 1997 +0000 @@ -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 @@ (: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 @@ (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 @@ :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)))))) + ;; Oh well. + (insert tag)))) -(defun widget-glyph-insert-glyph (widget tag glyph &optional down inactive) +(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 @@ 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 @@ (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 @@ :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 @@ (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 @@ (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 @@ "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 @@ "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 @@ (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 @@ (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 @@ ;; 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 @@ (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 @@ ;;; 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 @@ (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 @@ (define-widget 'checkbox 'toggle "A checkbox toggle." + :button-suffix "" + :button-prefix "" :format "%[%v%]" :on "[X]" :on-glyph "check1" @@ -1940,6 +2027,8 @@ "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 @@ (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 @@ (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 @@ (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 @@ :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)."