lisp/mh-e/mh-acros.el

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