X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgutter-items.el;h=8ac62f6c26b51692ac63a5c5ac4e315fb898b0b8;hb=d6e1720d3ff092d6d49fa42546089ccae66babb5;hp=9581a49c4b7e7045f7bd12e6c4b81e733f4de0bd;hpb=3890a2e3064a7f562107c58e59d928284ec04741;p=chise%2Fxemacs-chise.git.1

diff --git a/lisp/gutter-items.el b/lisp/gutter-items.el
index 9581a49..8ac62f6 100644
--- a/lisp/gutter-items.el
+++ b/lisp/gutter-items.el
@@ -1,7 +1,8 @@
 ;;; gutter-items.el --- Gutter content for XEmacs.
 
 ;; Copyright (C) 1999 Free Software Foundation, Inc.
-;; Copyright (C) 1999 Andy Piper.
+;; Copyright (C) 1999, 2000 Andy Piper.
+;; Copyright (C) 2000 Ben Wing.
 
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: frames, extensions, internal, dumped
@@ -24,53 +25,39 @@
 ;; Boston, MA 02111-1307, USA.
 
 ;; Some of this is taken from the buffer-menu stuff in menubar-items.el
-;; and the custom specs in toolbar.el.
 
-(defgroup gutter nil
-  "Input from the gutters."
-  :group 'environment)
+;;; The Buffers tab
+
+(defgroup buffers-tab nil
+  "Customization of `Buffers' tab."
+  :group 'gutter)
 
 (defvar gutter-buffers-tab nil
   "A tab widget in the gutter for displaying buffers.
-Do not set this. Use `glyph-image-instance' and
-`set-image-instance-property' to change the properties of the tab.")
+Do not set this. Use `set-glyph-image' to change the properties of the tab.")
 
-(defcustom gutter-visible-p 
-  (specifier-instance default-gutter-visible-p)
-  "Whether the default gutter is globally visible. This option can be
-customized through the options menu."
-  :group 'gutter
+(defcustom gutter-buffers-tab-visible-p
+  (gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
+  "Whether the buffers tab is globally visible. 
+
+There are side-effects, so don't setq it; use Customize or the options menu."
+  :group 'buffers-tab
   :type 'boolean
   :set #'(lambda (var val)
-	   (set-specifier default-gutter-visible-p val)
-	   (setq gutter-visible-p val)
-	   (when gutter-buffers-tab (update-tab-in-gutter))))
-
-(defcustom default-gutter-position
-  (default-gutter-position)
-  "The location of the default gutter. It can be 'top, 'bottom, 'left or
-'right. This option can be customized through the options menu."
-  :group 'gutter
-  :type '(choice (const :tag "top" top)
-		 (const :tag "bottom" bottom)
-		 (const :tag "left" left)
-		 (const :tag "right" right))
-  :set #'(lambda (var val)
-	   (set-default-gutter-position val)
-	   (setq default-gutter-position val)
-	   (when gutter-buffers-tab (update-tab-in-gutter))))
-
-;;; The Buffers tab
-
-(defgroup buffers-tab nil
-  "Customization of `Buffers' tab."
-  :group 'gutter)
+	   (set-gutter-element-visible-p default-gutter-visible-p 
+					 '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
@@ -89,28 +76,54 @@ 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
+(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)
+
+(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
   "*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'."
+buffers tab.  This is passed the buffer list and returns the list in the
+order desired for the tab widget.  The default value `nil' leaves the
+list in `buffer-list' order (usual most-recently-selected-first)."
 
   :type '(choice (const :tag "None" nil)
 		 function)
   :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."
@@ -159,17 +172,23 @@ If this is 0, then the full buffer name will be shown."
 (defun buffers-tab-switch-to-buffer (buffer)
   "For use as a value for `buffers-tab-switch-to-buffer-function'."
   (unless (eq (window-buffer) buffer)
+    ;; this used to add the norecord flag to both calls below.
+    ;; this is bogus because it is a pervasive assumption in XEmacs
+    ;; 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.
     (if (> (length (windows-of-buffer buffer)) 0)
-	(select-window (car (windows-of-buffer buffer)) t)
-      (switch-to-buffer buffer t))))
+	(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)
@@ -203,179 +222,252 @@ This just returns the buffer's name, optionally truncated."
       (buffer-name buffer))))
 
 (defsubst build-buffers-tab-internal (buffers)
-  (let (line)
+  (let ((selected t))
     (mapcar
      #'(lambda (buffer)
-	 (setq line (funcall buffers-tab-format-buffer-line-function
-			     buffer))
-	 (vector line (list buffers-tab-switch-to-buffer-function
-			    (buffer-name buffer))))
+	 (prog1
+	     (vector 
+	      (funcall buffers-tab-format-buffer-line-function
+		       buffer)
+	      (list buffers-tab-switch-to-buffer-function
+		    (buffer-name buffer))
+	      :selected selected)
+	   (when selected (setq selected nil))))
      buffers)))
 
-(defun buffers-tab-items (&optional in-deletion frame)
-  "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'."
+;;; #### 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)
+  "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
+		 (not in-deletion)
+		 (not (eq first-buf (window-buffer (selected-window frame)))))
+	(setq buffers (cons (window-buffer (selected-window frame))
+			    (delq first-buf buffers))))
       ;; if we're in deletion ignore the current buffer
       (when in-deletion 
 	(setq buffers (delq (current-buffer) buffers))
 	(setq first-buf (car buffers)))
-      ;; group buffers 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)
-	   ;; shorten list of buffers
-	   (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)))
+      ;; convert list of buffers to list of structures used by tab widget
       (setq buffers (build-buffers-tab-internal buffers))
       buffers)))
 
 (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 ""))
-    (unless gutter-buffers-tab-extent
-      (setq gutter-buffers-tab-extent (make-extent 0 0 gutter-string)))
-    (set-extent-begin-glyph 
-     gutter-buffers-tab-extent
-     (setq gutter-buffers-tab 
-	   (make-glyph 
-	    (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
-		    :orientation gutter-buffers-tab-orientation
-		    :properties (list :items (buffers-tab-items))))))
-    ;; This looks better than a 3d border
-    (mapcar '(lambda (x)
-	       (when (valid-image-instantiator-format-p 'tab-control x)
-		 (set-specifier default-gutter-border-width 0 'global x)
-		 (set-specifier top-gutter nil 'global x)
-		 (set-specifier bottom-gutter nil 'global x)
-		 (set-specifier left-gutter nil 'global x)
-		 (set-specifier right-gutter nil 'global x)
-		 (set-specifier left-gutter-width 0 'global x)
-		 (set-specifier right-gutter-width 0 'global x)
-		 (cond ((eq gutter-buffers-tab-orientation 'top)
-			(set-specifier top-gutter gutter-string 'global x))
-		       ((eq gutter-buffers-tab-orientation 'bottom)
-			(set-specifier bottom-gutter gutter-string 'global x))
-		       ((eq gutter-buffers-tab-orientation 'left)
-			(set-specifier left-gutter gutter-string 'global x)
-			(set-specifier left-gutter-width
-				       (glyph-width gutter-buffers-tab)
-				       'global x))
-		       ((eq gutter-buffers-tab-orientation 'right)
-			(set-specifier right-gutter gutter-string 'global x)
-			(set-specifier right-gutter-width
-				       (glyph-width gutter-buffers-tab)
-				       'global x))
-		       )))
-	    (console-type-list))))
-
-(defun update-tab-in-gutter (&optional frame-or-buffer)
+  (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)
+    (remove-gutter-element left-gutter 'buffers-tab)
+    (remove-gutter-element right-gutter 'buffers-tab)
+    ;; Put tabs into all devices that will be able to display them
+    (mapcar
+     #'(lambda (x)
+	 (when (valid-image-instantiator-format-p 'tab-control x)
+	   (cond ((eq gutter-buffers-tab-orientation 'top)
+		  ;; This looks better than a 3d border
+		  (set-specifier top-gutter-border-width 0 'global x)
+		  (set-gutter-element top-gutter 'buffers-tab 
+				      gutter-string 'global x))
+		 ((eq gutter-buffers-tab-orientation 'bottom)
+		  (set-specifier bottom-gutter-border-width 0 'global x)
+		  (set-gutter-element bottom-gutter 'buffers-tab
+				      gutter-string 'global x))
+		 ((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))
+		 ((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))
+		 )))
+     (console-type-list))))
+
+(defun update-tab-in-gutter (frame &optional force-selection)
   "Update the tab control in the gutter area."
-  (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
-    (when (specifier-instance default-gutter-visible-p locale)
-      (unless (and gutter-buffers-tab 
+    ;; dedicated frames don't get tabs
+  (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 locale)
-	(let ((inst (glyph-image-instance 
-		     gutter-buffers-tab
-		     (when (framep frame-or-buffer)
-		       (last-nonminibuf-window frame-or-buffer)))))
-	  (set-image-instance-property inst :items 
-				       (buffers-tab-items 
-					nil locale)))))))
-
-(defun remove-buffer-from-gutter-tab ()
-  "Remove the current buffer from the tab control in the gutter area."
-  (when (and (valid-image-instantiator-format-p 'tab-control)
-	     (specifier-instance default-gutter-visible-p))
-    (let ((inst (glyph-image-instance gutter-buffers-tab))
-	  (buffers (buffers-tab-items t)))
-      (unless buffers
-	(setq buffers (build-buffers-tab-internal 
-		       (list 
-			(get-buffer-create "*scratch*")))))
-      (set-image-instance-property inst :items buffers))))
-
-(add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
-(add-hook 'create-frame-hook 'update-tab-in-gutter)
-(add-hook 'record-buffer-hook 'update-tab-in-gutter)
+      (when (valid-image-instantiator-format-p 'tab-control 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-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
 ;;
-(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' or
-`display-progress'/`clear-progress' functions.")
+(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
+textual and displayed in the echo area."
+  :type 'boolean
+  :group 'gutter)
 
-(defvar progress-glyph-height 32
-  "Height of the gutter area for progress messages.")
+(defvar progress-glyph-height 24
+  "Height of the progress gauge glyph.")
 
-(defvar progress-stop-callback 'progress-quit-function
-  "Function to call to stop the progress operation.")
+(defvar progress-feedback-popup-period 0.5
+  "The time that the progress gauge should remain up after completion")
 
-(defun progress-quit-function ()
-  "Default function to call for the stop button in a progress gauge.
-This just removes the progress gauge and calls quit."
-  (interactive)
-  (clear-progress)
-  (keyboard-quit))
+(defcustom progress-feedback-style 'large
+  "*Control the appearance of the progress gauge.
+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)))
 
 ;; private variables
-(defvar progress-gauge-glyph
-  (make-glyph
-   (vector 'progress-gauge
-	   :pixel-height (- progress-glyph-height 8)
-	   :pixel-width 250
-	   :descriptor "Progress")))
-
-(defvar progress-text-glyph
-  (make-glyph [string :data ""]))
-
-(defvar progress-layout-glyph
-  (make-glyph
-   (vector 
-    'layout :orientation 'vertical :justify 'left
-    :items (list 
-	    progress-text-glyph
-	    (make-glyph
-	     (vector 
-	      'layout :pixel-height progress-glyph-height 
-	      :orientation 'horizontal
-	      :items (list 
-		      progress-gauge-glyph
-		      (vector 
-		       'button :pixel-height (- progress-glyph-height 8)
-		       :descriptor " Stop "
-		       :callback '(funcall progress-stop-callback)))))))))
-
-(defvar progress-abort-glyph
-  (make-glyph
-   (vector 'layout :orientation 'vertical :justify 'left
-	   :items (list progress-text-glyph
-			(make-glyph 
-			 (vector 'layout 
-				 :pixel-height progress-glyph-height
-				 :orientation 'horizontal))))))
-
-(defvar progress-extent-text "")
-(defvar progress-extent nil)
-
-(defun progress-displayed-p (&optional return-string frame)
+(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-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."
@@ -387,8 +479,8 @@ 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 (&optional label frame no-restore)
-  "Remove any progress gauge with the given LABEL from the progress gauge-stack,
+(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
 is nil, it will be displayed.  The string which remains in the gutter
@@ -397,23 +489,31 @@ 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)."
-  (or frame (setq frame (selected-frame)))
-  (remove-progress label frame)
-  (let ((inhibit-read-only t)
-	(zmacs-region-stays zmacs-region-stays)) ; preserve from change
-    (erase-buffer " *Echo Area*")
-    (erase-buffer (get-buffer-create " *Gutter Area*")))
-  (if no-restore
-      nil			; just preparing to put another msg up
-    (if progress-stack
-	(let ((oldmsg (cdr (car progress-stack))))
-	  (raw-append-progress oldmsg frame)
-	  oldmsg)
-      ;; nothing to display so get rid of the gauge
-      (set-specifier bottom-gutter-border-width 0 frame)
-      (set-specifier bottom-gutter-visible-p nil frame))))
-
-(defun remove-progress (&optional label frame)
+  (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
+	  progress-feedback-use-echo-area)
+      (clear-message label frame nil no-restore)
+    (or frame (setq frame (selected-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*")))
+    (if no-restore
+	nil			; just preparing to put another msg up
+      (if progress-stack
+	  (let ((oldmsg (cdr (car progress-stack))))
+	    (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-feedback-clear-when-idle (&optional label)
+  (add-one-shot-hook 'pre-idle-hook
+		     `(lambda ()
+			(clear-progress-feedback ',label))))
+
+(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
@@ -427,7 +527,15 @@ you should just use (progress nil)."
 	      (setcdr s (cdr (cdr s))))
 	  (setq s (cdr s)))))))
 
-(defun append-progress (label message &optional value frame)
+(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
+      ;; want.
+      (dispatch-non-command-events)
+    nil))
+
+(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))
@@ -435,141 +543,146 @@ you should just use (progress nil)."
     (if (eq label (car top))
 	(progn
 	  (setcdr top message)
-	  (if (eq tmsg message)
-	      (set-image-instance-property 
-	       (glyph-image-instance progress-gauge-glyph)
-	       :percent value)
-	    (raw-append-progress message value frame))
-	  (redisplay-gutter-area)
-	  (when (input-pending-p)
-	    (dispatch-event (next-command-event))))
+	  (if (equal tmsg message)
+	      (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 message value frame))
-    (when (eq value 100) 
-      (sit-for 0.5 nil)
-      (clear-progress label))))
-
-(defun abort-progress (label message &optional 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))
-	 (inhibit-read-only t)
-	 (zmacs-region-stays zmacs-region-stays))
-    (if (eq label (car top))
-	(setcdr top message)
-      (push (cons label message) progress-stack))
-    (unless (equal message "")
-      (insert-string message (get-buffer-create " *Gutter Area*"))
-      ;; Do what the device is able to cope with.
-      (if (not (valid-image-instantiator-format-p 'progress-gauge frame))
-	  (progn
-	    (insert-string message " *Echo Area*")
-	    (if (not executing-kbd-macro)
-		(redisplay-echo-area)))
-	;; do some funky display here.
-	(unless progress-extent
-	  (setq progress-extent (make-extent 0 0 progress-extent-text)))
-	(let ((bglyph (extent-begin-glyph progress-extent)))
-	  (set-extent-begin-glyph progress-extent progress-abort-glyph)
+      (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-feedback-popup-period nil)
+      (clear-progress-feedback label))))
+
+(defun abort-progress-feedback (label message &optional frame)
+  (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
+	  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
+    (let* ((top (car progress-stack))
+	   (inhibit-read-only t)
+	   (zmacs-region-stays zmacs-region-stays))
+      (if (eq label (car top))
+	  (setcdr top message)
+	(push (cons label message) progress-stack))
+      (unless (equal message "")
+	(insert-string message (get-buffer-create " *Gutter Area*"))
+	(let* ((gutter-string (copy-sequence "\n"))
+	       (ext (make-extent 0 1 gutter-string)))
+	  ;; do some funky display here.
+	  (set-extent-begin-glyph ext progress-abort-glyph)
 	  ;; fixup the gutter specifiers
-	  (set-specifier bottom-gutter progress-extent-text frame)
+	  (set-gutter-element bottom-gutter 'progress gutter-string frame)
 	  (set-specifier bottom-gutter-border-width 2 frame)
-	  (set-image-instance-property 
-	   (glyph-image-instance progress-text-glyph) :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-specifier bottom-gutter-visible-p t 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 0.5 nil)
-	  (clear-progress label)
-	  (set-extent-begin-glyph progress-extent bglyph)
+	  (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 (message &optional value frame)
+(defun raw-append-progress-feedback (message &optional value frame)
   (unless (equal message "")
-    (let ((inhibit-read-only t)
+    (let* ((inhibit-read-only t)
 	  (zmacs-region-stays zmacs-region-stays)
-	  (val (or value 0))) ; preserve from change
+	  (val (or value 0))
+	  (gutter-string (copy-sequence "\n"))
+	  (ext (make-extent 0 1 gutter-string)))
       (insert-string message (get-buffer-create " *Gutter Area*"))
-      ;; Do what the device is able to cope with.
-      (if (not (valid-image-instantiator-format-p 'progress-gauge frame))
+      ;; do some funky display here.
+      (set-extent-begin-glyph ext progress-layout-glyph)
+      ;; fixup the gutter specifiers
+      (set-gutter-element bottom-gutter 'progress gutter-string frame)
+      (set-specifier bottom-gutter-border-width 2 frame)
+      (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
+					 'progress frame))
+	  ;; if the gauge is already visible then just draw the gutter
+	  ;; checking for user events
 	  (progn
-	    (insert-string 
-	     (concat message (if (eq val 100) "done.")
-		     (make-string (/ val 5) ?.))
-	     " *Echo Area*")
-	    (if (not executing-kbd-macro)
-		(redisplay-echo-area)))
-	;; do some funky display here.
-	(unless progress-extent
-	  (setq progress-extent (make-extent 0 0 progress-extent-text))
-	  (set-extent-begin-glyph progress-extent progress-layout-glyph))
-	;; fixup the gutter specifiers
-	(set-specifier bottom-gutter progress-extent-text frame)
-	(set-specifier bottom-gutter-border-width 2 frame)
-	(set-image-instance-property 
-	 (glyph-image-instance progress-gauge-glyph) :percent val)
-	(set-image-instance-property 
-	 (glyph-image-instance progress-text-glyph) :data message)
-	(if (and (eq (specifier-instance bottom-gutter-height frame)
-		     'autodetect)
-		 (specifier-instance bottom-gutter-visible-p frame))
-	    (progn
-	      ;; if the gauge is already visible then just draw the gutter
-	      ;; checking for user events
-	      (redisplay-gutter-area)
-	      (when (input-pending-p)
-		(dispatch-event (next-command-event))))
-	  ;; otherwise make the gutter visible and redraw the frame
-	  (set-specifier bottom-gutter-height 'autodetect frame)
-	  (set-specifier bottom-gutter-visible-p t frame)
-	  ;; we have to do this so redisplay is up-to-date and so
-	  ;; redisplay-gutter-area performs optimally.
-	  (redisplay-frame)
-	  )))))
-
-(defun display-progress (label message &optional value frame)
+	    (redisplay-gutter-area)
+	    (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
+				      'progress t frame)
+	;; 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-feedback-dispatch-non-command-events)
+	(redisplay-frame 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' to remove a labelled
+the string to display.  Use `clear-progress-feedback' to remove a labelled
 message."
-  (clear-progress label frame t)
-  (if (eq value 'abort)
-      (abort-progress label message frame)
-    (append-progress label message value frame)))
-
-(defun current-progress (&optional frame)
+  (cond ((eq value 'abort)
+	 (abort-progress-feedback label message frame))
+	((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
+	     progress-feedback-use-echo-area)
+	 (display-message label 
+	   (concat message (if (eq value 100) "done."
+			     (make-string (/ value 5) ?.)))
+	   frame))
+	(t
+	 (append-progress-feedback label message value 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-label (&optional frame)
+(defun current-progress-feedback-label (&optional frame)
   (car (car progress-stack)))
 
-(defun progress (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'.
 
 If the only argument is nil, clear any existing progress gauge."
-  (if (and (null fmt) (null args))
-      (prog1 nil
-	(clear-progress nil))
-    (let ((str (apply 'format fmt args)))
-      (display-progress 'progress str value)
-      str)))
-
-(defun lprogress (label fmt &optional value &rest args)
+  (save-excursion
+    (if (and (null fmt) (null args))
+	(prog1 nil
+	  (clear-progress-feedback nil))
+      (let ((str (apply 'format fmt args)))
+	(display-progress-feedback 'progress str value)
+	str))))
+
+(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'."
-  (if (and (null fmt) (null args))
-      (prog1 nil
-	(clear-progress label nil))
-    (let ((str (apply 'format fmt args)))
-      (display-progress label str value)
-      str)))
+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-feedback label nil))
+      (let ((str (apply 'format fmt args)))
+	(display-progress-feedback label str value)
+	str))))
 
 (provide 'gutter-items)
 ;;; gutter-items.el ends here.