weissman@apollo.uucp (Mark Weissman) (06/21/88)
;Hello,
;
; Someone wanted a way to keep messages around
;for later viewing or insertion etc. This makes available
;a command called list-notifications which keeps track of
;this stuff. It uses an add-hooks macro which I have previously
;posted which adds generic before and after hooks to any
;function. Here hooks are added to message and error to post
;a copy of the message to a notifications buffer. It may be
;necessary to add notification hooks to other functions if
;messages are being missed.
;Mark D. Weissman
;Apollo Computers Inc.
;weissman@apollo.com
;;; -*- Mode: Emacs-Lisp -*-
(defvar apollo:notifications-buffer "*NOTIFICATIONS - APOLLO*")
(defvar apollo:last-notification nil)
(defvar apollo:whitespace "[ \t
(defvar apollo:all-whitespace (concat "^" apollo:whitespace "*$"))
(require ;; This stuff is evaluated at load and comile time!!!
(progn (provide 'apollo:byte-compile-macro-expand-hack)
(defconst apollo:gensym-name "NOTIFICATIONS-GENSYM")
(defvar apollo:gensym-number 0)
(defun apollo:gensym ()
"Generate a new unused symbol. This could conflict with
other gensyms. Care should be taken to insure
that apollo:gensym-name is unique to a given file."
(let (s)
(while (or (boundp
(setq s
(intern
(format "apollo:%s-%s"
apollo:gensym-name
(setq apollo:gensym-number
(1+ apollo:gensym-number))))))
(fboundp s)))
s))
'apollo:byte-compile-macro-expand-hack))
(defmacro eol () '(save-excursion (end-of-line) (point)))
(defmacro with-buffer-set (b &rest r)
"Perform some action in another buffer.
No save-excursion."
(let ((c (apollo:gensym)))
(list 'let
(list (list c '(current-buffer)))
(list 'unwind-protect
(append (list 'progn (list 'set-buffer b)) r)
(list 'set-buffer c)))))
(defun list-notifications (arg)
"Display buffer showing all messages form functions message and error.
These often go by too fast to read,
so heres a second chance to view them.
With a numeric positive argument, this
will just redisplay the first line of the ARGth message, setting
apollo:last-notification to that string"
(interactive "P")
(if (and (integerp arg) (> arg 0))
(with-buffer-set apollo:notifications-buffer
(goto-char (point-min))
(forward-line (1- arg))
(princ (setq apollo:last-notification (buffer-substring (point) (eol)))))
(let* ((b (get-buffer-create apollo:notifications-buffer))
(w (display-buffer b)))
(if w
(with-buffer-set b
(set-window-start w 1)
(set-window-point w 1)
(set-mark 1)
(goto-char 1))))))
(defvar apollo:notification-hacks-p t)
(defvar apollo:notifications-kept 200)
(defun apollo:notification (&rest args)
"Place a copy of each message in buffer *NOTIFICATIONS*.
The newest message will be placed at the top of the
buffer. This is here because messages go by too
quick for me!
There is a flag called apollo:notifications-hacks-p used
by this function when if non-nil, does some processing
on what to display, This is slightly slower but makes
this buffer easier to look at."
(with-buffer-set (get-buffer-create apollo:notifications-buffer)
(buffer-flush-undo (current-buffer))
(let ((s (apply (function format) args)))
(goto-char (point-min))
(if (and apollo:notification-hacks-p
(or (string= "Mark set" s)
(eq 0 (string-match apollo:all-whitespace s))))
nil
(if (and apollo:notification-hacks-p
(string-match "^I-search:" s)
(string-match
(regexp-quote (buffer-substring 1 (eol))) s))
(delete-region 1 (min (point-max) (1+ (eol))))
(progn
(setq apollo:last-notification s)
(insert s "\n")
(if (zerop (forward-line apollo:notifications-kept))
(delete-region (point) (point-max)))))))))
(defmacro apollo:add-hooks (function)
"This macro is called with a symbol representing an emacs lisp
FUNCTION. This FUNCTION is redefined to funcall a list
of hooks before and after function execution.
This will create local-variables as follows:
apollo:<function-name> bound to the symbol function of FUNCTION
apollo:<function-name>-documentation which will be the doc
string for the FUNCTION.
apollo:<function-name>-before-hooks, a list of functions to funcall
before execution. These functions will be called with the
same arguments as the original FUNCTION.
apollo:<function-name>-after-hooks, a list of functions to funcall
after execution. These functions will be called with the
result of executing the original FUNCTION followed by the
original arguments.
This will take same arguments and return the same value as
the original FUNCTION.
"
(let* ((mdw-name (concat "apollo:" (symbol-name function)))
(mdw-before (concat mdw-name "-before-hooks"))
(mdw-after (concat mdw-name "-after-hooks"))
(mdw-doc (concat mdw-name "-documentation"))
(args (apollo:gensym))
(hook (apollo:gensym))
(result (apollo:gensym)))
(if (fboundp function)
(list 'progn
(list 'defvar (intern mdw-name)
(list 'symbol-function (list 'quote function)))
(list 'defvar (intern mdw-doc)
(list 'documentation (list 'quote function)))
(list 'defvar (intern mdw-before) nil)
(list 'defvar (intern mdw-after) nil)
(list 'defun function (list '&rest args)
(concat
(if (boundp (intern mdw-doc))
(eval (intern mdw-doc))
(documentation function))
"\n\nAdded hooks: " mdw-before " &\n"
" " mdw-after ".")
'(interactive)
(list 'mapcar
(list 'function
(list 'lambda (list hook)
(list 'apply hook args)))
(intern mdw-before))
(list 'let
(list
(list result (list 'apply (intern mdw-name) args)))
(list 'mapcar
(list 'function (list 'lambda (list hook)
(list 'apply hook args)))
(intern mdw-after))
result))))))
(apollo:add-hooks error)
(if (memq 'apollo:notification apollo:error-before-hooks) nil
(setq apollo:error-before-hooks (cons 'apollo:notification apollo:error-before-hooks)))
(apollo:add-hooks message)
(if (memq 'apollo:notification apollo:message-before-hooks) nil
(setq apollo:message-before-hooks (cons 'apollo:notification apollo:message-before-hooks)))