auto-install/fame.el

   1 ;;; fame.el --- Framework for Applications' MEssages
   2 ;;
   3 ;; Copyright (C) 2004 David Ponce
   4 ;;
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 28 Oct 2004
   8 ;; Keywords: status
   9 ;; X-RCS: $Id: fame.el,v 1.3 2005-09-30 20:07:29 zappo Exp $
  10 ;;
  11 ;; This file is not part of GNU Emacs.
  12 ;;
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17 ;;
  18 ;; This software is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29 ;;
  30 ;; This library provides a convenient framework for applications to
  31 ;; send messages distinguished by their level of importance, allowing
  32 ;; to customize how they will be actually rendered.
  33 ;;
  34 ;; The principle is to define a `channel' where to send messages at
  35 ;; particular levels, depending on their importance.  A channel is
  36 ;; identified by a non-nil symbol.  For example this library could
  37 ;; send its messages to the `fame' channel.  Four levels of importance
  38 ;; are recognized, for debug, informational, warning and error
  39 ;; messages.
  40 ;;
  41 ;; Messages at any particular level can be either discarded,
  42 ;; temporarily displayed, recorded in the message log buffer without
  43 ;; showing them in the echo area, or shown the usual way like through
  44 ;; the `message' function.  Messages shown in the echo area can be
  45 ;; recorded or not in the message log buffer.
  46 ;;
  47 ;; The `define-fame-channel' macro permits to easily define a new
  48 ;; channel, that is an option to customize how to display the message
  49 ;; levels for this channel, and the level specific functions to use to
  50 ;; send messages to this channel.
  51 ;;
  52 ;; Here is a small example:
  53 ;;
  54 ;;     (require 'fame)
  55 ;;     ...
  56 ;;     (define-fame-channel feature)
  57 ;;     ...
  58 ;;     (feature-send-debug "Some useful debug message")
  59 ;;     ...
  60 ;;     (condition-case err
  61 ;;         ...
  62 ;;       (error
  63 ;;        (feature-send-error "%s" (error-message-string err))))
  64 ;;     ...
  65 ;;     (feature-send-info "Some useful informational message")
  66 ;;     ...
  67 ;;     (provide 'feature)
  68
  69 ;;; History:
  70 ;;
  71
  72 ;;; Code:
  73 \f
  74 ;;; Constants and options
  75 ;;
  76 (defconst fame-valid-levels
  77   '(:error :warning :info :debug)
  78   "Valid message levels.")
  79
  80 (defconst fame-valid-level-values
  81   '(t nolog temp temp-nolog log none)
  82   "Valid message level values.")
  83
  84 (defconst fame-default-level-values
  85   '(:debug log :info temp :warning t :error t)
  86   "Default display value of message levels.")
  87
  88 (define-widget 'fame-display-choice 'radio-button-choice
  89   "Widget to choose the display value of a level."
  90   :format "%v\n"
  91   :entry-format " %v%b"
  92   :args '((const :format "%v" :value t)
  93           (const :format "%v" :value nolog)
  94           (const :format "%v" :value temp)
  95           (const :format "%v" :value temp-nolog)
  96           (const :format "%v" :value log)
  97           (const :format "%v" :value none)))
  98
  99 (define-widget 'fame-level-widget 'const
 100   "Widget to display a level symbol."
 101   :format "   %t")
 102
 103 (define-widget 'fame-channel-widget 'list
 104   "Widget to customize the messages levels of a channel."
 105   :tag "Display value of message levels"
 106   :format "%{%t%}:\n%v\n"
 107   :args '((fame-level-widget :tag ":debug  " :value :debug)
 108           (fame-display-choice)
 109           (fame-level-widget :tag ":info   " :value :info)
 110           (fame-display-choice)
 111           (fame-level-widget :tag ":warning" :value :warning)
 112           (fame-display-choice)
 113           (fame-level-widget :tag ":error  " :value :error)
 114           (fame-display-choice)))
 115
 116 (defgroup fame nil
 117   "Framework for Applications' MEssages."
 118   :prefix "fame"
 119   :group 'lisp)
 120
 121 (defcustom fame-temp-message-delay 1
 122   "*Lifetime of a temporary message, in seconds."
 123   :group 'fame
 124   :type 'number)
 125 \f
 126 ;;; Core message functions
 127 ;;
 128 (eval-and-compile
 129
 130 ;;;; Read the message currently displayed in the echo area.
 131   (defalias 'fame-current-message
 132     (if (fboundp 'current-message)
 133         'current-message
 134       'ignore))
 135
 136 ;;;; Show a message in the echo area without logging it.
 137   (if (fboundp 'lmessage)
 138       ;; XEmacs
 139       (defun fame-message-nolog (&rest args)
 140         "Display but don't log a message on the echo area.
 141 ARGS are like those of the function `message'."
 142         (and args (apply 'lmessage 'no-log args)))
 143     ;; Emacs
 144     (defun fame-message-nolog (&rest args)
 145       "Display but don't log a message on the echo area.
 146 ARGS will be passed to the function `message'."
 147       (and args
 148            (let ((message-log-max nil)) ;; No logging
 149              (apply 'message args))))
 150     )
 151
 152 ;;;; Log a message without showing it in the echo area.
 153   (if (fboundp 'log-message)
 154       ;; XEmacs
 155       (defun fame-log-message (&rest args)
 156         "Log but don't display a message.
 157 ARGS are like those of the function `message'."
 158         (and args (log-message 'message (apply 'format args))))
 159     ;; Emacs
 160     (defun fame-log-message (&rest args)
 161       "Log but don't display a message.
 162 ARGS will be passed to the function `message'."
 163       (and args
 164            (let ((executing-kbd-macro t)) ;; Inhibit display!
 165              (apply 'message args))))
 166     )
 167   ;; If the above definition fails, here is a portable implementation
 168   ;; of a `log-message' function.
 169   '(defun fame-log-message (&rest args)
 170      "Log but don't display a message.
 171 ARGS are like those of the function `message'."
 172      (when args
 173        (let ((text (apply 'format args)))
 174          (with-current-buffer
 175              (get-buffer-create (if (featurep 'xemacs)
 176                                     " *Message-Log*"
 177                                   "*Messages*"))
 178            (goto-char (point-max))
 179            (or (bobp) (bolp) (insert "\n"))
 180            (forward-line -1)
 181            (if (search-forward text nil t)
 182                (if (looking-at " \\[\\([0-9]+\\) times\\]")
 183                    (replace-match
 184                     (number-to-string
 185                      (1+ (string-to-number (match-string 1))))
 186                     nil nil nil 1)
 187                  (end-of-line)
 188                  (insert " [2 times]"))
 189              (forward-line 1)
 190              (insert text))))))
 191
 192 ;;;; Log and temporarily show a message in the echo area.
 193   (condition-case nil
 194       (require 'timer)
 195     (error nil))
 196   ;; We need timers to display messages temporarily.
 197   (if (not (fboundp 'run-with-timer))
 198
 199       (defun fame-temp-message-internal (fun &rest args)
 200         "Display a message temporarily through the function FUN.
 201 ARGS are like those of the function `message'."
 202         ;; Without timers just call FUN.
 203         (and args (apply fun args)))
 204
 205     (defvar fame-temp-message-timer nil)
 206     (defvar fame-temp-message-saved nil)
 207
 208     (defun fame-temp-restore-message ()
 209       "Restore a message previously displayed in the echo area."
 210       (when (timerp fame-temp-message-timer)
 211         (cancel-timer fame-temp-message-timer)
 212         (setq fame-temp-message-timer nil))
 213       (when fame-temp-message-saved
 214         (prog1 (fame-message-nolog "%s" fame-temp-message-saved)
 215           (setq fame-temp-message-saved nil))))
 216
 217     (defun fame-temp-message-internal (fun &rest args)
 218       "Display a message temporarily through the function FUN.
 219 ARGS are like those of the function `message'."
 220       (when args
 221         (condition-case nil
 222             (progn
 223               (fame-temp-restore-message)
 224               (setq fame-temp-message-saved (fame-current-message))
 225               (prog1 (apply fun args)
 226                 (setq fame-temp-message-timer
 227                       (run-with-timer fame-temp-message-delay nil
 228                                       'fame-temp-restore-message))))
 229           (error
 230            (fame-temp-restore-message)))))
 231     )
 232   )
 233
 234 (defsubst fame-temp-message (&rest args)
 235   "Display a message temporarily and log it.
 236 ARGS are like those of the function `message'.
 237 The original message is restored to the echo area after
 238 `fame-temp-message-delay' seconds."
 239   (apply 'fame-temp-message-internal 'message args))
 240
 241 (defsubst fame-temp-message-nolog (&rest args)
 242   "Display a message temporarily without logging it.
 243 ARGS are like those of the function `message'.
 244 The original message is restored to the echo area after
 245 `fame-temp-message-delay' seconds."
 246   (apply 'fame-temp-message-internal 'fame-message-nolog args))
 247 \f
 248 ;;; Handling of message levels
 249 ;;
 250 (defun fame-check-level (level)
 251   "Check that LEVEL is a valid message level.
 252 If valid, return LEVEL.  Signal an error otherwise."
 253   (if (memq level fame-valid-levels)
 254       level
 255     (signal 'wrong-type-argument
 256             (list fame-valid-levels level))))
 257
 258 (defun fame-check-level-value (value)
 259   "Check that VALUE is a valid message level value.
 260 If valid, return VALUE.  Signal an error otherwise."
 261   (if (memq value fame-valid-level-values)
 262       value
 263     (signal 'wrong-type-argument
 264             (list fame-valid-level-values value))))
 265
 266 (defun fame-check-channel (channel)
 267   "Check that CHANNEL is a non-nil symbol.
 268 If valid, return CHANNEL.  Signal an error otherwise."
 269   (if (and channel (symbolp channel))
 270       channel
 271     (signal 'wrong-type-argument
 272             (list 'symbolp channel))))
 273
 274 (defun fame-check-channel-levels (levels)
 275   "Check that LEVELS is a valid specification of channel levels.
 276 If valid, return a normalized form of the specification.
 277 Signal an error otherwise."
 278   (let (spec)
 279     (dolist (level fame-valid-levels)
 280       (push (fame-check-level-value
 281              ;; A nil level value means to use the default value.
 282              (or (plist-get levels level)
 283                  (plist-get fame-default-level-values level))) spec)
 284       (push level spec))
 285     spec))
 286
 287 (defsubst fame-channel-symbol (channel)
 288   "Return the symbol whose value is CHANNEL's levels."
 289   (intern (format "%s-fame-levels" (fame-check-channel channel))))
 290
 291 (defun fame-channel-levels (channel)
 292   "Return the message levels display values of CHANNEL.
 293 If CHANNEL doesn't exist return the default value in constant
 294 `fame-default-level-values'."
 295   (let ((symbol (fame-channel-symbol channel)))
 296     (if (boundp symbol)
 297         (symbol-value symbol)
 298       fame-default-level-values)))
 299
 300 (defsubst fame-level-display (channel level)
 301   "For CHANNEL, return the display value of LEVEL.
 302 See also the option `fame-channels'."
 303   (plist-get (fame-channel-levels channel)
 304              (fame-check-level level)))
 305 \f
 306 ;;; Sending messages to channels
 307 ;;
 308 (defconst fame-send-functions-alist
 309   '((none       . nil)
 310     (log        . fame-log-message)
 311     (temp       . fame-temp-message)
 312     (temp-nolog . fame-temp-message-nolog)
 313     (nolog      . fame-message-nolog)
 314     (t          . message)
 315     ))
 316
 317 (defun fame-send (channel level &rest args)
 318   "Send a message to CHANNEL at level LEVEL.
 319 ARGS are like those of the function `message'.
 320 The message will be displayed according to what is specified for
 321 CHANNEL in the `fame-channels' option."
 322   (let ((sender (cdr (assq (fame-level-display channel level)
 323                            fame-send-functions-alist))))
 324     (and sender (apply sender args))))
 325
 326 (defsubst fame-send-debug (channel &rest args)
 327   "Send a debug message to CHANNEL.
 328 CHANNEL must be a non-nil symbol.
 329 ARGS will be passed to the function `fame-send'."
 330   (apply 'fame-send channel :debug args))
 331
 332 (defsubst fame-send-info (channel &rest args)
 333   "Send an informational message to CHANNEL.
 334 CHANNEL must be a non-nil symbol.
 335 ARGS will be passed to the function `fame-send'."
 336   (apply 'fame-send channel :info args))
 337
 338 (defsubst fame-send-warning (channel &rest args)
 339   "Send a warning message to CHANNEL.
 340 CHANNEL must be a non-nil symbol.
 341 ARGS will be passed to the function `fame-send'."
 342   (apply 'fame-send channel :warning args))
 343
 344 (defsubst fame-send-error (channel &rest args)
 345   "Send an error message to CHANNEL.
 346 CHANNEL must be a non-nil symbol.
 347 ARGS will be passed to the function `fame-send'."
 348   (apply 'fame-send channel :error args))
 349
 350 ;;; Defining new channels
 351 ;;
 352 ;;;###autoload
 353 (defmacro define-fame-channel (channel &optional default docstring)
 354   "Define the new message channel CHANNEL.
 355 CHANNEL must be a non-nil symbol.
 356 The optional argument DEFAULT specifies the default value of message
 357 levels for this channel.  By default it is the value of
 358 `fame-default-level-values'.
 359 DOCSTRING is an optional channel documentation.
 360
 361 This defines the option `CHANNEL-fame-levels' to customize the current
 362 value of message levels.  And the functions `CHANNEL-send-debug',
 363 `CHANNEL-send-info', `CHANNEL-send-warning', and `CHANNEL-send-error',
 364 that respectively send debug, informational, warning, and error
 365 messages to CHANNEL."
 366   (let ((c-opt (fame-channel-symbol channel)))
 367     `(eval-when-compile
 368        (defcustom ,c-opt ',(fame-check-channel-levels default)
 369          ,(format "*Display value of message levels in the %s channel.
 370 %s
 371 This is a plist where a message level is a property whose value
 372 defines how messages at this level will be displayed.
 373
 374 The possible levels are :debug, :info, :warning, and :error.
 375 Level values can be:
 376  - t           to show and log messages the standard way.
 377  - nolog       to show messages without logging them.
 378  - temp        to show messages temporarily and log them.
 379  - temp-nolog  to show messages temporarily without logging them.
 380  - log         to log but not show messages.
 381  - none        to discard messages.
 382
 383 The default behavior is specified in `fame-default-level-values'."
 384                   channel
 385                   (if docstring (format "%s\n" docstring) ""))
 386          :group 'fame
 387          :type 'fame-channel-widget)
 388        (defsubst ,(intern (format "%s-send-debug" channel))
 389          (&rest args)
 390          ,(format "Send a debug message to the `%s' channel.
 391 ARGS will be passed to the function `fame-send'.
 392 To customize how such messages will be displayed, see the option
 393 `%s'." channel c-opt)
 394          (apply 'fame-send ',channel :debug args))
 395        (defsubst ,(intern (format "%s-send-info" channel))
 396          (&rest args)
 397          ,(format "Send an informational message to the `%s' channel.
 398 ARGS will be passed to the function `fame-send'.
 399 To customize how such messages will be displayed, see the option
 400 `%s'." channel c-opt)
 401          (apply 'fame-send ',channel :info args))
 402        (defsubst ,(intern (format "%s-send-warn" channel))
 403          (&rest args)
 404          ,(format "Send a warning message to the `%s' channel.
 405 ARGS will be passed to the function `fame-send'.
 406 To customize how such messages will be displayed, see the option
 407 `%s'." channel c-opt)
 408          (apply 'fame-send ',channel :warning args))
 409        (defsubst ,(intern (format "%s-send-error" channel))
 410          (&rest args)
 411          ,(format "Send an error message to the `%s' channel.
 412 ARGS will be passed to the function `fame-send'.
 413 To customize how such messages will be displayed, see the option
 414 `%s'." channel c-opt)
 415          (apply 'fame-send ',channel :error args))
 416        ;; Return the CHANNEL symbol
 417        ',c-opt)))
 418
 419 (provide 'fame)
 420
 421 ;;; fame.el ends here