;;; wid-edit.el --- Functions for creating and using widgets.
;;
-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
+;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
;; Keywords: extensions
;; Version: 1.9960-x
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
:group 'hypermedia)
(defgroup widget-documentation nil
- "Options controling the display of documentation strings."
+ "Options controlling the display of documentation strings."
:group 'widgets)
(defgroup widget-faces nil
(and (functionp help-echo)
(setq help-echo (funcall help-echo widget)))
(when (stringp help-echo)
+ (setq help-echo-owns-message t)
(display-message 'help-echo help-echo))))
(defsubst widget-handle-help-echo (extent help-echo)
(let* ((glyph-widget (extent-property extent 'glyph-widget))
(up-glyph (widget-get glyph-widget :glyph-up))
(inactive-glyph (widget-get glyph-widget :glyph-inactive))
+ (instantiator (widget-get glyph-widget :glyph-instantiator))
(new-glyph (if activate-p up-glyph inactive-glyph)))
+ (cond
+ ;; Assume that an instantiator means a native widget.
+ (instantiator
+ (setq instantiator
+ (set-instantiator-property instantiator :active activate-p))
+ (widget-put glyph-widget :glyph-instantiator instantiator)
+ (set-glyph-image up-glyph instantiator))
;; Check that the new glyph exists, and differs from the
;; default one.
- (and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph))
- ;; Check if the glyph is already installed.
- (not (eq (extent-end-glyph extent) new-glyph))
- ;; Change it.
- (set-extent-end-glyph extent new-glyph)))))
+ ((and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph))
+ ;; Check if the glyph is already installed.
+ (not (eq (extent-end-glyph extent) new-glyph)))
+ ;; Change it.
+ (set-extent-end-glyph extent new-glyph))))))
nil)
(defun widget-specify-inactive (widget from to)
(defun widget-specify-active (widget)
"Make WIDGET active for user modifications."
- (let ((inactive (widget-get widget :inactive)))
+ (let ((inactive (widget-get widget :inactive))
+ (from (widget-get widget :from))
+ (to (widget-get widget :to)))
(when (and inactive (not (extent-detached-p inactive)))
;; Reactivate the buttons and fields covered by the extent.
(map-extents 'widget-activation-widget-mapper
- inactive nil nil :activate nil 'button-or-field)
+ nil from to :activate nil 'button-or-field)
;; Reactivate the glyphs.
(map-extents 'widget-activation-glyph-mapper
- inactive nil nil :activate nil 'end-glyph)
+ nil from to :activate nil 'end-glyph)
(delete-extent inactive)
(widget-put widget :inactive nil))))
value)))
(defun widget-member (widget property)
- "Non-nil iff there is a definition in WIDGET for PROPERTY."
+ "Return t if there is a definition in WIDGET for PROPERTY."
(cond ((widget-plist-member (cdr widget) property)
t)
((car widget)
;; In WIDGET, match the start of VALS.
(cond ((widget-get widget :inline)
(widget-apply widget :match-inline vals))
- ((and vals
+ ((and (listp vals)
(widget-apply widget :match (car vals)))
(cons (list (car vals)) (cdr vals)))
(t nil)))
:group 'widgets
:type 'boolean)
-(defcustom widget-image-conversion
+(defcustom widget-image-file-name-suffixes
'((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
(xbm ".xbm"))
"Conversion alist from image formats to file name suffixes."
(let* ((dirlist (cons (or widget-glyph-directory
(locate-data-directory "custom"))
data-directory-list))
- (formats widget-image-conversion)
- file)
- (while (and formats (not file))
- ;; This dance is necessary, because XEmacs signals an
- ;; error when it encounters an unrecognized image
- ;; format.
- (when (valid-image-instantiator-format-p (caar formats))
- (setq file (locate-file image dirlist
- (mapconcat #'identity (cdar formats)
- ":"))))
- (unless file
- (pop formats)))
+ (all-suffixes
+ (apply #'append
+ (mapcar
+ (lambda (el)
+ (and (valid-image-instantiator-format-p (car el))
+ (cdr el)))
+ widget-image-file-name-suffixes)))
+ (file (locate-file image dirlist all-suffixes)))
(when file
- ;; We create a glyph with the file as the default image
- ;; instantiator, and the TAG fallback
- (let ((glyph (make-glyph `([,(caar formats) :file ,file]
- [string :data ,tag]))))
- ;; Cache the glyph
- (laxputf widget-glyph-cache image glyph)
- ;; ...and return it
- glyph)))))
+ (let* ((extension (concat "." (file-name-extension file)))
+ (format (car (rassoc* extension
+ widget-image-file-name-suffixes
+ :test #'member))))
+ ;; We create a glyph with the file as the default image
+ ;; instantiator, and the TAG fallback
+ (let ((glyph (make-glyph `([,format :file ,file]
+ [string :data ,tag]))))
+ ;; Cache the glyph
+ (laxputf widget-glyph-cache image glyph)
+ ;; ...and return it
+ glyph))))))
((valid-instantiator-p image 'image)
;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
(make-glyph `(,image [string :data ,tag])))
(insert tag))
glyph))
-(defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
+(defun widget-glyph-insert-glyph (widget glyph &optional down inactive
+ instantiator)
"In WIDGET, insert GLYPH.
If optional arguments DOWN and INACTIVE are given, they should be
-glyphs used when the widget is pushed and inactive, respectively."
+glyphs used when the widget is pushed and inactive, respectively.
+INSTANTIATOR is the vector used to create the glyph."
(insert "*")
(let ((extent (make-extent (point) (1- (point))))
(help-echo (and widget (widget-get widget :help-echo)))
(when widget
(widget-put widget :glyph-up glyph)
(when down (widget-put widget :glyph-down down))
+ (when instantiator (widget-put widget :glyph-instantiator instantiator))
(when inactive (widget-put widget :glyph-inactive inactive))))
\f
(defun widget-field-activate (pos &optional event)
- "Invoke the ediable field at point."
+ "Invoke the editable field at point."
(interactive "@d")
(let ((field (widget-field-find pos)))
(if field
(t
(when (and (null arg)
(= last-non-space (point)))
- (forward-char -1))
+ (backward-char 1))
(transpose-chars arg)))))
(defcustom widget-complete-field (lookup-key global-map "\M-\t")
:group 'widgets
:type 'boolean)
-;; Cache already created GUI objects.
-(defvar widget-push-button-cache nil)
-
(defcustom widget-push-button-prefix "["
"String used as prefix for buttons."
:type 'string
(tag-glyph (widget-get widget :tag-glyph))
(text (concat widget-push-button-prefix
tag widget-push-button-suffix))
- (gui-glyphs (lax-plist-get widget-push-button-cache tag)))
+ gui inst)
(cond (tag-glyph
(widget-glyph-insert widget text tag-glyph))
;; We must check for console-on-window-system-p here,
;; components for colors, and they are not known on TTYs).
((and widget-push-button-gui
(console-on-window-system-p))
- (unless gui-glyphs
- (let* ((gui-button-shadow-thickness 1)
- (gui (make-gui-button tag 'widget-gui-action widget)))
- (setq
- gui-glyphs
- (list
- (make-glyph `(,(nth 0 (aref gui 1)) [string :data ,text]))
- (make-glyph `(,(nth 1 (aref gui 1)) [string :data ,text]))
- (make-glyph `(,(nth 2 (aref gui 1)) [string :data ,text]))))
- (laxputf widget-push-button-cache tag gui-glyphs)))
- (widget-glyph-insert-glyph
- widget (nth 0 gui-glyphs) (nth 1 gui-glyphs) (nth 2 gui-glyphs)))
+ (let* ((gui-button-shadow-thickness 1))
+ (setq inst (make-gui-button tag 'widget-gui-action widget))
+ (setq gui (make-glyph inst)))
+ (widget-glyph-insert-glyph widget gui nil nil inst))
(t
(insert text)))))
(defun widget-url-link-action (widget &optional event)
"Open the url specified by WIDGET."
- (if (boundp 'browse-url-browser-function)
- (funcall browse-url-browser-function (widget-value widget))
+ (if (fboundp 'browse-url)
+ (browse-url (widget-value widget))
(error "Cannot follow URLs in this XEmacs")))
;;; The `function-link' Widget.
found))
(defun widget-checklist-match-up (args vals)
- ;; Rerturn the first type from ARGS that matches VALS.
+ ;; Return the first type from ARGS that matches VALS.
(let (current found)
(while (and args (null found))
(setq current (car args)
result))
(defun widget-checklist-validate (widget)
- ;; Ticked chilren must be valid.
+ ;; Ticked children must be valid.
(let ((children (widget-get widget :children))
child button found)
(while (and children (not found))
projects / chise / xemacs-chise.git.1 / blobdiff