lisp/mh-e/mh-acros.el

   1 ;;; mh-acros.el --- macros used in MH-E
   2
   3 ;; Copyright (C) 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
   4
   5 ;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This file contains all macros that are used in more than one file.
  28 ;; If you run "make recompile" in CVS Emacs and see the message
  29 ;; "Source is newer than compiled," it is a sign that macro probably
  30 ;; needs to be moved here.
  31
  32 ;; Historically, it was so named with a silent "m" so that it would be
  33 ;; compiled first. Otherwise, "make recompile" in CVS Emacs would use
  34 ;; compiled files with stale macro definitions. Later, no-byte-compile
  35 ;; was added to the Local Variables section to avoid this problem and
  36 ;; because it's pointless to compile a file full of macros. But we
  37 ;; kept the name.
  38
  39 ;;; Change Log:
  40
  41 ;;; Code:
  42
  43 (require 'cl)
  44
  45 \f
  46
  47 ;;; Compatibility
  48
  49 ;;;###mh-autoload
  50 (defmacro mh-require-cl ()
  51   "Macro to load \"cl\" if needed.
  52
  53 Emacs coding conventions require that the \"cl\" package not be
  54 required at runtime. However, the \"cl\" package in Emacs 21.4
  55 and earlier left \"cl\" routines in their macro expansions. In
  56 particular, the expansion of (setf (gethash ...) ...) used
  57 functions in \"cl\" at run time. This macro recognizes that and
  58 loads \"cl\" appropriately."
  59   (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash)
  60       `(require 'cl)
  61     `(eval-when-compile (require 'cl))))
  62
  63 ;;;###mh-autoload
  64 (defmacro mh-do-in-gnu-emacs (&rest body)
  65   "Execute BODY if in GNU Emacs."
  66   (declare (debug t))
  67   (unless (featurep 'xemacs) `(progn ,@body)))
  68 (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)
  69
  70 ;;;###mh-autoload
  71 (defmacro mh-do-in-xemacs (&rest body)
  72   "Execute BODY if in XEmacs."
  73   (declare (debug t))
  74   (when (featurep 'xemacs) `(progn ,@body)))
  75 (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)
  76
  77 ;;;###mh-autoload
  78 (defmacro mh-funcall-if-exists (function &rest args)
  79   "Call FUNCTION with ARGS as parameters if it exists."
  80   (when (fboundp function)
  81     `(when (fboundp ',function)
  82        (funcall ',function ,@args))))
  83
  84 ;;;###mh-autoload
  85 (defmacro defun-mh (name function arg-list &rest body)
  86   "Create function NAME.
  87 If FUNCTION exists, then NAME becomes an alias for FUNCTION.
  88 Otherwise, create function NAME with ARG-LIST and BODY."
  89   (let ((defined-p (fboundp function)))
  90     (if defined-p
  91         `(defalias ',name ',function)
  92       `(defun ,name ,arg-list ,@body))))
  93 (put 'defun-mh 'lisp-indent-function 'defun)
  94
  95 ;;;###mh-autoload
  96 (defmacro defmacro-mh (name macro arg-list &rest body)
  97   "Create macro NAME.
  98 If MACRO exists, then NAME becomes an alias for MACRO.
  99 Otherwise, create macro NAME with ARG-LIST and BODY."
 100   (let ((defined-p (fboundp macro)))
 101     (if defined-p
 102         `(defalias ',name ',macro)
 103       `(defmacro ,name ,arg-list ,@body))))
 104 (put 'defmacro-mh 'lisp-indent-function 'defun)
 105
 106 \f
 107
 108 ;;; Miscellaneous
 109
 110 ;;;###mh-autoload
 111 (defmacro mh-make-local-hook (hook)
 112   "Make HOOK local if needed.
 113 XEmacs and versions of GNU Emacs before 21.1 require
 114 `make-local-hook' to be called."
 115   (when (and (fboundp 'make-local-hook)
 116              (not (get 'make-local-hook 'byte-obsolete-info)))
 117     `(make-local-hook ,hook)))
 118
 119 ;;;###mh-autoload
 120 (defmacro mh-mark-active-p (check-transient-mark-mode-flag)
 121   "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.
 122 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then
 123 check if variable `transient-mark-mode' is active."
 124   (cond ((featurep 'xemacs)             ;XEmacs
 125          `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))
 126         ((not check-transient-mark-mode-flag) ;GNU Emacs
 127          `(and (boundp 'mark-active) mark-active))
 128         (t                              ;GNU Emacs
 129          `(and (boundp 'transient-mark-mode) transient-mark-mode
 130                (boundp 'mark-active) mark-active))))
 131
 132 ;; Shush compiler.
 133 (defvar struct)                         ; XEmacs
 134 (defvar x)                              ; XEmacs
 135 (defvar y)                              ; XEmacs
 136
 137 ;;;###mh-autoload
 138 (defmacro mh-defstruct (name-spec &rest fields)
 139   "Replacement for `defstruct' from the \"cl\" package.
 140 The `defstruct' in the \"cl\" library produces compiler warnings,
 141 and generates code that uses functions present in \"cl\" at
 142 run-time. This is a partial replacement, that avoids these
 143 issues.
 144
 145 NAME-SPEC declares the name of the structure, while FIELDS
 146 describes the various structure fields. Lookup `defstruct' for
 147 more details."
 148   (let* ((struct-name (if (atom name-spec) name-spec (car name-spec)))
 149          (conc-name (or (and (consp name-spec)
 150                              (cadr (assoc :conc-name (cdr name-spec))))
 151                         (format "%s-" struct-name)))
 152          (predicate (intern (format "%s-p" struct-name)))
 153          (constructor (or (and (consp name-spec)
 154                                (cadr (assoc :constructor (cdr name-spec))))
 155                           (intern (format "make-%s" struct-name))))
 156          (field-names (mapcar #'(lambda (x) (if (atom x) x (car x))) fields))
 157          (field-init-forms (mapcar #'(lambda (x) (and (consp x) (cadr x)))
 158                                    fields))
 159          (struct (gensym "S"))
 160          (x (gensym "X"))
 161          (y (gensym "Y")))
 162     `(progn
 163        (defun* ,constructor (&key ,@(mapcar* #'(lambda (x y) (list x y))
 164                                              field-names field-init-forms))
 165          (list (quote ,struct-name) ,@field-names))
 166        (defun ,predicate (arg)
 167          (and (consp arg) (eq (car arg) (quote ,struct-name))))
 168        ,@(loop for x from 1
 169                for y in field-names
 170                collect `(defmacro ,(intern (format "%s%s" conc-name y)) (z)
 171                           (list 'nth ,x z)))
 172        (quote ,struct-name))))
 173
 174 ;;;###mh-autoload
 175 (defmacro with-mh-folder-updating (save-modification-flag &rest body)
 176   "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY).
 177 Execute BODY, which can modify the folder buffer without having to
 178 worry about file locking or the read-only flag, and return its result.
 179 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification flag
 180 is unchanged, otherwise it is cleared."
 181   (declare (debug t))
 182   (setq save-modification-flag (car save-modification-flag)) ; CL style
 183   `(prog1
 184        (let ((mh-folder-updating-mod-flag (buffer-modified-p))
 185              (buffer-read-only nil)
 186              (buffer-file-name nil))    ;don't let the buffer get locked
 187          (prog1
 188              (progn
 189                ,@body)
 190            (mh-set-folder-modified-p mh-folder-updating-mod-flag)))
 191      ,@(if (not save-modification-flag)
 192            '((mh-set-folder-modified-p nil)))))
 193 (put 'with-mh-folder-updating 'lisp-indent-hook 'defun)
 194
 195 ;;;###mh-autoload
 196 (defmacro mh-in-show-buffer (show-buffer &rest body)
 197   "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY).
 198 Display buffer SHOW-BUFFER in other window and execute BODY in it.
 199 Stronger than `save-excursion', weaker than `save-window-excursion'."
 200   (declare (debug t))
 201   (setq show-buffer (car show-buffer))  ; CL style
 202   `(let ((mh-in-show-buffer-saved-window (selected-window)))
 203      (switch-to-buffer-other-window ,show-buffer)
 204      (if mh-bury-show-buffer-flag (bury-buffer (current-buffer)))
 205      (unwind-protect
 206          (progn
 207            ,@body)
 208        (select-window mh-in-show-buffer-saved-window))))
 209 (put 'mh-in-show-buffer 'lisp-indent-hook 'defun)
 210
 211 ;;;###mh-autoload
 212 (defmacro mh-do-at-event-location (event &rest body)
 213   "Switch to the location of EVENT and execute BODY.
 214 After BODY has been executed return to original window. The
 215 modification flag of the buffer in the event window is
 216 preserved."
 217   (declare (debug t))
 218   (let ((event-window (make-symbol "event-window"))
 219         (event-position (make-symbol "event-position"))
 220         (original-window (make-symbol "original-window"))
 221         (original-position (make-symbol "original-position"))
 222         (modified-flag (make-symbol "modified-flag")))
 223     `(save-excursion
 224        (let* ((,event-window
 225                (or (mh-funcall-if-exists posn-window (event-start ,event))
 226                    (mh-funcall-if-exists event-window ,event)))
 227               (,event-position
 228                (or (mh-funcall-if-exists posn-point (event-start ,event))
 229                    (mh-funcall-if-exists event-closest-point ,event)))
 230               (,original-window (selected-window))
 231               (,original-position (progn
 232                                    (set-buffer (window-buffer ,event-window))
 233                                    (set-marker (make-marker) (point))))
 234               (,modified-flag (buffer-modified-p))
 235               (buffer-read-only nil))
 236          (unwind-protect (progn
 237                            (select-window ,event-window)
 238                            (goto-char ,event-position)
 239                            ,@body)
 240            (set-buffer-modified-p ,modified-flag)
 241            (goto-char ,original-position)
 242            (set-marker ,original-position nil)
 243            (select-window ,original-window))))))
 244 (put 'mh-do-at-event-location 'lisp-indent-hook 'defun)
 245
 246 \f
 247
 248 ;;; Sequences and Ranges
 249
 250 ;;;###mh-autoload
 251 (defsubst mh-seq-msgs (sequence)
 252   "Extract messages from the given SEQUENCE."
 253   (cdr sequence))
 254
 255 ;;;###mh-autoload
 256 (defmacro mh-iterate-on-messages-in-region (var begin end &rest body)
 257   "Iterate over region.
 258
 259 VAR is bound to the message on the current line as we loop
 260 starting from BEGIN till END. In each step BODY is executed.
 261
 262 If VAR is nil then the loop is executed without any binding."
 263   (declare (debug (symbolp body)))
 264   (unless (symbolp var)
 265     (error "Can not bind the non-symbol %s" var))
 266   (let ((binding-needed-flag var))
 267     `(save-excursion
 268        (goto-char ,begin)
 269        (beginning-of-line)
 270        (while (and (<= (point) ,end) (not (eobp)))
 271          (when (looking-at mh-scan-valid-regexp)
 272            (let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ())
 273              ,@body))
 274          (forward-line 1)))))
 275 (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun)
 276
 277 ;;;###mh-autoload
 278 (defmacro mh-iterate-on-range (var range &rest body)
 279   "Iterate an operation over a region or sequence.
 280
 281 VAR is bound to each message in turn in a loop over RANGE, which
 282 can be a message number, a list of message numbers, a sequence, a
 283 region in a cons cell, or a MH range (something like last:20) in
 284 a string. In each iteration, BODY is executed.
 285
 286 The parameter RANGE is usually created with
 287 `mh-interactive-range' in order to provide a uniform interface to
 288 MH-E functions."
 289   (declare (debug (symbolp body)))
 290   (unless (symbolp var)
 291     (error "Can not bind the non-symbol %s" var))
 292   (let ((binding-needed-flag var)
 293         (msgs (make-symbol "msgs"))
 294         (seq-hash-table (make-symbol "seq-hash-table")))
 295     `(cond ((numberp ,range)
 296             (when (mh-goto-msg ,range t t)
 297               (let ,(if binding-needed-flag `((,var ,range)) ())
 298                 ,@body)))
 299            ((and (consp ,range)
 300                  (numberp (car ,range)) (numberp (cdr ,range)))
 301             (mh-iterate-on-messages-in-region ,var
 302               (car ,range) (cdr ,range)
 303               ,@body))
 304            (t (let ((,msgs (cond ((and ,range (symbolp ,range))
 305                                   (mh-seq-to-msgs ,range))
 306                                  ((stringp ,range)
 307                                   (mh-translate-range mh-current-folder
 308                                                       ,range))
 309                                  (t ,range)))
 310                     (,seq-hash-table (make-hash-table)))
 311                 (dolist (msg ,msgs)
 312                   (setf (gethash msg ,seq-hash-table) t))
 313                 (mh-iterate-on-messages-in-region v (point-min) (point-max)
 314                   (when (gethash v ,seq-hash-table)
 315                     (let ,(if binding-needed-flag `((,var v)) ())
 316                       ,@body))))))))
 317 (put 'mh-iterate-on-range 'lisp-indent-hook 'defun)
 318
 319 (provide 'mh-acros)
 320
 321 ;; Local Variables:
 322 ;; no-byte-compile: t
 323 ;; indent-tabs-mode: nil
 324 ;; sentence-end-double-space: nil
 325 ;; End:
 326
 327 ;; arch-tag: b383b49a-494f-4ed0-a30a-cb6d5d2da4ff
 328 ;;; mh-acros.el ends here