X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fwid-edit.el;h=aaa80ca74efe1f2ec0751d0c215122e57c86b8a0;hb=1a1aa5f685a384c2798f6e1dcb75132059acbd49;hp=a311bc4a6b256f9cb12cd02faf688928920d50aa;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index a311bc4..aaa80ca 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,9 +1,9 @@ ;;; 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 -;; Maintainer: Hrvoje Niksic +;; Maintainer: Hrvoje Niksic ;; Keywords: extensions ;; Version: 1.9960-x ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ @@ -49,7 +49,7 @@ :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 @@ -302,6 +302,7 @@ new value." (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) @@ -479,14 +480,22 @@ Suitable for use with `map-extents'." (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) @@ -511,14 +520,16 @@ Suitable for use with `map-extents'." (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)))) @@ -533,7 +544,7 @@ Suitable for use with `map-extents'." 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: @@ -565,7 +576,7 @@ Otherwise, just return the value." 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) @@ -600,7 +611,7 @@ ARGS are passed as extra arguments to the function." ;; 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))) @@ -673,7 +684,7 @@ automatically." :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." @@ -722,27 +733,27 @@ It can also be a valid image instantiator, in which case it will be (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]))) @@ -782,10 +793,12 @@ only because of compatibility." (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))) @@ -807,6 +820,7 @@ glyphs used when the widget is pushed and inactive, respectively." (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)))) @@ -1040,7 +1054,7 @@ Recommended as a parent keymap for modes using widgets.") (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 @@ -1063,48 +1077,49 @@ Recommended as a parent keymap for modes using widgets.") (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." @@ -1128,7 +1143,7 @@ Recommended as a parent keymap for modes using widgets.") (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. @@ -1346,7 +1361,7 @@ With optional ARG, move across that many fields." (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") @@ -1896,9 +1911,6 @@ If END is omitted, it defaults to the length of LIST." :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 @@ -1923,7 +1935,7 @@ If END is omitted, it defaults to the length of LIST." (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, @@ -1931,18 +1943,10 @@ If END is omitted, it defaults to the length of LIST." ;; 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))))) @@ -1995,8 +1999,8 @@ If END is omitted, it defaults to the length of LIST." (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. @@ -2530,7 +2534,7 @@ when he invoked the menu." 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) @@ -2552,7 +2556,7 @@ when he invoked the menu." 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))