xemacs-beta: lisp/gutter-items.el comparison

comparison lisp/gutter-items.el @ 406:b8cc9ab3f761 r21-2-33

Import from CVS: tag r21-2-33

author	cvs
date	Mon, 13 Aug 2007 11:17:09 +0200
parents	2f8bb876ab1d
children	501cfd01ee6d

comparison

equal deleted inserted replaced

-:0e08f63c74d2
+:b8cc9ab3f761
 ;; along with Xmacs; see the file COPYING.  If not, write to the
 ;; Free Software Foundation, 59 Temple Place - Suite 330,
 ;; 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)
-;; Although these customizations appear bogus, they are neccessary in
-;; order to be able to save options through the options menu.
-(defcustom default-gutter-position
-(default-gutter-position)
-"The location of the default gutter. It can be 'top, 'bottom, 'left or
-'right. This option should be customized through the options menu.
-To set the gutter position explicitly use `set-default-gutter-position'"
-: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)))
-;;; Gutter helper functions
-;; called by Fset_default_gutter_position()
-(defvar default-gutter-position-changed-hook nil
-"Function or functions to be called when the gutter position is changed.
-The value of this variable may be buffer-local.")
-;; called by set-gutter-element-visible-p
-(defvar gutter-element-visibility-changed-hook nil
-"Function or functions to be called when the visibility of an
-element in the gutter changes.  The value of this variable may be
-buffer-local. The gutter element symbol is passed as an argument to
-the hook, as is the visibility flag.")
-(defun set-gutter-element (gutter-specifier prop val &optional locale tag-set)
-"Set GUTTER-SPECIFIER gutter element PROP to VAL in optional LOCALE.
-This is a convenience function for setting gutter elements."
-(map-extents #'(lambda (extent arg)
-		   (set-extent-property extent 'duplicable t)) val)
-(modify-specifier-instances gutter-specifier #'plist-put (list prop val)
-'force nil locale tag-set))
-(defun remove-gutter-element (gutter-specifier prop &optional locale tag-set)
-"Remove gutter element PROP from GUTTER-SPECIFIER in optional LOCALE.
-This is a convenience function for removing gutter elements."
-(modify-specifier-instances gutter-specifier #'plist-remprop (list prop)
-'force nil locale tag-set))
-(defun set-gutter-element-visible-p (gutter-visible-specifier-p
-				     prop &optional visible-p
-				     locale tag-set)
-"Change the visibility of gutter elements.
-Set the visibility of element PROP to VISIBLE-P for
-GUTTER-SPECIFIER-VISIBLE-P in optional LOCALE.
-This is a convenience function for hiding and showing gutter elements."
-(modify-specifier-instances
-gutter-visible-specifier-p #'(lambda (spec prop visible-p)
-				  (if (consp spec)
-				      (if visible-p
-					  (if (memq prop spec) spec
-					    (cons prop spec))
-					(delq prop spec))
-				    (if visible-p (list prop))))
-(list prop visible-p)
-'force nil locale tag-set)
-(run-hook-with-args 'gutter-element-visibility-changed-hook prop visible-p))
-(defun gutter-element-visible-p (gutter-visible-specifier-p
-				 prop &optional domain)
-"Determine whether a gutter element is visible.
-Given GUTTER-VISIBLE-SPECIFIER-P and gutter element PROP, return
-non-nil if it is visible in optional DOMAIN."
-(let ((spec (specifier-instance gutter-visible-specifier-p domain)))
-(or (and (listp spec) (memq 'buffers-tab spec))
-	spec)))
-(defun init-gutter ()
-"Initialize the gutter."
-;; do nothing as yet.
-)
 ;;; The Buffers tab
 (defgroup buffers-tab nil
 "Customization of `Buffers' tab."
 "Whether the buffers tab is globally visible.
 This option should be set through the options menu."
 :group 'buffers-tab
 :type 'boolean
 :set #'(lambda (var val)
-	   (set-gutter-element-visible-p default-gutter-visible-p 'buffers-tab val)
+	   (set-gutter-element-visible-p default-gutter-visible-p
+					 'buffers-tab val)
 	   (setq gutter-buffers-tab-visible-p val)))
 (defvar gutter-buffers-tab-orientation 'top
 "Where the buffers tab currently is. Do not set this.")
 	   (setq buffers-tab-max-buffer-line-length val)))
 (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.
+;;
+;; 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)) t)
+	(select-window (car (windows-of-buffer buffer)))
-(switch-to-buffer buffer t))))
+(switch-to-buffer buffer))))
 (defun select-buffers-tab-buffers-by-mode (buf1 buf2)
 "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)))
 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 "\n"))
+(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
 ;; A myriad of different update hooks all doing slightly different things
 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
 (add-hook 'create-frame-hook
 	  #'(lambda (frame)
 	      (when gutter-buffers-tab (update-tab-in-gutter frame t))))
-(add-hook 'record-buffer-hook 'update-tab-in-gutter)
+(add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
-(add-hook 'default-gutter-position-changed
+(add-hook 'default-gutter-position-changed-hook
-	  #'(lambda (arg)
+	  #'(lambda ()
-	      (when gutter-buffers-tab (update-tab-in-gutter arg))))
+	      (when gutter-buffers-tab (update-tab-in-gutter))))
 (add-hook 'gutter-element-visibility-changed-hook
 	  #'(lambda (prop visible-p)
 	      (when (and (eq prop 'buffers-tab) visible-p)
 		(update-tab-in-gutter))))
 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-display-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 (- progress-glyph-height 8)
+: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 24)
+(setq progress-layout-glyph
+	  (make-glyph
+	   `[layout
+	     :orientation horizontal
+	     :items (,progress-gauge-glyph
+		     [button
+		      :pixel-height (- progress-glyph-height 8)
+		      ;; 'quit is special and acts "asynchronously".
+		      :descriptor "Stop" :callback 'quit]
+		     ,progress-text-glyph)])))
+(t
+(setq progress-glyph-height 32)
+(setq progress-layout-glyph
+	  (make-glyph
+	   `[layout
+	     :orientation vertical :justify left
+	     :items (,progress-text-glyph
+		     [layout
+		      :pixel-height (eval progress-glyph-height)
+		      :orientation horizontal
+		      :items (,progress-gauge-glyph
+			      [button
+			       :pixel-height (- progress-glyph-height 8)
+			       :descriptor " Stop "
+			       ;; 'quit is special and acts "asynchronously".
+			       :callback 'quit])])])))))
+(defcustom progress-display-style 'large
+"*Control the appearance of the progress gauge.
+If 'large, the default, then the progress-display 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)))
 (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-glyph-height 32
-"Height of the gutter area for progress messages.")
-(defvar progress-display-stop-callback 'progress-display-quit-function
-"Function to call to stop the progress operation.")
-(defvar progress-display-popup-period 0.5
-"The time that the progress gauge should remain up after completion")
-(defun progress-display-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-display)
-(keyboard-quit))
-;; 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-display-stop-callback)))))))))
 (defvar progress-abort-glyph
 (make-glyph
-(vector 'layout :orientation 'vertical :justify 'left
+`[layout :orientation vertical :justify left
-	   :items (list progress-text-glyph
+	    :items (,progress-text-glyph
-			(make-glyph
+		    [layout
-			 (vector 'layout
+		     :pixel-height progress-glyph-height
-				 :pixel-height progress-glyph-height
+		     :orientation horizontal])]))
-				 :orientation 'horizontal))))))
-(defvar progress-extent-text "\n")
-(defvar progress-extent nil)
 (defun progress-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."
 (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-display oldmsg frame)
+	    (raw-append-progress-display 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)
-(add-hook 'pre-idle-hook
+(add-one-shot-hook 'pre-idle-hook
-	    (defun progress-display-clear-pre-idle-hook ()
+		     `(lambda ()
-	      (clear-progress-display label)
+			(clear-progress-display ',label))))
-	      (remove-hook 'pre-idle-hook
-			   'progress-display-clear-pre-idle-hook))))
 (defun remove-progress-display (&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
 	(if (eq label (car msg))
 	    (progn
 	      (setcdr s (cdr (cdr s))))
 	  (setq s (cdr s)))))))
+(defun progress-display-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-display (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))
 	 (tmsg (cdr top)))
 (if (eq label (car top))
 	(progn
 	  (setcdr top message)
 	  (if (equal tmsg message)
 	      (set-image-instance-property
-	       (glyph-image-instance progress-gauge-glyph)
+	       (glyph-image-instance progress-gauge-glyph
-	       :percent value)
+				     (frame-selected-window frame))
+	       :value value)
 	    (raw-append-progress-display message value frame))
 	  (redisplay-gutter-area))
 (push (cons label message) progress-stack)
 (raw-append-progress-display message value frame))
-(dispatch-non-command-events)
+(progress-display-dispatch-non-command-events)
 ;; either get command events or sit waiting for them
-(if (not (eq value 100))
+(when (eq value 100)
-	(when (input-pending-p)
+;      (sit-for progress-display-popup-period nil)
-	  (dispatch-event (next-command-event)))
-(sit-for progress-display-popup-period nil)
 (clear-progress-display label))))
 (defun abort-progress-display (label message &optional frame)
 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
 	  progress-display-use-echo-area)
 (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.
+	(let* ((gutter-string (copy-sequence "\n"))
-	;; do some funky display here.
+	       (ext (make-extent 0 1 gutter-string)))
-	(unless progress-extent
+	  ;; do some funky display here.
-	  (setq progress-extent (make-extent 0 1 progress-extent-text)))
+	  (set-extent-begin-glyph ext progress-abort-glyph)
-	(let ((bglyph (extent-begin-glyph progress-extent)))
-	  (set-extent-begin-glyph progress-extent progress-abort-glyph)
 	  ;; fixup the gutter specifiers
-	  (set-gutter-element bottom-gutter
+	  (set-gutter-element bottom-gutter 'progress gutter-string frame)
-			      'progress progress-extent-text frame)
 	  (set-specifier bottom-gutter-border-width 2 frame)
 	  (set-image-instance-property
-	   (glyph-image-instance progress-text-glyph) :data message)
+	   (glyph-image-instance progress-text-glyph
+				 (frame-selected-window frame)) :data message)
 	  (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)
+	  (clear-progress-display label frame)
-	  (set-extent-begin-glyph progress-extent bglyph)
+	  (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)
 (unless (equal message "")
-(let ((inhibit-read-only t)
+(let* ((inhibit-read-only t)
 	  (zmacs-region-stays zmacs-region-stays)
-	  (val (or value 0)))
+	  (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 some funky display here.
-(unless progress-extent
+(set-extent-begin-glyph ext progress-layout-glyph)
-	(setq progress-extent (make-extent 0 1 progress-extent-text))
-	(set-extent-begin-glyph progress-extent progress-layout-glyph))
 ;; fixup the gutter specifiers
-(set-gutter-element bottom-gutter 'progress 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-gauge-glyph) :percent val)
+(glyph-image-instance progress-gauge-glyph
+			     (frame-selected-window frame))
+:value val)
 (set-image-instance-property
-(glyph-image-instance progress-text-glyph) :data message)
+(glyph-image-instance progress-text-glyph (frame-selected-window frame))
+:data message)
 (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
-	    ;; if the gauge is already visible then just draw the gutter
-	    ;; checking for user events
 	    (redisplay-gutter-area)
-	    (dispatch-non-command-events)
+	    (progress-display-dispatch-non-command-events))
-	    (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-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.
-	(dispatch-non-command-events)
+	(progress-display-dispatch-non-command-events)
-	(redisplay-frame)
+	(redisplay-frame frame)
 	))))
 (defun display-progress-display (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
 	  (clear-progress-display label nil))
 (let ((str (apply 'format fmt args)))
 	(display-progress-display 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.

Mercurial > hg > xemacs-beta

comparison lisp/gutter-items.el @ 406:b8cc9ab3f761 r21-2-33