(locale-translate): New function, with old code extracted from
[emacs.git] / lisp / mh-e / mh-acros.el
blob21fe19bb8857b023f93f2e7b626f67ee9bf88b66
1 ;;; mh-acros.el --- macros used in MH-E
3 ;; Copyright (C) 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
5 ;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
6 ;; Maintainer: Bill Wohler <wohler@newt.com>
7 ;; Keywords: mail
8 ;; See: mh-e.el
10 ;; This file is part of GNU Emacs.
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, or (at your option)
15 ;; any later version.
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.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
27 ;;; Commentary:
29 ;; This file contains all macros that are used in more than one file.
30 ;; If you run "make recompile" in CVS Emacs and see the message
31 ;; "Source is newer than compiled," it is a sign that macro probably
32 ;; needs to be moved here.
34 ;; Historically, it was so named with a silent "m" so that it would be
35 ;; compiled first. Otherwise, "make recompile" in CVS Emacs would use
36 ;; compiled files with stale macro definitions. Later, no-byte-compile
37 ;; was added to the Local Variables section to avoid this problem and
38 ;; because it's pointless to compile a file full of macros. But we
39 ;; kept the name.
41 ;;; Change Log:
43 ;;; Code:
45 (require 'cl)
49 ;;; Compatibility
51 ;;;###mh-autoload
52 (defmacro mh-require-cl ()
53 "Macro to load \"cl\" if needed.
55 Emacs coding conventions require that the \"cl\" package not be
56 required at runtime. However, the \"cl\" package in Emacs 21.4
57 and earlier left \"cl\" routines in their macro expansions. In
58 particular, the expansion of (setf (gethash ...) ...) used
59 functions in \"cl\" at run time. This macro recognizes that and
60 loads \"cl\" appropriately."
61 (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash)
62 `(require 'cl)
63 `(eval-when-compile (require 'cl))))
65 ;;;###mh-autoload
66 (defmacro mh-do-in-gnu-emacs (&rest body)
67 "Execute BODY if in GNU Emacs."
68 (unless (featurep 'xemacs) `(progn ,@body)))
69 (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)
71 ;;;###mh-autoload
72 (defmacro mh-do-in-xemacs (&rest body)
73 "Execute BODY if in XEmacs."
74 (when (featurep 'xemacs) `(progn ,@body)))
75 (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)
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))))
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)
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)
108 ;;; Miscellaneous
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)))
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))))
132 ;; Shush compiler.
133 (defvar struct) ; XEmacs
134 (defvar x) ; XEmacs
135 (defvar y) ; XEmacs
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.
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))))
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 (setq save-modification-flag (car save-modification-flag)) ; CL style
182 `(prog1
183 (let ((mh-folder-updating-mod-flag (buffer-modified-p))
184 (buffer-read-only nil)
185 (buffer-file-name nil)) ;don't let the buffer get locked
186 (prog1
187 (progn
188 ,@body)
189 (mh-set-folder-modified-p mh-folder-updating-mod-flag)))
190 ,@(if (not save-modification-flag)
191 '((mh-set-folder-modified-p nil)))))
192 (put 'with-mh-folder-updating 'lisp-indent-hook 'defun)
194 ;;;###mh-autoload
195 (defmacro mh-in-show-buffer (show-buffer &rest body)
196 "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY).
197 Display buffer SHOW-BUFFER in other window and execute BODY in it.
198 Stronger than `save-excursion', weaker than `save-window-excursion'."
199 (setq show-buffer (car show-buffer)) ; CL style
200 `(let ((mh-in-show-buffer-saved-window (selected-window)))
201 (switch-to-buffer-other-window ,show-buffer)
202 (if mh-bury-show-buffer-flag (bury-buffer (current-buffer)))
203 (unwind-protect
204 (progn
205 ,@body)
206 (select-window mh-in-show-buffer-saved-window))))
207 (put 'mh-in-show-buffer 'lisp-indent-hook 'defun)
209 ;;;###mh-autoload
210 (defmacro mh-do-at-event-location (event &rest body)
211 "Switch to the location of EVENT and execute BODY.
212 After BODY has been executed return to original window. The
213 modification flag of the buffer in the event window is
214 preserved."
215 (let ((event-window (make-symbol "event-window"))
216 (event-position (make-symbol "event-position"))
217 (original-window (make-symbol "original-window"))
218 (original-position (make-symbol "original-position"))
219 (modified-flag (make-symbol "modified-flag")))
220 `(save-excursion
221 (let* ((,event-window
222 (or (mh-funcall-if-exists posn-window (event-start ,event))
223 (mh-funcall-if-exists event-window ,event)))
224 (,event-position
225 (or (mh-funcall-if-exists posn-point (event-start ,event))
226 (mh-funcall-if-exists event-closest-point ,event)))
227 (,original-window (selected-window))
228 (,original-position (progn
229 (set-buffer (window-buffer ,event-window))
230 (set-marker (make-marker) (point))))
231 (,modified-flag (buffer-modified-p))
232 (buffer-read-only nil))
233 (unwind-protect (progn
234 (select-window ,event-window)
235 (goto-char ,event-position)
236 ,@body)
237 (set-buffer-modified-p ,modified-flag)
238 (goto-char ,original-position)
239 (set-marker ,original-position nil)
240 (select-window ,original-window))))))
241 (put 'mh-do-at-event-location 'lisp-indent-hook 'defun)
245 ;;; Sequences and Ranges
247 ;;;###mh-autoload
248 (defmacro mh-seq-msgs (sequence)
249 "Extract messages from the given SEQUENCE."
250 (list 'cdr sequence))
252 ;;;###mh-autoload
253 (defmacro mh-iterate-on-messages-in-region (var begin end &rest body)
254 "Iterate over region.
256 VAR is bound to the message on the current line as we loop
257 starting from BEGIN till END. In each step BODY is executed.
259 If VAR is nil then the loop is executed without any binding."
260 (unless (symbolp var)
261 (error "Can not bind the non-symbol %s" var))
262 (let ((binding-needed-flag var))
263 `(save-excursion
264 (goto-char ,begin)
265 (beginning-of-line)
266 (while (and (<= (point) ,end) (not (eobp)))
267 (when (looking-at mh-scan-valid-regexp)
268 (let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ())
269 ,@body))
270 (forward-line 1)))))
271 (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun)
273 ;;;###mh-autoload
274 (defmacro mh-iterate-on-range (var range &rest body)
275 "Iterate an operation over a region or sequence.
277 VAR is bound to each message in turn in a loop over RANGE, which
278 can be a message number, a list of message numbers, a sequence, a
279 region in a cons cell, or a MH range (something like last:20) in
280 a string. In each iteration, BODY is executed.
282 The parameter RANGE is usually created with
283 `mh-interactive-range' in order to provide a uniform interface to
284 MH-E functions."
285 (unless (symbolp var)
286 (error "Can not bind the non-symbol %s" var))
287 (let ((binding-needed-flag var)
288 (msgs (make-symbol "msgs"))
289 (seq-hash-table (make-symbol "seq-hash-table")))
290 `(cond ((numberp ,range)
291 (when (mh-goto-msg ,range t t)
292 (let ,(if binding-needed-flag `((,var ,range)) ())
293 ,@body)))
294 ((and (consp ,range)
295 (numberp (car ,range)) (numberp (cdr ,range)))
296 (mh-iterate-on-messages-in-region ,var
297 (car ,range) (cdr ,range)
298 ,@body))
299 (t (let ((,msgs (cond ((and ,range (symbolp ,range))
300 (mh-seq-to-msgs ,range))
301 ((stringp ,range)
302 (mh-translate-range mh-current-folder
303 ,range))
304 (t ,range)))
305 (,seq-hash-table (make-hash-table)))
306 (dolist (msg ,msgs)
307 (setf (gethash msg ,seq-hash-table) t))
308 (mh-iterate-on-messages-in-region v (point-min) (point-max)
309 (when (gethash v ,seq-hash-table)
310 (let ,(if binding-needed-flag `((,var v)) ())
311 ,@body))))))))
312 (put 'mh-iterate-on-range 'lisp-indent-hook 'defun)
314 (provide 'mh-acros)
316 ;; Local Variables:
317 ;; no-byte-compile: t
318 ;; indent-tabs-mode: nil
319 ;; sentence-end-double-space: nil
320 ;; End:
322 ;; arch-tag: b383b49a-494f-4ed0-a30a-cb6d5d2da4ff
323 ;;; mh-acros.el ends here