Commits

Anonymous committed 561db63

2004-03-30 Steve Youngs <sryoungs@bigpond.net.au>

* profile.el (profile-displaying-temp-buffer): New.
(profile-results): Use it.

Comments (0)

Files changed (2)

+2004-03-30  Steve Youngs  <sryoungs@bigpond.net.au>
+
+	* profile.el (profile-displaying-temp-buffer): New.
+	(profile-results): Use it.
+
 2004-01-13  Norbert Koch  <viteno@xemacs.org>
 
 	* Makefile (VERSION): XEmacs package 1.61 released.
 
 ;;; Code:
 
+;;; FIXME: This is (almost) a direct copy of `with-displaying-help-buffer'
+;; that exists only in 21.5 core.  When 21.5 is stable I'd suggest
+;; that this macro be removed and the call to it in `profile-results'
+;; (see fixme comment in that function) below be changed to use the
+;; macro in core.  This is here because the packages are built with
+;; 21.4 so when this file is byte-compiled it doesn't include the
+;; definition of the `with-displaying-temp-buffer'.  Which was OK for
+;; 21.4 users, but 21.5 users would lose. --SY.
+(defmacro profile-displaying-temp-buffer (name &rest body)
+  "Form which makes a help buffer with given NAME and evaluates BODY there.
+
+Use this function for displaying information in temporary buffers, where the
+user will typically view the information and then exit using
+\\<temp-buffer-mode-map>\\[help-mode-quit].
+
+The buffer is put into the mode specified in `mode-for-temp-buffer'."
+  `(let* ((winconfig (current-window-configuration))
+	  (was-one-window (one-window-p))
+	  (buffer-name ,name)
+	  (help-not-visible
+	   (not (and (windows-of-buffer buffer-name) ;shortcut
+		     (memq (selected-frame)
+			   (mapcar 'window-frame
+				   (windows-of-buffer buffer-name)))))))
+    (help-register-and-maybe-prune-excess buffer-name)
+    ;; if help-sticky-window is bogus or deleted, get rid of it.
+    (if (and help-sticky-window (or (not (windowp help-sticky-window))
+				    (not (window-live-p help-sticky-window))))
+	(setq help-sticky-window nil))
+    (prog1
+	(let ((temp-buffer-show-function
+	       (if help-sticky-window
+		   #'(lambda (buffer)
+		       (set-window-buffer help-sticky-window buffer))
+		 temp-buffer-show-function)))
+	  (with-output-to-temp-buffer buffer-name
+	    (prog1 (progn ,@body)
+	      (save-excursion
+		(set-buffer standard-output)
+		(funcall mode-for-help)))))
+      (let ((helpwin (get-buffer-window buffer-name)))
+	(when helpwin
+	  ;; If the temp buffer is already displayed on this
+	  ;; frame, don't override the previous configuration
+	  (when help-not-visible
+	    (with-current-buffer (window-buffer helpwin)
+	      (setq help-window-config winconfig)))
+	  (when help-selects-help-window
+	    (select-window helpwin))
+	  (cond ((eq helpwin (selected-window))
+		 (display-message 'command
+		   (substitute-command-keys "Type \\[help-mode-quit] to remove window, \\[scroll-up] to scroll the text.")))
+		(was-one-window
+		 (display-message 'command
+		   (substitute-command-keys "Type \\[delete-other-windows] to remove window, \\[scroll-other-window] to scroll the text.")))
+		(t
+		 (display-message 'command
+		   (substitute-command-keys "Type \\[switch-to-buffer-other-window] to restore the other window, \\[scroll-other-window] to scroll the text.")))))))))
+
+(put 'profile-displaying-temp-buffer 'lisp-indent-function 1)
+
 ;;;###autoload
 (defun profile-results (&optional info stream sort-by)
   "Print profiling info INFO to STREAM in a pretty format.
 				   (current-prefix-arg 'call-count))))
   (or info (setq info (get-profiling-info)))
   (if (not stream)
-      (if (fboundp 'with-displaying-temp-buffer)
-	  (with-displaying-temp-buffer "*Profiling Results*"
-	      (profile-results info standard-output sort-by))
-	(pop-to-buffer (get-buffer-create "*Profiling Results*"))
-	(erase-buffer)
-	(profile-results info (current-buffer))
-	(goto-char (point-min)))
+      ;; FIXME: change this to `with-displaying-temp-buffer' when that
+      ;; exists in stable XEmacs. --SY.
+      (profile-displaying-temp-buffer "*Profiling Results*"
+	(profile-results info standard-output sort-by))
     (let* ((standard-output stream)
 	   ;; #### Support old profile format for the moment
 	   (timing (if (consp (car info)) (copy-alist info)