;;; 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)
widget-shadow-subrs)
(defun widget-put (widget property value)
"In WIDGET set PROPERTY to VALUE.
-The value can later be retrived with `widget-get'."
+The value can later be retrieved with `widget-get'."
(setcdr widget (plist-put (cdr widget) property value))))
;; Recoded in C, for efficiency:
;; 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])))
(defun widget-button-click (event)
"Invoke button below mouse pointer."
- (interactive "@e")
- (cond ((event-glyph event)
- (widget-glyph-click event))
- ((widget-event-point event)
- (let* ((pos (widget-event-point event))
- (button (get-char-property pos 'button)))
- (if button
- (let* ((extent (widget-get button :button-extent))
- (face (extent-property extent 'face))
- (mouse-face (extent-property extent 'mouse-face))
- (help-echo (extent-property extent 'help-echo)))
- (unwind-protect
- (progn
- ;; Merge relevant faces, and make the result mouse-face.
- (let ((merge `(widget-button-pressed-face ,mouse-face)))
- (nconc merge (if (listp face)
- face (list face)))
- (setq merge (delete-if-not 'find-face merge))
- (set-extent-property extent 'mouse-face merge))
- (unless (widget-apply button :mouse-down-action event)
- ;; Wait for button release.
- (while (not (button-release-event-p
- (setq event (next-event))))
- (dispatch-event event)))
- ;; Disallow mouse-face and help-echo.
- (set-extent-property extent 'mouse-face nil)
- (set-extent-property extent 'help-echo nil)
- (setq pos (widget-event-point event))
- (unless (eq (current-buffer) (extent-object extent))
- ;; Barf if dispatch-event tripped us by
- ;; changing buffer.
- (error "Buffer changed during mouse motion"))
- ;; Do the associated action.
- (when (and pos (extent-in-region-p extent pos pos))
- (widget-apply-action button event)))
- ;; Unwinding: fully release the button.
- (set-extent-property extent 'mouse-face mouse-face)
- (set-extent-property extent 'help-echo help-echo)))
- ;; This should not happen!
- (error "`widget-button-click' called outside button"))))
- (t
- (message "You clicked somewhere weird"))))
+ (interactive "e")
+ (with-current-buffer (event-buffer event)
+ (cond ((event-glyph event)
+ (widget-glyph-click event))
+ ((widget-event-point event)
+ (let* ((pos (widget-event-point event))
+ (button (get-char-property pos 'button)))
+ (if button
+ (let* ((extent (widget-get button :button-extent))
+ (face (extent-property extent 'face))
+ (mouse-face (extent-property extent 'mouse-face))
+ (help-echo (extent-property extent 'help-echo)))
+ (unwind-protect
+ (progn
+ ;; Merge relevant faces, and make the result mouse-face.
+ (let ((merge `(widget-button-pressed-face ,mouse-face)))
+ (nconc merge (if (listp face)
+ face (list face)))
+ (setq merge (delete-if-not 'find-face merge))
+ (set-extent-property extent 'mouse-face merge))
+ (unless (widget-apply button :mouse-down-action event)
+ ;; Wait for button release.
+ (while (not (button-release-event-p
+ (setq event (next-event))))
+ (dispatch-event event)))
+ ;; Disallow mouse-face and help-echo.
+ (set-extent-property extent 'mouse-face nil)
+ (set-extent-property extent 'help-echo nil)
+ (setq pos (widget-event-point event))
+ (unless (eq (current-buffer) (extent-object extent))
+ ;; Barf if dispatch-event tripped us by
+ ;; changing buffer.
+ (error "Buffer changed during mouse motion"))
+ ;; Do the associated action.
+ (when (and pos (extent-in-region-p extent pos pos))
+ (widget-apply-action button event)))
+ ;; Unwinding: fully release the button.
+ (set-extent-property extent 'mouse-face mouse-face)
+ (set-extent-property extent 'help-echo help-echo)))
+ ;; This should not happen!
+ (error "`widget-button-click' called outside button"))))
+ (t
+ (message "You clicked somewhere weird")))))
(defun widget-button1-click (event)
"Invoke glyph below mouse pointer."
(error "This widget is inactive"))
(let ((current-glyph 'down))
;; We always know what glyph is drawn currently, to avoid
- ;; unnecessary extent changes. Is this any noticable gain?
+ ;; unnecessary extent changes. Is this any noticeable gain?
(unwind-protect
(progn
;; Press the glyph.
: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)
(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 gui (make-glyph
+ (make-gui-button tag 'widget-gui-action widget))))
+ (widget-glyph-insert-glyph widget gui))
(t
(insert text)))))
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