X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgutter-items.el;h=8ac62f6c26b51692ac63a5c5ac4e315fb898b0b8;hb=9f7593526f487e8b5272d5aa2a72facbf121b23e;hp=777ddc398076eb7dd7dd43d14f24d8d3a68fa02a;hpb=76759ab036458c54499a454399e19602b8ae6ce3;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/gutter-items.el b/lisp/gutter-items.el index 777ddc3..8ac62f6 100644 --- a/lisp/gutter-items.el +++ b/lisp/gutter-items.el @@ -2,6 +2,7 @@ ;; Copyright (C) 1999 Free Software Foundation, Inc. ;; Copyright (C) 1999, 2000 Andy Piper. +;; Copyright (C) 2000 Ben Wing. ;; Maintainer: XEmacs Development Team ;; Keywords: frames, extensions, internal, dumped @@ -38,7 +39,8 @@ Do not set this. Use `set-glyph-image' to change the properties of the tab.") (defcustom gutter-buffers-tab-visible-p (gutter-element-visible-p default-gutter-visible-p 'buffers-tab) "Whether the buffers tab is globally visible. -This option should be set through the options menu." + +There are side-effects, so don't setq it; use Customize or the options menu." :group 'buffers-tab :type 'boolean :set #'(lambda (var val) @@ -46,11 +48,16 @@ This option should be set through the options menu." 'buffers-tab val) (setq gutter-buffers-tab-visible-p val))) +(defcustom gutter-buffers-tab-enabled t + "*Whether to enable support for buffers tab in the gutter. +This is different to `gutter-buffers-tab-visible-p' which still runs hooks +even when the gutter is invisible." + :group 'buffers-tab + :type 'boolean) + (defvar gutter-buffers-tab-orientation 'top "Where the buffers tab currently is. Do not set this.") -(defvar gutter-buffers-tab-extent nil) - (defcustom buffers-tab-max-size 6 "*Maximum number of entries which may appear on the \"Buffers\" tab. If this is 10, then only the ten most-recently-selected buffers will be @@ -69,24 +76,40 @@ a large number or nil will slow down tab responsiveness." :group 'buffers-tab) (defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers - "*If non-nil, a function specifying the buffers to omit from the buffers tab. + "*A function specifying the buffers to omit from the buffers tab, or nil. This is passed a buffer and should return non-nil if the buffer should be -omitted. The default value `buffers-tab-omit-invisible-buffers' omits +omitted. The default value `buffers-menu-omit-invisible-buffers' omits buffers that are normally considered \"invisible\" (those whose name begins with a space)." :type '(choice (const :tag "None" nil) function) :group 'buffers-tab) -(defcustom buffers-tab-selection-function 'select-buffers-tab-buffers-by-mode - "*If non-nil, a function specifying the buffers to select from the -buffers tab. This is passed two buffers and should return non-nil if -the second buffer should be selected. The default value -`select-buffers-tab-buffers-by-mode' groups buffers by major mode and -by `buffers-tab-grouping-regexp'." +(make-obsolete-variable 'buffers-tab-selection-function + 'buffers-tab-filter-functions) +(defcustom buffers-tab-selection-function nil + "*A function specifying buffers to display in the buffers tab, or nil. +Don't use this---it is never consulted. Use `buffers-tab-filter-functions' +instead. + +The function must take arguments (BUF1 BUF2). BUF1 is a candidate for +display in the buffers tab control. BUF2 is current (first in the buffers +list). Return non-nil if BUF1 should be added to the tab control." + :type '(choice function (const :tag "None" nil)) + :group 'buffers-tab) - :type '(choice (const :tag "None" nil) - function) +(defcustom buffers-tab-filter-functions '(select-buffers-tab-buffers-by-mode) + "*A list of functions specifying buffers to display in the buffers tab. + +If nil, all buffers are kept, up to `buffers-tab-max-size', in usual order. +Otherwise, each function in the list must take arguments (BUF1 BUF2). +BUF1 is the candidate, and BUF2 is the current buffer (first in the buffers +list). The function should return non-nil if BUF1 should be added to the +buffers tab. BUF1 will be omitted if any of the functions returns nil. + +Defaults to `select-buffers-tab-buffers-by-mode', which adds BUF1 if BUF1 and +BUF2 have the same major mode, or both match `buffers-tab-grouping-regexp'." + :type '(repeat function) :group 'buffers-tab) (defcustom buffers-tab-sort-function nil @@ -100,7 +123,7 @@ list in `buffer-list' order (usual most-recently-selected-first)." :group 'buffers-tab) (make-face 'buffers-tab "Face for displaying the buffers tab.") -(set-face-parent 'buffers-tab 'default) +(set-face-parent 'buffers-tab 'modeline) (defcustom buffers-tab-face 'buffers-tab "*Face to use for displaying the buffers tab." @@ -154,20 +177,18 @@ If this is 0, then the full buffer name will be shown." ;; that the current buffer is at the front of the buffers list. ;; for example, select an item and then do M-C-l ;; (switch-to-other-buffer). Things get way confused. - ;; - ;; Andy, if you want to maintain the current look, you must - ;; *uncouple* the gutter order and buffers order. (if (> (length (windows-of-buffer buffer)) 0) (select-window (car (windows-of-buffer buffer))) (switch-to-buffer buffer)))) -(defun select-buffers-tab-buffers-by-mode (buf1 buf2) +(defun select-buffers-tab-buffers-by-mode (buffer-to-select buf1) "For use as a value of `buffers-tab-selection-function'. This selects buffers by major mode `buffers-tab-grouping-regexp'." (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1))) - (mode2 (symbol-name (symbol-value-in-buffer 'major-mode buf2))) + (mode2 (symbol-name (symbol-value-in-buffer 'major-mode + buffer-to-select))) (modenm1 (symbol-value-in-buffer 'mode-name buf1)) - (modenm2 (symbol-value-in-buffer 'mode-name buf2))) + (modenm2 (symbol-value-in-buffer 'mode-name buffer-to-select))) (cond ((or (eq mode1 mode2) (eq modenm1 modenm2) (and (string-match "^[^-]+-" mode1) @@ -214,32 +235,25 @@ This just returns the buffer's name, optionally truncated." (when selected (setq selected nil)))) buffers))) -;;; #### SJT I'd really like this function to have just two hooks: (1) the -;;; buffer filter list and (2) a sort function list. Both should be lists -;;; of functions. Each filter takes two arguments: a buffer and a model -;;; buffer. (The model buffer argument allows selecting according to the -;;; mode or directory of that buffer.) The filter returns t if the buffer -;;; should be listed and nil otherwise. Effectively the filter amounts to -;;; the conjuction of the filter list. (Optionally the filter could take a -;;; frame instead of a buffer or generalize to a locale as in a specifier?) -;;; The filtering is done this way to preserve the ordering imposed by -;;; `buffer-list'. In addition, the in-deletion argument will be used the -;;; same way as in the current design. -;;; The list is checked for length and pruned according to least-recently- -;;; selected. (Optionally there could be some kind of sort function here, -;;; too.) -;;; Finally the list is sorted to gutter display order, and the tab data -;;; structure is created and returned. -;;; #### Docstring isn't very well expressed. +;;; #### SJT would like this function to have a sort function list. I +;;; don't see how this could work given that sorting is not +;;; cumulative --andyp. (defun buffers-tab-items (&optional in-deletion frame force-selection) - "This is the tab filter for the top-level buffers \"Buffers\" tab. -It dynamically creates a list of buffers to use as the contents of the tab. -Only the most-recently-used few buffers will be listed on the tab, for -efficiency reasons. You can control how many buffers will be shown by -setting `buffers-tab-max-size'. You can control the text of the tab -items by redefining the function `format-buffers-menu-line'." + "Return a list of tab instantiators based on the current buffers list. +This function is used as the tab filter for the top-level buffers +\"Buffers\" tab. It dynamically creates a list of tab instantiators +to use as the contents of the tab. The contents and order of the list +is controlled by `buffers-tab-filter-functions' which by default +groups buffers according to major mode and removes invisible buffers. +You can control how many buffers will be shown by setting +`buffers-tab-max-size'. You can control the text of the tab items by +redefining the function `format-buffers-menu-line'." (save-match-data - (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame))) + ;; NB it is too late if we run the omit function as part of the + ;; filter functions because we need to know which buffer is the + ;; context buffer before they get run. + (let* ((buffers (delete-if + buffers-tab-omit-function (buffer-list frame))) (first-buf (car buffers))) ;; maybe force the selected window (when (and force-selection @@ -251,16 +265,24 @@ items by redefining the function `format-buffers-menu-line'." (when in-deletion (setq buffers (delq (current-buffer) buffers)) (setq first-buf (car buffers))) - ;; select buffers in group (default is by mode) - (when buffers-tab-selection-function - (delete-if-not #'(lambda (buf) - (funcall buffers-tab-selection-function - first-buf buf)) buffers)) + ;; filter buffers + (when buffers-tab-filter-functions + (setq buffers + (delete-if + #'null + (mapcar #'(lambda (buf) + (let ((tmp-buf buf)) + (mapc #'(lambda (fun) + (unless (funcall fun buf first-buf) + (setq tmp-buf nil))) + buffers-tab-filter-functions) + tmp-buf)) + buffers)))) ;; maybe shorten list of buffers (and (integerp buffers-tab-max-size) (> buffers-tab-max-size 1) (> (length buffers) buffers-tab-max-size) - (setcdr (nthcdr buffers-tab-max-size buffers) nil)) + (setcdr (nthcdr (1- buffers-tab-max-size) buffers) nil)) ;; sort buffers in group (default is most-recently-selected) (when buffers-tab-sort-function (setq buffers (funcall buffers-tab-sort-function buffers))) @@ -271,14 +293,11 @@ items by redefining the function `format-buffers-menu-line'." (defun add-tab-to-gutter () "Put a tab control in the gutter area to hold the most recent buffers." (setq gutter-buffers-tab-orientation (default-gutter-position)) - (let ((gutter-string (copy-sequence "\n"))) - (unless gutter-buffers-tab-extent - (setq gutter-buffers-tab-extent (make-extent 0 1 gutter-string))) - (set-extent-begin-glyph - gutter-buffers-tab-extent - (setq gutter-buffers-tab - (make-glyph))) - + (let* ((gutter-string (copy-sequence "\n")) + (gutter-buffers-tab-extent (make-extent 0 1 gutter-string))) + (set-extent-begin-glyph gutter-buffers-tab-extent + (setq gutter-buffers-tab + (make-glyph))) ;; Nuke all existing tabs (remove-gutter-element top-gutter 'buffers-tab) (remove-gutter-element bottom-gutter 'buffers-tab) @@ -300,63 +319,67 @@ items by redefining the function `format-buffers-menu-line'." ((eq gutter-buffers-tab-orientation 'left) (set-specifier left-gutter-border-width 0 'global x) (set-gutter-element left-gutter 'buffers-tab - gutter-string 'global x) - (set-specifier left-gutter-width - (glyph-width gutter-buffers-tab) - 'global x)) + gutter-string 'global x)) ((eq gutter-buffers-tab-orientation 'right) (set-specifier right-gutter-border-width 0 'global x) (set-gutter-element right-gutter 'buffers-tab - gutter-string 'global x) - (set-specifier right-gutter-width - (glyph-width gutter-buffers-tab) - 'global x)) + gutter-string 'global x)) ))) (console-type-list)))) (defun update-tab-in-gutter (frame &optional force-selection) "Update the tab control in the gutter area." ;; dedicated frames don't get tabs - (unless (window-dedicated-p (frame-selected-window frame)) + (unless (or (window-dedicated-p (frame-selected-window frame)) + (frame-property frame 'popup)) (when (specifier-instance default-gutter-visible-p frame) (unless (and gutter-buffers-tab (eq (default-gutter-position) gutter-buffers-tab-orientation)) (add-tab-to-gutter)) (when (valid-image-instantiator-format-p 'tab-control frame) - (set-glyph-image - gutter-buffers-tab - (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face - :orientation gutter-buffers-tab-orientation - (if (or (eq gutter-buffers-tab-orientation 'top) - (eq gutter-buffers-tab-orientation 'bottom)) - :pixel-width :pixel-height) - (if (or (eq gutter-buffers-tab-orientation 'top) - (eq gutter-buffers-tab-orientation 'bottom)) - '(gutter-pixel-width) '(gutter-pixel-height)) - :properties - (list :items - (buffers-tab-items nil frame force-selection))) - frame))))) + (let ((items (buffers-tab-items nil frame force-selection))) + (when items + (set-glyph-image + gutter-buffers-tab + (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face + :orientation gutter-buffers-tab-orientation + (if (or (eq gutter-buffers-tab-orientation 'top) + (eq gutter-buffers-tab-orientation 'bottom)) + :pixel-width :pixel-height) + (if (or (eq gutter-buffers-tab-orientation 'top) + (eq gutter-buffers-tab-orientation 'bottom)) + '(gutter-pixel-width) '(gutter-pixel-height)) + :items items) + frame) + ;; set-glyph-image will not make the gutter dirty + (set-gutter-dirty-p gutter-buffers-tab-orientation))))))) ;; A myriad of different update hooks all doing slightly different things -(add-hook 'create-frame-hook - #'(lambda (frame) - (when gutter-buffers-tab (update-tab-in-gutter frame t)))) -(add-hook 'buffer-list-changed-hook 'update-tab-in-gutter) -(add-hook 'default-gutter-position-changed-hook - #'(lambda () - (when gutter-buffers-tab - (mapc #'update-tab-in-gutter (frame-list))))) -(add-hook 'gutter-element-visibility-changed-hook - #'(lambda (prop visible-p) - (when (and (eq prop 'buffers-tab) visible-p) - (mapc #'update-tab-in-gutter (frame-list))))) +(add-one-shot-hook + 'after-init-hook + #'(lambda () + ;; don't add the hooks if the user really doesn't want them + (when gutter-buffers-tab-enabled + (add-hook 'create-frame-hook + #'(lambda (frame) + (when gutter-buffers-tab (update-tab-in-gutter frame t)))) + (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter) + (add-hook 'default-gutter-position-changed-hook + #'(lambda () + (when gutter-buffers-tab + (mapc #'update-tab-in-gutter (frame-list))))) + (add-hook 'gutter-element-visibility-changed-hook + #'(lambda (prop visible-p) + (when (and (eq prop 'buffers-tab) visible-p) + (mapc #'update-tab-in-gutter (frame-list))))) + (update-tab-in-gutter (selected-frame) t)))) + ;; ;; progress display ;; ripped off from message display ;; -(defcustom progress-display-use-echo-area nil +(defcustom progress-feedback-use-echo-area nil "*Whether progress gauge display should display in the echo area. If NIL then progress gauges will be displayed with whatever native widgets are available on the current console. If non-NIL then progress display will be @@ -367,84 +390,84 @@ textual and displayed in the echo area." (defvar progress-glyph-height 24 "Height of the progress gauge glyph.") -(defvar progress-display-popup-period 0.5 +(defvar progress-feedback-popup-period 0.5 "The time that the progress gauge should remain up after completion") -;; private variables -(defvar progress-text-glyph - (make-glyph [string :data ""])) - -(defvar progress-layout-glyph nil) -(defvar progress-gauge-glyph - (make-glyph - `[progress-gauge - :pixel-height (eval progress-glyph-height) - :pixel-width 250 - :descriptor "Progress"])) - -(defun set-progress-display-style (style) - "Control the appearance of the progress gauge. -If STYLE is 'large, the default, then the progress-display text is -displayed above the gauge itself. If STYLE is 'small then the gauge -and text are arranged side-by-side." - (cond - ((eq style 'small) - (setq progress-glyph-height 16) - (setq progress-layout-glyph - (make-glyph - `[layout - :orientation horizontal - :margin-width 4 - :items (,progress-gauge-glyph - [button - :pixel-height (eval progress-glyph-height) - ;; 'quit is special and acts "asynchronously". - :descriptor "Stop" :callback 'quit] - ,progress-text-glyph)]))) - (t - (setq progress-glyph-height 24) - (setq progress-layout-glyph - (make-glyph - `[layout - :orientation vertical :justify left - :margin-width 4 - :items (,progress-text-glyph - [layout - :orientation horizontal - :items (,progress-gauge-glyph - [button - :pixel-height (eval progress-glyph-height) - :descriptor " Stop " - ;; 'quit is special and acts "asynchronously". - :callback 'quit])])]))))) - -(defcustom progress-display-style 'large +(defcustom progress-feedback-style 'large "*Control the appearance of the progress gauge. -If 'large, the default, then the progress-display text is displayed +If 'large, the default, then the progress-feedback text is displayed above the gauge itself. If 'small then the gauge and text are arranged side-by-side." :group 'gutter :type '(choice (const :tag "large" large) - (const :tag "small" small)) - :set #'(lambda (var val) - (set-progress-display-style val))) + (const :tag "small" small))) + +;; private variables +(defvar progress-text-instantiator [string :data ""]) +(defvar progress-layout-glyph (make-glyph)) +(defvar progress-layout-instantiator nil) + +(defvar progress-gauge-instantiator + [progress-gauge + :value 0 + :pixel-height (eval progress-glyph-height) + :pixel-width 250 + :descriptor "Progress"]) + +(defun set-progress-feedback-instantiator (&optional locale) + (cond + ((eq progress-feedback-style 'small) + (setq progress-glyph-height 16) + (setq progress-layout-instantiator + `[layout + :orientation vertical :margin-width 4 + :horizontally-justify left :vertically-justify center + :items (,progress-gauge-instantiator + [button + :pixel-height (eval progress-glyph-height) + ;; 'quit is special and acts "asynchronously". + :descriptor "Stop" :callback 'quit] + ,progress-text-instantiator)]) + (set-glyph-image progress-layout-glyph progress-layout-instantiator + locale)) + (t + (setq progress-glyph-height 24) + (setq progress-layout-instantiator + `[layout + :orientation vertical :margin-width 4 + :horizontally-justify left :vertically-justify center + :items (,progress-text-instantiator + [layout + :orientation horizontal + :items (,progress-gauge-instantiator + [button + :pixel-height (eval progress-glyph-height) + :descriptor " Stop " + ;; 'quit is special and acts "asynchronously". + :callback 'quit])])]) + (set-glyph-image progress-layout-glyph progress-layout-instantiator + locale)))) + +(defvar progress-abort-glyph (make-glyph)) + +(defun set-progress-abort-instantiator (&optional locale) + (set-glyph-image progress-abort-glyph + `[layout :orientation vertical + :horizontally-justify left :vertically-justify center + :items (,progress-text-instantiator + [layout + :margin-width 4 + :pixel-height progress-glyph-height + :orientation horizontal])] + locale)) (defvar progress-stack nil "An alist of label/string pairs representing active progress gauges. The first element in the list is currently displayed in the gutter area. -Do not modify this directly--use the `progress-display' or -`display-progress-display'/`clear-progress-display' functions.") - -(defvar progress-abort-glyph - (make-glyph - `[layout :orientation vertical :justify left - :items (,progress-text-glyph - [layout - :margin-width 4 - :pixel-height progress-glyph-height - :orientation horizontal])])) - -(defun progress-displayed-p (&optional return-string frame) +Do not modify this directly--use the `progress-feedback' or +`display-progress-feedback'/`clear-progress-feedback' functions.") + +(defun progress-feedback-displayed-p (&optional return-string frame) "Return a non-nil value if a progress gauge is presently displayed in the gutter area. If optional argument RETURN-STRING is non-nil, return a string containing the message, otherwise just return t." @@ -456,7 +479,7 @@ return a string containing the message, otherwise just return t." ;;; Returns the string which remains in the echo area, or nil if none. ;;; If label is nil, the whole message stack is cleared. -(defun clear-progress-display (&optional label frame no-restore) +(defun clear-progress-feedback (&optional label frame no-restore) "Remove any progress gauge with LABEL from the progress gauge-stack, erasing it from the gutter area if it's currently displayed there. If a message remains at the head of the progress-stack and NO-RESTORE @@ -467,10 +490,10 @@ If LABEL is nil, the entire progress-stack is cleared. Unless you need the return value or you need to specify a label, you should just use (progress nil)." (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame)) - progress-display-use-echo-area) + progress-feedback-use-echo-area) (clear-message label frame nil no-restore) (or frame (setq frame (selected-frame))) - (remove-progress-display label frame) + (remove-progress-feedback label frame) (let ((inhibit-read-only t) (zmacs-region-stays zmacs-region-stays)) ; preserve from change (erase-buffer (get-buffer-create " *Gutter Area*"))) @@ -478,19 +501,19 @@ you should just use (progress nil)." nil ; just preparing to put another msg up (if progress-stack (let ((oldmsg (cdr (car progress-stack)))) - (raw-append-progress-display oldmsg nil frame) + (raw-append-progress-feedback oldmsg nil frame) oldmsg) ;; nothing to display so get rid of the gauge (set-specifier bottom-gutter-border-width 0 frame) (set-gutter-element-visible-p bottom-gutter-visible-p 'progress nil frame))))) -(defun progress-display-clear-when-idle (&optional label) +(defun progress-feedback-clear-when-idle (&optional label) (add-one-shot-hook 'pre-idle-hook `(lambda () - (clear-progress-display ',label)))) + (clear-progress-feedback ',label)))) -(defun remove-progress-display (&optional label frame) +(defun remove-progress-feedback (&optional label frame) ;; If label is nil, we want to remove all matching progress gauges. (while (and progress-stack (or (null label) ; null label means clear whole stack @@ -504,7 +527,7 @@ you should just use (progress nil)." (setcdr s (cdr (cdr s)))) (setq s (cdr s))))))) -(defun progress-display-dispatch-non-command-events () +(defun progress-feedback-dispatch-non-command-events () ;; don't allow errors to hose things (condition-case t ;; (sit-for 0) is too agressive and cause more display than we @@ -512,7 +535,7 @@ you should just use (progress nil)." (dispatch-non-command-events) nil)) -(defun append-progress-display (label message &optional value frame) +(defun append-progress-feedback (label message &optional value frame) (or frame (setq frame (selected-frame))) ;; Add a new entry to the message-stack, or modify an existing one (let* ((top (car progress-stack)) @@ -521,25 +544,22 @@ you should just use (progress nil)." (progn (setcdr top message) (if (equal tmsg message) - ;; #### use of set-image-instance-property is wrong. - ;; use set-glyph-image instead. - (set-image-instance-property - (glyph-image-instance progress-gauge-glyph - (frame-selected-window frame)) - :value value) - (raw-append-progress-display message value frame)) + (progn + (set-instantiator-property progress-gauge-instantiator :value value) + (set-progress-feedback-instantiator (frame-selected-window frame))) + (raw-append-progress-feedback message value frame)) (redisplay-gutter-area)) (push (cons label message) progress-stack) - (raw-append-progress-display message value frame)) - (progress-display-dispatch-non-command-events) + (raw-append-progress-feedback message value frame)) + (progress-feedback-dispatch-non-command-events) ;; either get command events or sit waiting for them (when (eq value 100) -; (sit-for progress-display-popup-period nil) - (clear-progress-display label)))) +; (sit-for progress-feedback-popup-period nil) + (clear-progress-feedback label)))) -(defun abort-progress-display (label message &optional frame) +(defun abort-progress-feedback (label message &optional frame) (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame)) - progress-display-use-echo-area) + progress-feedback-use-echo-area) (display-message label (concat message "aborted.") frame) (or frame (setq frame (selected-frame))) ;; Add a new entry to the message-stack, or modify an existing one @@ -558,24 +578,21 @@ you should just use (progress nil)." ;; fixup the gutter specifiers (set-gutter-element bottom-gutter 'progress gutter-string frame) (set-specifier bottom-gutter-border-width 2 frame) - ;; #### use of set-image-instance-property is wrong. - ;; use set-glyph-image instead. - (set-image-instance-property - (glyph-image-instance progress-text-glyph - (frame-selected-window frame)) :data message) + (set-instantiator-property progress-text-instantiator :data message) + (set-progress-abort-instantiator (frame-selected-window frame)) (set-specifier bottom-gutter-height 'autodetect frame) (set-gutter-element-visible-p bottom-gutter-visible-p 'progress t frame) ;; we have to do this so redisplay is up-to-date and so ;; redisplay-gutter-area performs optimally. (redisplay-gutter-area) - (sit-for progress-display-popup-period nil) - (clear-progress-display label frame) + (sit-for progress-feedback-popup-period nil) + (clear-progress-feedback label frame) (set-extent-begin-glyph ext progress-layout-glyph) (set-gutter-element bottom-gutter 'progress gutter-string frame) ))))) -(defun raw-append-progress-display (message &optional value frame) +(defun raw-append-progress-feedback (message &optional value frame) (unless (equal message "") (let* ((inhibit-read-only t) (zmacs-region-stays zmacs-region-stays) @@ -588,15 +605,11 @@ you should just use (progress nil)." ;; fixup the gutter specifiers (set-gutter-element bottom-gutter 'progress gutter-string frame) (set-specifier bottom-gutter-border-width 2 frame) - ;; #### use of set-image-instance-property is wrong. - ;; use set-glyph-image instead. - (set-image-instance-property - (glyph-image-instance progress-gauge-glyph - (frame-selected-window frame)) - :value val) - (set-image-instance-property - (glyph-image-instance progress-text-glyph (frame-selected-window frame)) - :data message) + (set-instantiator-property progress-gauge-instantiator :value val) + (set-progress-feedback-instantiator (frame-selected-window frame)) + + (set-instantiator-property progress-text-instantiator :data message) + (set-progress-feedback-instantiator (frame-selected-window frame)) (if (and (eq (specifier-instance bottom-gutter-height frame) 'autodetect) (gutter-element-visible-p bottom-gutter-visible-p @@ -605,7 +618,7 @@ you should just use (progress nil)." ;; checking for user events (progn (redisplay-gutter-area) - (progress-display-dispatch-non-command-events)) + (progress-feedback-dispatch-non-command-events)) ;; otherwise make the gutter visible and redraw the frame (set-specifier bottom-gutter-height 'autodetect frame) (set-gutter-element-visible-p bottom-gutter-visible-p @@ -613,36 +626,36 @@ you should just use (progress nil)." ;; we have to do this so redisplay is up-to-date and so ;; redisplay-gutter-area performs optimally. This may also ;; make sure the frame geometry looks ok. - (progress-display-dispatch-non-command-events) + (progress-feedback-dispatch-non-command-events) (redisplay-frame frame) )))) -(defun display-progress-display (label message &optional value frame) +(defun display-progress-feedback (label message &optional value frame) "Display a progress gauge and message in the bottom gutter area. First argument LABEL is an identifier for this message. MESSAGE is -the string to display. Use `clear-progress-display' to remove a labelled +the string to display. Use `clear-progress-feedback' to remove a labelled message." (cond ((eq value 'abort) - (abort-progress-display label message frame)) + (abort-progress-feedback label message frame)) ((or (not (valid-image-instantiator-format-p 'progress-gauge frame)) - progress-display-use-echo-area) + progress-feedback-use-echo-area) (display-message label (concat message (if (eq value 100) "done." (make-string (/ value 5) ?.))) frame)) (t - (append-progress-display label message value frame)))) + (append-progress-feedback label message value frame)))) -(defun current-progress-display (&optional frame) +(defun current-progress-feedback (&optional frame) "Return the current progress gauge in the gutter area, or nil. The FRAME argument is currently unused." (cdr (car progress-stack))) ;;; may eventually be frame-dependent -(defun current-progress-display-label (&optional frame) +(defun current-progress-feedback-label (&optional frame) (car (car progress-stack))) -(defun progress-display (fmt &optional value &rest args) +(defun progress-feedback (fmt &optional value &rest args) "Print a progress gauge and message in the bottom gutter area of the frame. The arguments are the same as to `format'. @@ -650,89 +663,26 @@ If the only argument is nil, clear any existing progress gauge." (save-excursion (if (and (null fmt) (null args)) (prog1 nil - (clear-progress-display nil)) + (clear-progress-feedback nil)) (let ((str (apply 'format fmt args))) - (display-progress-display 'progress str value) + (display-progress-feedback 'progress str value) str)))) -(defun lprogress-display (label fmt &optional value &rest args) +(defun progress-feedback-with-label (label fmt &optional value &rest args) "Print a progress gauge and message in the bottom gutter area of the frame. -First argument LABEL is an identifier for this progress gauge. The rest of the -arguments are the same as to `format'." +LABEL is an identifier for this progress gauge. +FMT is a format string to be passed to `format' along with ARGS. +Optional VALUE is the current degree of progress, an integer 0-100. +The remaining ARGS are passed with FMT `(apply #'format FMT ARGS)'." ;; #### sometimes the buffer gets changed temporarily. I don't know ;; why this is, so protect against it. (save-excursion (if (and (null fmt) (null args)) (prog1 nil - (clear-progress-display label nil)) + (clear-progress-feedback label nil)) (let ((str (apply 'format fmt args))) - (display-progress-display label str value) + (display-progress-feedback label str value) str)))) -;; -;; Simple search dialog -;; -(defvar search-dialog-direction t) -(defvar search-dialog-text - (make-glyph - [edit-field :width 15 :descriptor "" :active t :face default])) - -(defun search-dialog-callback (parent image-instance event) - (save-selected-frame - (select-frame parent) - (funcall (if search-dialog-direction - 'search-forward 'search-backward) - (image-instance-property - (glyph-image-instance search-dialog-text - (frame-selected-window - (event-channel event))) :text)) - (isearch-highlight (match-beginning 0) (match-end 0)))) - -(defun make-search-dialog () - "Popup a search dialog box." - (interactive) - (let* ((parent (selected-frame))) - (set-buffer-dedicated-frame - (get-buffer-create "Dialog") - (make-dialog-box - (make-glyph - `[layout - :orientation horizontal :justify left - :height 10 :width 40 - :border [string :data "Search"] - :items - ([layout :orientation vertical :justify left - :items - ([string :data "Search for:"] - [button :descriptor "Match case" - :style toggle - :selected (not case-fold-search) - :callback (setq case-fold-search - (not case-fold-search))] - [button :descriptor "Forwards" - :style radio - :selected search-dialog-direction - :callback (setq search-dialog-direction t)] - [button :descriptor "Backwards" - :style radio - :selected (not search-dialog-direction) - :callback (setq search-dialog-direction nil)] - )] - [layout :orientation vertical :justify left - :items - (search-dialog-text - [button :width 10 :descriptor "Find Next" - :callback-ex - (lambda (image-instance event) - (search-dialog-callback ,parent - image-instance event))] - [button :width 10 :descriptor "Cancel" - :callback-ex - (lambda (image-instance event) - (isearch-dehighlight) - (delete-frame - (event-channel event)))])])]) - '(height 10 width 40))))) - (provide 'gutter-items) ;;; gutter-items.el ends here.