Mercurial > emacs
comparison lisp/mh-e/mh-utils.el @ 49459:06b77df47802
* mh-e: Created directory. ChangeLog will appear in a week when we
release version 7.2.
* lisp/mail/mh-alias.el, lisp/mail/mh-comp.el,
lisp/mail/mh-customize.el, lisp/mail/mh-e.el, lisp/mail/mh-funcs.el,
lisp/mail/mh-identity.el, lisp/mail/mh-index.el,
lisp/mail/mh-loaddefs.el, lisp/mail/mh-mime.el, lisp/mail/mh-pick.el,
lisp/mail/mh-seq.el, lisp/mail/mh-speed.el, lisp/mail/mh-utils.el,
lisp/mail/mh-xemacs-compat.el: Moved to mh-e. Note that reply2.pbm and
reply2.xpm, which were created by the MH-E package, were left in mail
since they can probably be used by other mail packages.
* makefile.w32-in (WINS): Added mh-e.
* makefile.nt (WINS): Added mh-e.
author | Bill Wohler <wohler@newt.com> |
---|---|
date | Sun, 26 Jan 2003 02:38:37 +0000 |
parents | |
children | b35587af8747 |
comparison
equal
deleted
inserted
replaced
49458:5ddabc4c81b0 | 49459:06b77df47802 |
---|---|
1 ;;; mh-utils.el --- MH-E code needed for both sending and reading | |
2 | |
3 ;; Copyright (C) 1993, 1995, 1997, 2000, 2001, 2002 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Bill Wohler <wohler@newt.com> | |
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 2, or (at your option) | |
15 ;; 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; see the file COPYING. If not, write to the | |
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
25 ;; Boston, MA 02111-1307, USA. | |
26 | |
27 ;;; Commentary: | |
28 | |
29 ;; Internal support for MH-E package. | |
30 | |
31 ;;; Change Log: | |
32 | |
33 ;; $Id: mh-utils.el,v 1.34 2003/01/08 23:21:16 wohler Exp $ | |
34 | |
35 ;;; Code: | |
36 | |
37 ;; Is this XEmacs-land? Located here since needed by mh-customize.el. | |
38 (defvar mh-xemacs-flag (featurep 'xemacs) | |
39 "Non-nil means the current Emacs is XEmacs.") | |
40 | |
41 (require 'cl) | |
42 (require 'gnus-util) | |
43 (require 'font-lock) | |
44 (require 'mh-loaddefs) | |
45 (require 'mh-customize) | |
46 | |
47 (load "mm-decode" t t) ; Non-fatal dependency | |
48 (load "mm-view" t t) ; Non-fatal dependency | |
49 (load "executable" t t) ; Non-fatal dependency on | |
50 ; executable-find | |
51 | |
52 ;; Shush the byte-compiler | |
53 (defvar font-lock-auto-fontify) | |
54 (defvar font-lock-defaults) | |
55 (defvar mark-active) | |
56 (defvar tool-bar-mode) | |
57 | |
58 ;;; Autoloads | |
59 (autoload 'gnus-article-highlight-citation "gnus-cite") | |
60 (autoload 'mail-header-end "sendmail") | |
61 (autoload 'Info-goto-node "info") | |
62 (unless (fboundp 'make-hash-table) | |
63 (autoload 'make-hash-table "cl")) | |
64 | |
65 ;;; Set for local environment: | |
66 ;;; mh-progs and mh-lib used to be set in paths.el, which tried to | |
67 ;;; figure out at build time which of several possible directories MH | |
68 ;;; was installed into. But if you installed MH after building Emacs, | |
69 ;;; this would almost certainly be wrong, so now we do it at run time. | |
70 | |
71 (defvar mh-progs nil | |
72 "Directory containing MH commands, such as inc, repl, and rmm.") | |
73 | |
74 (defvar mh-lib nil | |
75 "Directory containing the MH library. | |
76 This directory contains, among other things, the components file.") | |
77 | |
78 (defvar mh-lib-progs nil | |
79 "Directory containing MH helper programs. | |
80 This directory contains, among other things, the mhl program.") | |
81 | |
82 (defvar mh-nmh-flag nil | |
83 "Non-nil means nmh is installed on this system instead of MH.") | |
84 | |
85 ;;;###autoload | |
86 (put 'mh-progs 'risky-local-variable t) | |
87 ;;;###autoload | |
88 (put 'mh-lib 'risky-local-variable t) | |
89 ;;;###autoload | |
90 (put 'mh-lib-progs 'risky-local-variable t) | |
91 ;;;###autoload | |
92 (put 'mh-nmh-flag 'risky-local-variable t) | |
93 | |
94 ;;; CL Replacements | |
95 (defun mh-search-from-end (char string) | |
96 "Return the position of last occurrence of CHAR in STRING. | |
97 If CHAR is not present in STRING then return nil. The function is used in lieu | |
98 of `search' in the CL package." | |
99 (loop for index from (1- (length string)) downto 0 | |
100 when (equal (aref string index) char) return index | |
101 finally return nil)) | |
102 | |
103 ;;; Macro to generate correct code for different emacs variants | |
104 | |
105 (defmacro mh-mark-active-p (check-transient-mark-mode-flag) | |
106 "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs. | |
107 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if | |
108 variable `transient-mark-mode' is active." | |
109 (cond (mh-xemacs-flag ;XEmacs | |
110 `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p))) | |
111 ((not check-transient-mark-mode-flag) ;GNU Emacs | |
112 `(and (boundp 'mark-active) mark-active)) | |
113 (t ;GNU Emacs | |
114 `(and (boundp 'transient-mark-mode) transient-mark-mode | |
115 (boundp 'mark-active) mark-active)))) | |
116 | |
117 ;;; Additional header fields that might someday be added: | |
118 ;;; "Sender: " "Reply-to: " | |
119 | |
120 (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" | |
121 "Regexp to find the number of a message in a scan line. | |
122 The message's number must be surrounded with \\( \\)") | |
123 | |
124 (defvar mh-scan-msg-overflow-regexp "^\\?[0-9]" | |
125 "Regexp to find a scan line in which the message number overflowed. | |
126 The message's number is left truncated in this case.") | |
127 | |
128 (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" | |
129 "Regexp to find message number width in an scan format. | |
130 The message number width must be surrounded with \\( \\).") | |
131 | |
132 (defvar mh-scan-msg-format-string "%d" | |
133 "Format string for width of the message number in a scan format. | |
134 Use `0%d' for zero-filled message numbers.") | |
135 | |
136 (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" | |
137 "Format string containing a regexp matching the scan listing for a message. | |
138 The desired message's number will be an argument to format.") | |
139 | |
140 (defvar mh-default-folder-for-message-function nil | |
141 "Function to select a default folder for refiling or Fcc. | |
142 If set to a function, that function is called with no arguments by | |
143 `\\[mh-refile-msg]' and `\\[mh-to-fcc]' to get a default when | |
144 prompting the user for a folder. The function is called from within a | |
145 `save-excursion', with point at the start of the message. It should | |
146 return the folder to offer as the refile or Fcc folder, as a string | |
147 with a leading `+' sign. It can also return an empty string to use no | |
148 default, or nil to calculate the default the usual way. | |
149 NOTE: This variable is not an ordinary hook; | |
150 It may not be a list of functions.") | |
151 | |
152 (defvar mh-show-buffer-mode-line-buffer-id "{show-%s} %d" | |
153 "Format string to produce `mode-line-buffer-identification' for show buffers. | |
154 First argument is folder name. Second is message number.") | |
155 | |
156 (defvar mh-cmd-note 4 | |
157 "Column to insert notation. | |
158 Use `mh-set-cmd-note' to modify it. | |
159 This value may be dynamically updated if `mh-adaptive-cmd-note-flag' is | |
160 non-nil and `mh-scan-format-file' is t. | |
161 Note that the first column is column number 0.") | |
162 (make-variable-buffer-local 'mh-cmd-note) | |
163 | |
164 (defvar mh-note-seq "%" | |
165 "String whose first character is used to notate messages in a sequence.") | |
166 | |
167 (defvar mh-mail-header-separator "--------" | |
168 "*Line used by MH to separate headers from text in messages being composed. | |
169 This variable should not be used directly in programs. Programs should use | |
170 `mail-header-separator' instead. `mail-header-separator' is initialized to | |
171 `mh-mail-header-separator' in `mh-letter-mode'; in other contexts, you may | |
172 have to perform this initialization yourself. | |
173 | |
174 Do not make this a regexp as it may be the argument to `insert' and it is | |
175 passed through `regexp-quote' before being used by functions like | |
176 `re-search-forward'.") | |
177 | |
178 ;; Variables for MIME display | |
179 | |
180 ;; Structure to keep track of MIME handles on a per buffer basis. | |
181 (defstruct (mh-buffer-data (:conc-name mh-mime-) | |
182 (:constructor mh-make-buffer-data)) | |
183 (handles ()) ; List of MIME handles | |
184 (handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of | |
185 ; nested messages | |
186 (parts-count 0) ; The button number is generated from | |
187 ; this number | |
188 (part-index-hash (make-hash-table))) ; Avoid incrementing the part number | |
189 ; for nested messages | |
190 ;;; This has to be a macro, since we do: (setf (mh-buffer-data) ...) | |
191 (defmacro mh-buffer-data () | |
192 "Convenience macro to get the MIME data structures of the current buffer." | |
193 `(gethash (current-buffer) mh-globals-hash)) | |
194 | |
195 (defvar mh-globals-hash (make-hash-table) | |
196 "Keeps track of MIME data on a per buffer basis.") | |
197 | |
198 (defvar mh-gnus-pgp-support-flag (not (not (locate-library "mml2015"))) | |
199 "Non-nil means installed Gnus has PGP support.") | |
200 | |
201 (defvar mh-mm-inline-media-tests | |
202 `(("image/jpeg" | |
203 mm-inline-image | |
204 (lambda (handle) | |
205 (mm-valid-and-fit-image-p 'jpeg handle))) | |
206 ("image/png" | |
207 mm-inline-image | |
208 (lambda (handle) | |
209 (mm-valid-and-fit-image-p 'png handle))) | |
210 ("image/gif" | |
211 mm-inline-image | |
212 (lambda (handle) | |
213 (mm-valid-and-fit-image-p 'gif handle))) | |
214 ("image/tiff" | |
215 mm-inline-image | |
216 (lambda (handle) | |
217 (mm-valid-and-fit-image-p 'tiff handle)) ) | |
218 ("image/xbm" | |
219 mm-inline-image | |
220 (lambda (handle) | |
221 (mm-valid-and-fit-image-p 'xbm handle))) | |
222 ("image/x-xbitmap" | |
223 mm-inline-image | |
224 (lambda (handle) | |
225 (mm-valid-and-fit-image-p 'xbm handle))) | |
226 ("image/xpm" | |
227 mm-inline-image | |
228 (lambda (handle) | |
229 (mm-valid-and-fit-image-p 'xpm handle))) | |
230 ("image/x-pixmap" | |
231 mm-inline-image | |
232 (lambda (handle) | |
233 (mm-valid-and-fit-image-p 'xpm handle))) | |
234 ("image/bmp" | |
235 mm-inline-image | |
236 (lambda (handle) | |
237 (mm-valid-and-fit-image-p 'bmp handle))) | |
238 ("image/x-portable-bitmap" | |
239 mm-inline-image | |
240 (lambda (handle) | |
241 (mm-valid-and-fit-image-p 'pbm handle))) | |
242 ("text/plain" mm-inline-text identity) | |
243 ("text/enriched" mm-inline-text identity) | |
244 ("text/richtext" mm-inline-text identity) | |
245 ("text/x-patch" mm-display-patch-inline | |
246 (lambda (handle) | |
247 (locate-library "diff-mode"))) | |
248 ("application/emacs-lisp" mm-display-elisp-inline identity) | |
249 ("application/x-emacs-lisp" mm-display-elisp-inline identity) | |
250 ("text/html" | |
251 ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text) | |
252 (lambda (handle) | |
253 (or (and (boundp 'mm-inline-text-html-renderer) | |
254 mm-inline-text-html-renderer) | |
255 (and (boundp 'mm-text-html-renderer) mm-text-html-renderer)))) | |
256 ("text/x-vcard" | |
257 mm-inline-text-vcard | |
258 (lambda (handle) | |
259 (or (featurep 'vcard) | |
260 (locate-library "vcard")))) | |
261 ("message/delivery-status" mm-inline-text identity) | |
262 ("message/rfc822" mh-mm-inline-message identity) | |
263 ;;("message/partial" mm-inline-partial identity) | |
264 ;;("message/external-body" mm-inline-external-body identity) | |
265 ("text/.*" mm-inline-text identity) | |
266 ("audio/wav" mm-inline-audio | |
267 (lambda (handle) | |
268 (and (or (featurep 'nas-sound) (featurep 'native-sound)) | |
269 (device-sound-enabled-p)))) | |
270 ("audio/au" | |
271 mm-inline-audio | |
272 (lambda (handle) | |
273 (and (or (featurep 'nas-sound) (featurep 'native-sound)) | |
274 (device-sound-enabled-p)))) | |
275 ("application/pgp-signature" ignore identity) | |
276 ("application/x-pkcs7-signature" ignore identity) | |
277 ("application/pkcs7-signature" ignore identity) | |
278 ("application/x-pkcs7-mime" ignore identity) | |
279 ("application/pkcs7-mime" ignore identity) | |
280 ("multipart/alternative" ignore identity) | |
281 ("multipart/mixed" ignore identity) | |
282 ("multipart/related" ignore identity) | |
283 ;; Disable audio and image | |
284 ("audio/.*" ignore ignore) | |
285 ("image/.*" ignore ignore) | |
286 ;; Default to displaying as text | |
287 (".*" mm-inline-text mm-readable-p)) | |
288 "Alist of media types/tests saying whether types can be displayed inline.") | |
289 | |
290 ;; Needed by mh-comp.el and mh-mime.el | |
291 (defvar mh-mhn-compose-insert-flag nil | |
292 "Non-nil means MIME insertion was done. | |
293 Triggers an automatic call to `mh-edit-mhn' in `mh-send-letter'. | |
294 This variable is buffer-local.") | |
295 (make-variable-buffer-local 'mh-mhn-compose-insert-flag) | |
296 | |
297 (defvar mh-mml-compose-insert-flag nil | |
298 "Non-nil means that a MIME insertion was done. | |
299 This buffer-local variable is used to remember if a MIME insertion was done. | |
300 Triggers an automatic call to `mh-mml-to-mime' in `mh-send-letter'.") | |
301 (make-variable-buffer-local 'mh-mml-compose-insert-flag) | |
302 | |
303 ;; Copy of `goto-address-mail-regexp' | |
304 (defvar mh-address-mail-regexp | |
305 "[-a-zA-Z0-9._]+@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+" | |
306 "A regular expression probably matching an e-mail address.") | |
307 | |
308 ;; From goto-addr.el, which we don't want to force-load on users. | |
309 ;;;###mh-autoload | |
310 (defun mh-goto-address-find-address-at-point () | |
311 "Find e-mail address around or before point. | |
312 Then search backwards to beginning of line for the start of an e-mail | |
313 address. If no e-mail address found, return nil." | |
314 (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) | |
315 (if (or (looking-at mh-address-mail-regexp) ; already at start | |
316 (and (re-search-forward mh-address-mail-regexp | |
317 (line-end-position) 'lim) | |
318 (goto-char (match-beginning 0)))) | |
319 (match-string-no-properties 0))) | |
320 | |
321 (defun mh-in-header-p () | |
322 "Return non-nil if the point is in the header of a draft message." | |
323 (< (point) (mail-header-end))) | |
324 | |
325 (defun mh-header-field-beginning () | |
326 "Move to the beginning of the current header field. | |
327 Handles RFC 822 continuation lines." | |
328 (beginning-of-line) | |
329 (while (looking-at "^[ \t]") | |
330 (forward-line -1))) | |
331 | |
332 (defun mh-header-field-end () | |
333 "Move to the end of the current header field. | |
334 Handles RFC 822 continuation lines." | |
335 (forward-line 1) | |
336 (while (looking-at "^[ \t]") | |
337 (forward-line 1)) | |
338 (backward-char 1)) ;to end of previous line | |
339 | |
340 (defun mh-letter-header-font-lock (limit) | |
341 "Return the entire mail header to font-lock. | |
342 Argument LIMIT limits search." | |
343 (if (= (point) limit) | |
344 nil | |
345 (let* ((mail-header-end (save-match-data (mail-header-end))) | |
346 (lesser-limit (if (< mail-header-end limit) mail-header-end limit))) | |
347 (when (mh-in-header-p) | |
348 (set-match-data (list 1 lesser-limit)) | |
349 (goto-char lesser-limit) | |
350 t)))) | |
351 | |
352 (defun mh-header-field-font-lock (field limit) | |
353 "Return the value of a header field FIELD to font-lock. | |
354 Argument LIMIT limits search." | |
355 (if (= (point) limit) | |
356 nil | |
357 (let* ((mail-header-end (mail-header-end)) | |
358 (lesser-limit (if (< mail-header-end limit) mail-header-end limit)) | |
359 (case-fold-search t)) | |
360 (when (and (< (point) mail-header-end) ;Only within header | |
361 (re-search-forward (format "^%s" field) lesser-limit t)) | |
362 (let ((match-one-b (match-beginning 0)) | |
363 (match-one-e (match-end 0))) | |
364 (mh-header-field-end) | |
365 (if (> (point) limit) ;Don't search for end beyond limit | |
366 (goto-char limit)) | |
367 (set-match-data (list match-one-b match-one-e | |
368 (1+ match-one-e) (point))) | |
369 t))))) | |
370 | |
371 (defun mh-header-to-font-lock (limit) | |
372 "Return the value of a header field To to font-lock. | |
373 Argument LIMIT limits search." | |
374 (mh-header-field-font-lock "To:" limit)) | |
375 | |
376 (defun mh-header-cc-font-lock (limit) | |
377 "Return the value of a header field cc to font-lock. | |
378 Argument LIMIT limits search." | |
379 (mh-header-field-font-lock "cc:" limit)) | |
380 | |
381 (defun mh-header-subject-font-lock (limit) | |
382 "Return the value of a header field Subject to font-lock. | |
383 Argument LIMIT limits search." | |
384 (mh-header-field-font-lock "Subject:" limit)) | |
385 | |
386 (eval-and-compile | |
387 ;; Otherwise byte-compilation fails on `mh-show-font-lock-keywords-with-cite' | |
388 (defvar mh-show-font-lock-keywords | |
389 '(("^\\(From:\\|Sender:\\)\\(.*\\)" (1 'default) (2 mh-show-from-face)) | |
390 (mh-header-to-font-lock (0 'default) (1 mh-show-to-face)) | |
391 (mh-header-cc-font-lock (0 'default) (1 mh-show-cc-face)) | |
392 ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" | |
393 (1 'default) (2 mh-show-from-face)) | |
394 (mh-header-subject-font-lock (0 'default) (1 mh-show-subject-face)) | |
395 ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" | |
396 (1 'default) (2 mh-show-cc-face)) | |
397 ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" | |
398 (1 'default) (2 mh-show-date-face)) | |
399 (mh-letter-header-font-lock (0 mh-show-header-face append t))) | |
400 "Additional expressions to highlight in MH-show mode.")) | |
401 | |
402 (defvar mh-show-font-lock-keywords-with-cite | |
403 (eval-when-compile | |
404 (let* ((cite-chars "[>|}]") | |
405 (cite-prefix "A-Za-z") | |
406 (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) | |
407 (append | |
408 mh-show-font-lock-keywords | |
409 (list | |
410 ;; Use MATCH-ANCHORED to effectively anchor the regexp left side. | |
411 `(,cite-chars | |
412 (,(concat "\\=[ \t]*" | |
413 "\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?" | |
414 "\\(" cite-chars "[ \t]*\\)\\)+" | |
415 "\\(.*\\)") | |
416 (beginning-of-line) (end-of-line) | |
417 (2 font-lock-constant-face nil t) | |
418 (4 font-lock-comment-face nil t))))))) | |
419 "Additional expressions to highlight in MH-show mode.") | |
420 | |
421 (defun mh-show-font-lock-fontify-region (beg end loudly) | |
422 "Limit font-lock in `mh-show-mode' to the header. | |
423 Used when `mh-highlight-citation-p' is set to gnus, leaving the body to be | |
424 dealt with by gnus highlighting. The region between BEG and END is | |
425 given over to be fontified and LOUDLY controls if a user sees a | |
426 message about the fontification operation." | |
427 (let ((header-end (mail-header-end))) | |
428 (cond | |
429 ((and (< beg header-end)(< end header-end)) | |
430 (font-lock-default-fontify-region beg end loudly)) | |
431 ((and (< beg header-end)(>= end header-end)) | |
432 (font-lock-default-fontify-region beg header-end loudly)) | |
433 (t | |
434 nil)))) | |
435 | |
436 ;; Needed to help shush the byte-compiler. | |
437 (if mh-xemacs-flag | |
438 (progn | |
439 (eval-and-compile | |
440 (require 'gnus) | |
441 (require 'gnus-art) | |
442 (require 'gnus-cite)))) | |
443 | |
444 (defun mh-gnus-article-highlight-citation () | |
445 "Highlight cited text in current buffer using gnus." | |
446 (interactive) | |
447 ;; Requiring gnus-cite should have been sufficient. However for Emacs21.1, | |
448 ;; recursive-load-depth-limit is only 10, so an error occurs. Also it may be | |
449 ;; better to have an autoload at top-level (though that won't work because | |
450 ;; of recursive-load-depth-limit). That gets rid of a compiler warning as | |
451 ;; well. | |
452 (unless mh-xemacs-flag | |
453 (require 'gnus-art) | |
454 (require 'gnus-cite)) | |
455 ;; Don't allow Gnus to create buttons while highlighting, maybe this is bad | |
456 ;; style? | |
457 (flet ((gnus-article-add-button (&rest args) nil)) | |
458 (let* ((modified (buffer-modified-p)) | |
459 (gnus-article-buffer (buffer-name)) | |
460 (gnus-cite-face-list `(,@(cdr gnus-cite-face-list) | |
461 ,(car gnus-cite-face-list)))) | |
462 (gnus-article-highlight-citation t) | |
463 (set-buffer-modified-p modified)))) | |
464 | |
465 ;;; Internal bookkeeping variables: | |
466 | |
467 ;; The value of `mh-folder-list-change-hook' is called whenever | |
468 ;; mh-folder-list variable is set. | |
469 ;; List of folder names for completion. | |
470 (defvar mh-folder-list nil) | |
471 | |
472 ;; Cached value of the `Path:' component in the user's MH profile. | |
473 ;; User's mail folder directory. | |
474 (defvar mh-user-path nil) | |
475 | |
476 ;; An mh-draft-folder of nil means do not use a draft folder. | |
477 ;; Cached value of the `Draft-Folder:' component in the user's MH profile. | |
478 ;; Name of folder containing draft messages. | |
479 (defvar mh-draft-folder nil) | |
480 | |
481 ;; Cached value of the `Unseen-Sequence:' component in the user's MH profile. | |
482 ;; Name of the Unseen sequence. | |
483 (defvar mh-unseen-seq nil) | |
484 | |
485 ;; Cached value of the `Previous-Sequence:' component in the user's MH | |
486 ;; profile. | |
487 ;; Name of the Previous sequence. | |
488 (defvar mh-previous-seq nil) | |
489 | |
490 ;; Cached value of the `Inbox:' component in the user's MH profile, | |
491 ;; or "+inbox" if no such component. | |
492 ;; Name of the Inbox folder. | |
493 (defvar mh-inbox nil) | |
494 | |
495 ;; Name of MH-E scratch buffer. | |
496 (defconst mh-temp-buffer " *mh-temp*") | |
497 | |
498 ;; Name of the MH-E folder list buffer. | |
499 (defconst mh-temp-folders-buffer "*Folders*") | |
500 | |
501 ;; Name of the MH-E sequences list buffer. | |
502 (defconst mh-temp-sequences-buffer "*Sequences*") | |
503 | |
504 ;; Window configuration before MH-E command. | |
505 (defvar mh-previous-window-config nil) | |
506 | |
507 ;;Non-nil means next SPC or whatever goes to next undeleted message. | |
508 (defvar mh-page-to-next-msg-flag nil) | |
509 | |
510 ;;; Internal variables local to a folder. | |
511 | |
512 ;; Name of current folder, a string. | |
513 (defvar mh-current-folder nil) | |
514 | |
515 ;; Buffer that displays message for this folder. | |
516 (defvar mh-show-buffer nil) | |
517 | |
518 ;; Full path of directory for this folder. | |
519 (defvar mh-folder-filename nil) | |
520 | |
521 ;;Number of msgs in buffer. | |
522 (defvar mh-msg-count nil) | |
523 | |
524 ;; If non-nil, show the message in a separate window. | |
525 (defvar mh-showing-mode nil) | |
526 | |
527 (defvar mh-show-mode-map (make-sparse-keymap) | |
528 "Keymap used by the show buffer.") | |
529 | |
530 (defvar mh-show-folder-buffer nil | |
531 "Keeps track of folder whose message is being displayed.") | |
532 | |
533 ;;; This holds a documentation string used by describe-mode. | |
534 (defun mh-showing-mode (&optional arg) | |
535 "Change whether messages should be displayed. | |
536 With arg, display messages iff ARG is positive." | |
537 (setq mh-showing-mode | |
538 (if (null arg) | |
539 (not mh-showing-mode) | |
540 (> (prefix-numeric-value arg) 0)))) | |
541 | |
542 ;; The sequences of this folder. An alist of (seq . msgs). | |
543 (defvar mh-seq-list nil) | |
544 | |
545 ;; List of displayed messages to be removed from the Unseen sequence. | |
546 (defvar mh-seen-list nil) | |
547 | |
548 ;; If non-nil, show buffer contains message with all headers. | |
549 ;; If nil, show buffer contains message processed normally. | |
550 ;; Showing message with headers or normally. | |
551 (defvar mh-showing-with-headers nil) | |
552 | |
553 | |
554 ;;; MH-E macros | |
555 | |
556 (defmacro with-mh-folder-updating (save-modification-flag &rest body) | |
557 "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). | |
558 Execute BODY, which can modify the folder buffer without having to | |
559 worry about file locking or the read-only flag, and return its result. | |
560 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification | |
561 flag is unchanged, otherwise it is cleared." | |
562 (setq save-modification-flag (car save-modification-flag)) ; CL style | |
563 `(prog1 | |
564 (let ((mh-folder-updating-mod-flag (buffer-modified-p)) | |
565 (buffer-read-only nil) | |
566 (buffer-file-name nil)) ;don't let the buffer get locked | |
567 (prog1 | |
568 (progn | |
569 ,@body) | |
570 (mh-set-folder-modified-p mh-folder-updating-mod-flag))) | |
571 ,@(if (not save-modification-flag) | |
572 '((mh-set-folder-modified-p nil))))) | |
573 | |
574 (put 'with-mh-folder-updating 'lisp-indent-hook 1) | |
575 | |
576 (defmacro mh-in-show-buffer (show-buffer &rest body) | |
577 "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY). | |
578 Display buffer SHOW-BUFFER in other window and execute BODY in it. | |
579 Stronger than `save-excursion', weaker than `save-window-excursion'." | |
580 (setq show-buffer (car show-buffer)) ; CL style | |
581 `(let ((mh-in-show-buffer-saved-window (selected-window))) | |
582 (switch-to-buffer-other-window ,show-buffer) | |
583 (if mh-bury-show-buffer-flag (bury-buffer (current-buffer))) | |
584 (unwind-protect | |
585 (progn | |
586 ,@body) | |
587 (select-window mh-in-show-buffer-saved-window)))) | |
588 | |
589 (put 'mh-in-show-buffer 'lisp-indent-hook 1) | |
590 | |
591 (defmacro mh-make-seq (name msgs) | |
592 "Create sequence NAME with the given MSGS." | |
593 (list 'cons name msgs)) | |
594 | |
595 (defmacro mh-seq-name (sequence) | |
596 "Extract sequence name from the given SEQUENCE." | |
597 (list 'car sequence)) | |
598 | |
599 (defmacro mh-seq-msgs (sequence) | |
600 "Extract messages from the given SEQUENCE." | |
601 (list 'cdr sequence)) | |
602 | |
603 (defun mh-recenter (arg) | |
604 "Like recenter but with three improvements: | |
605 - At the end of the buffer it tries to show fewer empty lines. | |
606 - operates only if the current buffer is in the selected window. | |
607 (Commands like `save-some-buffers' can make this false.) | |
608 - nil ARG means recenter as if prefix argument had been given." | |
609 (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) | |
610 nil) | |
611 ((= (point-max) (save-excursion | |
612 (forward-line (- (/ (window-height) 2) 2)) | |
613 (point))) | |
614 (let ((lines-from-end 2)) | |
615 (save-excursion | |
616 (while (> (point-max) (progn (forward-line) (point))) | |
617 (incf lines-from-end))) | |
618 (recenter (- lines-from-end)))) | |
619 ;; '(4) is the same as C-u prefix argument. | |
620 (t (recenter (or arg '(4)))))) | |
621 | |
622 (defun mh-start-of-uncleaned-message () | |
623 "Position uninteresting headers off the top of the window." | |
624 (let ((case-fold-search t)) | |
625 (re-search-forward | |
626 "^To:\\|^Cc:\\|^From:\\|^Subject:\\|^Date:" nil t) | |
627 (beginning-of-line) | |
628 (mh-recenter 0))) | |
629 | |
630 (defun mh-invalidate-show-buffer () | |
631 "Invalidate the show buffer so we must update it to use it." | |
632 (if (get-buffer mh-show-buffer) | |
633 (save-excursion | |
634 (set-buffer mh-show-buffer) | |
635 (mh-unvisit-file)))) | |
636 | |
637 (defun mh-unvisit-file () | |
638 "Separate current buffer from the message file it was visiting." | |
639 (or (not (buffer-modified-p)) | |
640 (null buffer-file-name) ;we've been here before | |
641 (yes-or-no-p (format "Message %s modified; flush changes? " | |
642 (file-name-nondirectory buffer-file-name))) | |
643 (error "Flushing changes not confirmed")) | |
644 (clear-visited-file-modtime) | |
645 (unlock-buffer) | |
646 (setq buffer-file-name nil)) | |
647 | |
648 ;;;###mh-autoload | |
649 (defun mh-get-msg-num (error-if-no-message) | |
650 "Return the message number of the displayed message. | |
651 If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is | |
652 not pointing to a message." | |
653 (save-excursion | |
654 (beginning-of-line) | |
655 (cond ((looking-at mh-scan-msg-number-regexp) | |
656 (string-to-int (buffer-substring (match-beginning 1) | |
657 (match-end 1)))) | |
658 (error-if-no-message | |
659 (error "Cursor not pointing to message")) | |
660 (t nil)))) | |
661 | |
662 (defun mh-folder-name-p (name) | |
663 "Return non-nil if NAME is the name of a folder. | |
664 A name (a string or symbol) can be a folder name if it begins with \"+\"." | |
665 (if (symbolp name) | |
666 (eq (aref (symbol-name name) 0) ?+) | |
667 (and (> (length name) 0) | |
668 (eq (aref name 0) ?+)))) | |
669 | |
670 | |
671 (defun mh-expand-file-name (filename &optional default) | |
672 "Expand FILENAME like `expand-file-name', but also handle MH folder names. | |
673 Any filename that starts with '+' is treated as a folder name. | |
674 See `expand-file-name' for description of DEFAULT." | |
675 (if (mh-folder-name-p filename) | |
676 (expand-file-name (substring filename 1) mh-user-path) | |
677 (expand-file-name filename default))) | |
678 | |
679 | |
680 (defun mh-msg-filename (msg &optional folder) | |
681 "Return the file name of MSG in FOLDER (default current folder)." | |
682 (expand-file-name (int-to-string msg) | |
683 (if folder | |
684 (mh-expand-file-name folder) | |
685 mh-folder-filename))) | |
686 | |
687 ;;; Infrastructure to generate show-buffer functions from folder functions | |
688 ;;; XEmacs does not have deactivate-mark? What is the equivalent of | |
689 ;;; transient-mark-mode for XEmacs? Should we be restoring the mark in the | |
690 ;;; folder buffer after the operation has been carried out. | |
691 (defmacro mh-defun-show-buffer (function original-function | |
692 &optional dont-return) | |
693 "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. | |
694 If the buffer we start in is still visible and DONT-RETURN is nil then switch | |
695 to it after that." | |
696 `(defun ,function () | |
697 ,(format "Calls %s from the message's folder.\n%s\nSee `%s' for more info.\n" | |
698 original-function | |
699 (if dont-return "" | |
700 "When function completes, returns to the show buffer if it is | |
701 still visible.\n") | |
702 original-function) | |
703 (interactive) | |
704 (when (buffer-live-p (get-buffer mh-show-folder-buffer)) | |
705 (let ((config (current-window-configuration)) | |
706 (folder-buffer mh-show-folder-buffer) | |
707 (normal-exit nil) | |
708 ,@(if dont-return () '((cur-buffer-name (buffer-name))))) | |
709 (pop-to-buffer mh-show-folder-buffer nil) | |
710 (unless (equal (buffer-name | |
711 (window-buffer (frame-first-window (selected-frame)))) | |
712 folder-buffer) | |
713 (delete-other-windows)) | |
714 (mh-goto-cur-msg t) | |
715 (and (fboundp 'deactivate-mark) (deactivate-mark)) | |
716 (unwind-protect | |
717 (prog1 (call-interactively (function ,original-function)) | |
718 (setq normal-exit t)) | |
719 (and (fboundp 'deactivate-mark) (deactivate-mark)) | |
720 (cond ((not normal-exit) | |
721 (set-window-configuration config)) | |
722 ,(if dont-return | |
723 `(t (setq mh-previous-window-config config)) | |
724 `((and (get-buffer cur-buffer-name) | |
725 (window-live-p (get-buffer-window | |
726 (get-buffer cur-buffer-name)))) | |
727 (pop-to-buffer (get-buffer cur-buffer-name) nil))))))))) | |
728 | |
729 ;;; Generate interactive functions for the show buffer from the corresponding | |
730 ;;; folder functions. | |
731 (mh-defun-show-buffer mh-show-previous-undeleted-msg | |
732 mh-previous-undeleted-msg) | |
733 (mh-defun-show-buffer mh-show-next-undeleted-msg | |
734 mh-next-undeleted-msg) | |
735 (mh-defun-show-buffer mh-show-quit mh-quit) | |
736 (mh-defun-show-buffer mh-show-delete-msg mh-delete-msg) | |
737 (mh-defun-show-buffer mh-show-refile-msg mh-refile-msg) | |
738 (mh-defun-show-buffer mh-show-undo mh-undo) | |
739 (mh-defun-show-buffer mh-show-execute-commands mh-execute-commands) | |
740 (mh-defun-show-buffer mh-show-reply mh-reply t) | |
741 (mh-defun-show-buffer mh-show-redistribute mh-redistribute) | |
742 (mh-defun-show-buffer mh-show-forward mh-forward t) | |
743 (mh-defun-show-buffer mh-show-header-display mh-header-display) | |
744 (mh-defun-show-buffer mh-show-refile-or-write-again | |
745 mh-refile-or-write-again) | |
746 (mh-defun-show-buffer mh-show-show mh-show) | |
747 (mh-defun-show-buffer mh-show-write-message-to-file | |
748 mh-write-msg-to-file) | |
749 (mh-defun-show-buffer mh-show-extract-rejected-mail | |
750 mh-extract-rejected-mail t) | |
751 (mh-defun-show-buffer mh-show-delete-msg-no-motion | |
752 mh-delete-msg-no-motion) | |
753 (mh-defun-show-buffer mh-show-first-msg mh-first-msg) | |
754 (mh-defun-show-buffer mh-show-last-msg mh-last-msg) | |
755 (mh-defun-show-buffer mh-show-copy-msg mh-copy-msg) | |
756 (mh-defun-show-buffer mh-show-edit-again mh-edit-again t) | |
757 (mh-defun-show-buffer mh-show-goto-msg mh-goto-msg) | |
758 (mh-defun-show-buffer mh-show-inc-folder mh-inc-folder) | |
759 (mh-defun-show-buffer mh-show-delete-subject-or-thread | |
760 mh-delete-subject-or-thread) | |
761 (mh-defun-show-buffer mh-show-delete-subject mh-delete-subject) | |
762 (mh-defun-show-buffer mh-show-print-msg mh-print-msg) | |
763 (mh-defun-show-buffer mh-show-send mh-send t) | |
764 (mh-defun-show-buffer mh-show-toggle-showing mh-toggle-showing t) | |
765 (mh-defun-show-buffer mh-show-pipe-msg mh-pipe-msg t) | |
766 (mh-defun-show-buffer mh-show-sort-folder mh-sort-folder) | |
767 (mh-defun-show-buffer mh-show-visit-folder mh-visit-folder t) | |
768 (mh-defun-show-buffer mh-show-rescan-folder mh-rescan-folder) | |
769 (mh-defun-show-buffer mh-show-pack-folder mh-pack-folder) | |
770 (mh-defun-show-buffer mh-show-kill-folder mh-kill-folder t) | |
771 (mh-defun-show-buffer mh-show-list-folders mh-list-folders t) | |
772 (mh-defun-show-buffer mh-show-search-folder mh-search-folder t) | |
773 (mh-defun-show-buffer mh-show-undo-folder mh-undo-folder) | |
774 (mh-defun-show-buffer mh-show-delete-msg-from-seq | |
775 mh-delete-msg-from-seq) | |
776 (mh-defun-show-buffer mh-show-delete-seq mh-delete-seq) | |
777 (mh-defun-show-buffer mh-show-list-sequences mh-list-sequences) | |
778 (mh-defun-show-buffer mh-show-narrow-to-seq mh-narrow-to-seq) | |
779 (mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq) | |
780 (mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq) | |
781 (mh-defun-show-buffer mh-show-widen mh-widen) | |
782 (mh-defun-show-buffer mh-show-narrow-to-subject | |
783 mh-narrow-to-subject) | |
784 (mh-defun-show-buffer mh-show-store-msg mh-store-msg) | |
785 (mh-defun-show-buffer mh-show-page-digest mh-page-digest) | |
786 (mh-defun-show-buffer mh-show-page-digest-backwards | |
787 mh-page-digest-backwards) | |
788 (mh-defun-show-buffer mh-show-burst-digest mh-burst-digest) | |
789 (mh-defun-show-buffer mh-show-page-msg mh-page-msg) | |
790 (mh-defun-show-buffer mh-show-previous-page mh-previous-page) | |
791 (mh-defun-show-buffer mh-show-modify mh-modify t) | |
792 (mh-defun-show-buffer mh-show-next-button mh-next-button) | |
793 (mh-defun-show-buffer mh-show-prev-button mh-prev-button) | |
794 (mh-defun-show-buffer mh-show-toggle-mime-part mh-folder-toggle-mime-part) | |
795 (mh-defun-show-buffer mh-show-save-mime-part mh-folder-save-mime-part) | |
796 (mh-defun-show-buffer mh-show-inline-mime-part mh-folder-inline-mime-part) | |
797 (mh-defun-show-buffer mh-show-toggle-threads mh-toggle-threads) | |
798 (mh-defun-show-buffer mh-show-thread-delete mh-thread-delete) | |
799 (mh-defun-show-buffer mh-show-thread-refile mh-thread-refile) | |
800 (mh-defun-show-buffer mh-show-update-sequences mh-update-sequences) | |
801 (mh-defun-show-buffer mh-show-next-unread-msg mh-next-unread-msg) | |
802 (mh-defun-show-buffer mh-show-previous-unread-msg mh-previous-unread-msg) | |
803 (mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor) | |
804 (mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling) | |
805 (mh-defun-show-buffer mh-show-thread-previous-sibling | |
806 mh-thread-previous-sibling) | |
807 (mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t) | |
808 | |
809 ;;; Populate mh-show-mode-map | |
810 (gnus-define-keys mh-show-mode-map | |
811 " " mh-show-page-msg | |
812 "!" mh-show-refile-or-write-again | |
813 "," mh-show-header-display | |
814 "." mh-show-show | |
815 ">" mh-show-write-message-to-file | |
816 "?" mh-help | |
817 "E" mh-show-extract-rejected-mail | |
818 "M" mh-show-modify | |
819 "\177" mh-show-previous-page | |
820 "\C-d" mh-show-delete-msg-no-motion | |
821 "\t" mh-show-next-button | |
822 [backtab] mh-show-prev-button | |
823 "\M-\t" mh-show-prev-button | |
824 "\ed" mh-show-redistribute | |
825 "^" mh-show-refile-msg | |
826 "c" mh-show-copy-msg | |
827 "d" mh-show-delete-msg | |
828 "e" mh-show-edit-again | |
829 "f" mh-show-forward | |
830 "g" mh-show-goto-msg | |
831 "i" mh-show-inc-folder | |
832 "k" mh-show-delete-subject-or-thread | |
833 "l" mh-show-print-msg | |
834 "m" mh-show-send | |
835 "n" mh-show-next-undeleted-msg | |
836 "\M-n" mh-show-next-unread-msg | |
837 "o" mh-show-refile-msg | |
838 "p" mh-show-previous-undeleted-msg | |
839 "\M-p" mh-show-previous-unread-msg | |
840 "q" mh-show-quit | |
841 "r" mh-show-reply | |
842 "s" mh-show-send | |
843 "t" mh-show-toggle-showing | |
844 "u" mh-show-undo | |
845 "x" mh-show-execute-commands | |
846 "v" mh-show-index-visit-folder | |
847 "|" mh-show-pipe-msg) | |
848 | |
849 (gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) | |
850 "?" mh-prefix-help | |
851 "S" mh-show-sort-folder | |
852 "f" mh-show-visit-folder | |
853 "i" mh-index-search | |
854 "k" mh-show-kill-folder | |
855 "l" mh-show-list-folders | |
856 "o" mh-show-visit-folder | |
857 "r" mh-show-rescan-folder | |
858 "s" mh-show-search-folder | |
859 "t" mh-show-toggle-threads | |
860 "u" mh-show-undo-folder | |
861 "v" mh-show-visit-folder) | |
862 | |
863 (gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map) | |
864 "?" mh-prefix-help | |
865 "d" mh-show-delete-msg-from-seq | |
866 "k" mh-show-delete-seq | |
867 "l" mh-show-list-sequences | |
868 "n" mh-show-narrow-to-seq | |
869 "p" mh-show-put-msg-in-seq | |
870 "s" mh-show-msg-is-in-seq | |
871 "w" mh-show-widen) | |
872 | |
873 (gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) | |
874 "?" mh-prefix-help | |
875 "u" mh-show-thread-ancestor | |
876 "p" mh-show-thread-previous-sibling | |
877 "n" mh-show-thread-next-sibling | |
878 "t" mh-show-toggle-threads | |
879 "d" mh-show-thread-delete | |
880 "o" mh-show-thread-refile) | |
881 | |
882 (gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) | |
883 "?" mh-prefix-help | |
884 "s" mh-show-narrow-to-subject | |
885 "w" mh-show-widen) | |
886 | |
887 (gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) | |
888 "?" mh-prefix-help | |
889 "s" mh-show-store-msg | |
890 "u" mh-show-store-msg) | |
891 | |
892 ;; Untested... | |
893 (gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map) | |
894 "?" mh-prefix-help | |
895 " " mh-show-page-digest | |
896 "\177" mh-show-page-digest-backwards | |
897 "b" mh-show-burst-digest) | |
898 | |
899 (gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) | |
900 "?" mh-prefix-help | |
901 "a" mh-mime-save-parts | |
902 "v" mh-show-toggle-mime-part | |
903 "o" mh-show-save-mime-part | |
904 "i" mh-show-inline-mime-part | |
905 "\t" mh-show-next-button | |
906 [backtab] mh-show-prev-button | |
907 "\M-\t" mh-show-prev-button) | |
908 | |
909 (easy-menu-define | |
910 mh-show-sequence-menu mh-show-mode-map "Menu for MH-E folder-sequence." | |
911 '("Sequence" | |
912 ["Add Message to Sequence..." mh-show-put-msg-in-seq t] | |
913 ["List Sequences for Message" mh-show-msg-is-in-seq t] | |
914 ["Delete Message from Sequence..." mh-show-delete-msg-from-seq t] | |
915 ["List Sequences in Folder..." mh-show-list-sequences t] | |
916 ["Delete Sequence..." mh-show-delete-seq t] | |
917 ["Narrow to Sequence..." mh-show-narrow-to-seq t] | |
918 ["Widen from Sequence" mh-show-widen t] | |
919 "--" | |
920 ["Narrow to Subject Sequence" mh-show-narrow-to-subject t] | |
921 ["Delete Rest of Same Subject" mh-show-delete-subject t] | |
922 "--" | |
923 ["Push State Out to MH" mh-show-update-sequences t])) | |
924 | |
925 (easy-menu-define | |
926 mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message." | |
927 '("Message" | |
928 ["Show Message" mh-show-show t] | |
929 ["Show Message with Header" mh-show-header-display t] | |
930 ["Next Message" mh-show-next-undeleted-msg t] | |
931 ["Previous Message" mh-show-previous-undeleted-msg t] | |
932 ["Go to First Message" mh-show-first-msg t] | |
933 ["Go to Last Message" mh-show-last-msg t] | |
934 ["Go to Message by Number..." mh-show-goto-msg t] | |
935 ["Modify Message" mh-show-modify t] | |
936 ["Delete Message" mh-show-delete-msg t] | |
937 ["Refile Message" mh-show-refile-msg t] | |
938 ["Undo Delete/Refile" mh-show-undo t] | |
939 ["Process Delete/Refile" mh-show-execute-commands t] | |
940 "--" | |
941 ["Compose a New Message" mh-send t] | |
942 ["Reply to Message..." mh-show-reply t] | |
943 ["Forward Message..." mh-show-forward t] | |
944 ["Redistribute Message..." mh-show-redistribute t] | |
945 ["Edit Message Again" mh-show-edit-again t] | |
946 ["Re-edit a Bounced Message" mh-show-extract-rejected-mail t] | |
947 "--" | |
948 ["Copy Message to Folder..." mh-show-copy-msg t] | |
949 ["Print Message" mh-show-print-msg t] | |
950 ["Write Message to File..." mh-show-write-msg-to-file t] | |
951 ["Pipe Message to Command..." mh-show-pipe-msg t] | |
952 ["Unpack Uuencoded Message..." mh-show-store-msg t] | |
953 ["Burst Digest Message" mh-show-burst-digest t])) | |
954 | |
955 (easy-menu-define | |
956 mh-show-folder-menu mh-show-mode-map "Menu for MH-E folder." | |
957 '("Folder" | |
958 ["Incorporate New Mail" mh-show-inc-folder t] | |
959 ["Toggle Show/Folder" mh-show-toggle-showing t] | |
960 ["Execute Delete/Refile" mh-show-execute-commands t] | |
961 ["Rescan Folder" mh-show-rescan-folder t] | |
962 ["Thread Folder" mh-show-toggle-threads t] | |
963 ["Pack Folder" mh-show-pack-folder t] | |
964 ["Sort Folder" mh-show-sort-folder t] | |
965 "--" | |
966 ["List Folders" mh-show-list-folders t] | |
967 ["Visit a Folder..." mh-show-visit-folder t] | |
968 ["Search a Folder..." mh-show-search-folder t] | |
969 ["Indexed Search..." mh-index-search t] | |
970 "--" | |
971 ["Quit MH-E" mh-quit t])) | |
972 | |
973 | |
974 ;;; Ensure new buffers won't get this mode if default-major-mode is nil. | |
975 (put 'mh-show-mode 'mode-class 'special) | |
976 | |
977 (define-derived-mode mh-show-mode text-mode "MH-Show" | |
978 "Major mode for showing messages in MH-E.\\<mh-show-mode-map> | |
979 The value of `mh-show-mode-hook' is a list of functions to | |
980 be called, with no arguments, upon entry to this mode." | |
981 (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) | |
982 (setq paragraph-start (default-value 'paragraph-start)) | |
983 (mh-show-unquote-From) | |
984 (mh-show-xface) | |
985 (mh-show-addr) | |
986 (make-local-variable 'font-lock-defaults) | |
987 ;;(set (make-local-variable 'font-lock-support-mode) nil) | |
988 (cond | |
989 ((equal mh-highlight-citation-p 'font-lock) | |
990 (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) | |
991 ((equal mh-highlight-citation-p 'gnus) | |
992 (setq font-lock-defaults '((mh-show-font-lock-keywords) | |
993 t nil nil nil | |
994 (font-lock-fontify-region-function | |
995 . mh-show-font-lock-fontify-region))) | |
996 (mh-gnus-article-highlight-citation)) | |
997 (t | |
998 (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) | |
999 (if (and mh-xemacs-flag | |
1000 font-lock-auto-fontify) | |
1001 (turn-on-font-lock)) | |
1002 (if (and (boundp 'tool-bar-mode) tool-bar-mode) | |
1003 (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)) | |
1004 (when mh-decode-mime-flag | |
1005 (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t)) | |
1006 (easy-menu-add mh-show-sequence-menu) | |
1007 (easy-menu-add mh-show-message-menu) | |
1008 (easy-menu-add mh-show-folder-menu) | |
1009 (make-local-variable 'mh-show-folder-buffer) | |
1010 (buffer-disable-undo) | |
1011 (setq buffer-read-only t) | |
1012 (use-local-map mh-show-mode-map) | |
1013 (run-hooks 'mh-show-mode-hook)) | |
1014 | |
1015 (defun mh-show-addr () | |
1016 "Use `goto-address'." | |
1017 (when mh-show-use-goto-addr-flag | |
1018 (if (not (featurep 'goto-addr)) | |
1019 (load "goto-addr" t t)) | |
1020 (if (fboundp 'goto-address) | |
1021 (goto-address)))) | |
1022 | |
1023 (defvar mh-show-xface-function | |
1024 (cond ((and mh-xemacs-flag (locate-library "x-face")) | |
1025 (load "x-face" t t) | |
1026 (if (fboundp 'x-face-xmas-wl-display-x-face) | |
1027 #'x-face-xmas-wl-display-x-face | |
1028 #'ignore)) | |
1029 ((and (not mh-xemacs-flag) (>= emacs-major-version 21)) | |
1030 (load "x-face-e21" t t) | |
1031 (if (fboundp 'x-face-decode-message-header) | |
1032 #'x-face-decode-message-header | |
1033 #'ignore)) | |
1034 (t #'ignore)) | |
1035 "Determine at run time what function should be called to display X-Face.") | |
1036 | |
1037 (defun mh-show-xface () | |
1038 "Display X-Face." | |
1039 (when (and mh-show-use-xface-flag | |
1040 (or mh-decode-mime-flag mhl-formfile | |
1041 mh-clean-message-header-flag)) | |
1042 (funcall mh-show-xface-function))) | |
1043 | |
1044 (defun mh-maybe-show (&optional msg) | |
1045 "Display message at cursor, but only if in show mode. | |
1046 If optional arg MSG is non-nil, display that message instead." | |
1047 (if mh-showing-mode (mh-show msg))) | |
1048 | |
1049 (defun mh-show (&optional message) | |
1050 "Show message at cursor. | |
1051 If optional argument MESSAGE is non-nil, display that message instead. | |
1052 Force a two-window display with the folder window on top (size | |
1053 `mh-summary-height') and the show buffer below it. | |
1054 If the message is already visible, display the start of the message. | |
1055 | |
1056 Display of the message is controlled by setting the variables | |
1057 `mh-clean-message-header-flag' and `mhl-formfile'. The default behavior is | |
1058 to scroll uninteresting headers off the top of the window. | |
1059 Type \"\\[mh-header-display]\" to see the message with all its headers." | |
1060 (interactive) | |
1061 (and mh-showing-with-headers | |
1062 (or mhl-formfile mh-clean-message-header-flag) | |
1063 (mh-invalidate-show-buffer)) | |
1064 (mh-show-msg message)) | |
1065 | |
1066 (defun mh-show-mouse (EVENT) | |
1067 "Move point to mouse EVENT and show message." | |
1068 (interactive "e") | |
1069 (mouse-set-point EVENT) | |
1070 (mh-show)) | |
1071 | |
1072 (defun mh-show-msg (msg) | |
1073 "Show MSG. | |
1074 The value of `mh-show-hook' is a list of functions to be called, with no | |
1075 arguments, after the message has been displayed." | |
1076 (if (not msg) | |
1077 (setq msg (mh-get-msg-num t))) | |
1078 (mh-showing-mode t) | |
1079 (setq mh-page-to-next-msg-flag nil) | |
1080 (let ((folder mh-current-folder) | |
1081 (clean-message-header mh-clean-message-header-flag) | |
1082 (show-window (get-buffer-window mh-show-buffer))) | |
1083 (if (not (eq (next-window (minibuffer-window)) (selected-window))) | |
1084 (delete-other-windows)) ; force ourself to the top window | |
1085 (mh-in-show-buffer (mh-show-buffer) | |
1086 (if (and show-window | |
1087 (equal (mh-msg-filename msg folder) buffer-file-name)) | |
1088 (progn ;just back up to start | |
1089 (goto-char (point-min)) | |
1090 (if (not clean-message-header) | |
1091 (mh-start-of-uncleaned-message))) | |
1092 (mh-display-msg msg folder)))) | |
1093 (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split | |
1094 (shrink-window (- (window-height) mh-summary-height))) | |
1095 (mh-recenter nil) | |
1096 (if (not (memq msg mh-seen-list)) | |
1097 (setq mh-seen-list (cons msg mh-seen-list))) | |
1098 (when mh-update-sequences-after-mh-show-flag | |
1099 (mh-update-sequences)) | |
1100 (run-hooks 'mh-show-hook)) | |
1101 | |
1102 (defun mh-modify (&optional message) | |
1103 "Edit message at cursor. | |
1104 If optional argument MESSAGE is non-nil, edit that message instead. | |
1105 Force a two-window display with the folder window on top (size | |
1106 `mh-summary-height') and the message editing buffer below it. | |
1107 | |
1108 The message is displayed in raw form." | |
1109 (interactive) | |
1110 (let* ((message (or message (mh-get-msg-num t))) | |
1111 (msg-filename (mh-msg-filename message)) | |
1112 edit-buffer) | |
1113 (when (not (file-exists-p msg-filename)) | |
1114 (error "Message %d does not exist" message)) | |
1115 | |
1116 ;; Invalidate the show buffer if it is showing the same message that is | |
1117 ;; to be edited. | |
1118 (when (and (buffer-live-p (get-buffer mh-show-buffer)) | |
1119 (equal (save-excursion (set-buffer mh-show-buffer) | |
1120 buffer-file-name) | |
1121 msg-filename)) | |
1122 (mh-invalidate-show-buffer)) | |
1123 | |
1124 ;; Edit message | |
1125 (find-file msg-filename) | |
1126 (setq edit-buffer (current-buffer)) | |
1127 | |
1128 ;; Set buffer properties | |
1129 (mh-letter-mode) | |
1130 (use-local-map text-mode-map) | |
1131 | |
1132 ;; Just show the edit buffer... | |
1133 (delete-other-windows) | |
1134 (switch-to-buffer edit-buffer))) | |
1135 | |
1136 (defun mh-decode-quoted-printable () | |
1137 "Run mimedecode on current buffer, replacing its contents." | |
1138 (let ((case-fold-search t)) | |
1139 (goto-char (point-min)) | |
1140 (when (and (re-search-forward | |
1141 "^content-transfer-encoding:[ \t]*quoted-printable" | |
1142 (if mh-decode-mime-flag (mail-header-end) nil) t) | |
1143 (search-forward "\n\n" nil t)) | |
1144 (message "Converting quoted-printable characters...") | |
1145 (let ((modified (buffer-modified-p)) | |
1146 (command "mimedecode")) | |
1147 (shell-command-on-region (point-min) (point-max) command t t) | |
1148 (if (fboundp 'deactivate-mark) | |
1149 (deactivate-mark)) | |
1150 (set-buffer-modified-p modified)) | |
1151 (message "Converting quoted-printable characters... done.")))) | |
1152 | |
1153 (defun mh-show-unquote-From () | |
1154 "Decode >From at beginning of lines for `mh-show-mode'." | |
1155 (save-excursion | |
1156 (let ((modified (buffer-modified-p)) | |
1157 (case-fold-search nil)) | |
1158 (goto-char (mail-header-end)) | |
1159 (while (re-search-forward "^>From" nil t) | |
1160 (replace-match "From")) | |
1161 (set-buffer-modified-p modified)))) | |
1162 | |
1163 (defun mh-msg-folder (folder-name) | |
1164 "Return the name of the buffer for FOLDER-NAME." | |
1165 folder-name) | |
1166 | |
1167 (defun mh-display-msg (msg-num folder-name) | |
1168 "Display MSG-NUM of FOLDER-NAME. | |
1169 Sets the current buffer to the show buffer." | |
1170 (let ((folder (mh-msg-folder folder-name))) | |
1171 (set-buffer folder) | |
1172 ;; When Gnus uses external displayers it has to keep handles longer. So | |
1173 ;; we will delete these handles when mh-quit is called on the folder. It | |
1174 ;; would be nicer if there are weak pointers in emacs lisp, then we could | |
1175 ;; get the garbage collector to do this for us. | |
1176 (unless (mh-buffer-data) | |
1177 (setf (mh-buffer-data) (mh-make-buffer-data))) | |
1178 ;; Bind variables in folder buffer in case they are local | |
1179 (let ((formfile mhl-formfile) | |
1180 (clean-message-header mh-clean-message-header-flag) | |
1181 (invisible-headers mh-invisible-headers) | |
1182 (visible-headers mh-visible-headers) | |
1183 (msg-filename (mh-msg-filename msg-num folder-name)) | |
1184 (show-buffer mh-show-buffer) | |
1185 (mm-inline-media-tests mh-mm-inline-media-tests)) | |
1186 (if (not (file-exists-p msg-filename)) | |
1187 (error "Message %d does not exist" msg-num)) | |
1188 (if (and (> mh-show-maximum-size 0) | |
1189 (> (elt (file-attributes msg-filename) 7) | |
1190 mh-show-maximum-size) | |
1191 (not (y-or-n-p | |
1192 (format | |
1193 "Message %d (%d bytes) exceeds %d bytes. Display it? " | |
1194 msg-num (elt (file-attributes msg-filename) 7) | |
1195 mh-show-maximum-size)))) | |
1196 (error "Message %d not displayed" msg-num)) | |
1197 (set-buffer show-buffer) | |
1198 (cond ((not (equal msg-filename buffer-file-name)) | |
1199 (mh-unvisit-file) | |
1200 (setq buffer-read-only nil) | |
1201 (erase-buffer) | |
1202 ;; Changing contents, so this hook needs to be reinitialized. | |
1203 ;; pgp.el uses this. | |
1204 (if (boundp 'write-contents-hooks) ;Emacs 19 | |
1205 (kill-local-variable 'write-contents-hooks)) | |
1206 (if formfile | |
1207 (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" | |
1208 (if (stringp formfile) | |
1209 (list "-form" formfile)) | |
1210 msg-filename) | |
1211 (insert-file-contents msg-filename)) | |
1212 (if mh-decode-quoted-printable-flag | |
1213 (mh-decode-quoted-printable)) | |
1214 ;; Cleanup old mime handles | |
1215 (mh-mime-cleanup) | |
1216 ;; Use mm to display buffer | |
1217 (when (and mh-decode-mime-flag (not formfile)) | |
1218 (mh-add-missing-mime-version-header) | |
1219 (setf (mh-buffer-data) (mh-make-buffer-data)) | |
1220 (mh-mime-display)) | |
1221 ;; Header cleanup | |
1222 (goto-char (point-min)) | |
1223 (cond (clean-message-header | |
1224 (mh-clean-msg-header (point-min) | |
1225 invisible-headers | |
1226 visible-headers) | |
1227 (goto-char (point-min))) | |
1228 (t | |
1229 (mh-start-of-uncleaned-message))) | |
1230 ;; the parts of visiting we want to do (no locking) | |
1231 (or (eq buffer-undo-list t) ;don't save undo info for prev msgs | |
1232 (setq buffer-undo-list nil)) | |
1233 (set-buffer-auto-saved) | |
1234 ;; the parts of set-visited-file-name we want to do (no locking) | |
1235 (setq buffer-file-name msg-filename) | |
1236 (setq buffer-backed-up nil) | |
1237 (auto-save-mode 1) | |
1238 (set-mark nil) | |
1239 (mh-show-mode) | |
1240 (unwind-protect | |
1241 (when (and mh-decode-mime-flag (not formfile)) | |
1242 (setq buffer-read-only nil) | |
1243 (mh-display-smileys) | |
1244 (mh-display-emphasis)) | |
1245 (setq buffer-read-only t)) | |
1246 (set-buffer-modified-p nil) | |
1247 (setq mh-show-folder-buffer folder) | |
1248 (setq mode-line-buffer-identification | |
1249 (list (format mh-show-buffer-mode-line-buffer-id | |
1250 folder-name msg-num))) | |
1251 (set-buffer folder) | |
1252 (setq mh-showing-with-headers nil)))))) | |
1253 | |
1254 (defun mh-clean-msg-header (start invisible-headers visible-headers) | |
1255 "Flush extraneous lines in message header. | |
1256 Header is cleaned from START to the end of the message header. | |
1257 INVISIBLE-HEADERS contains a regular expression specifying lines to delete | |
1258 from the header. VISIBLE-HEADERS contains a regular expression specifying the | |
1259 lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil." | |
1260 (let ((case-fold-search t) | |
1261 (after-change-functions nil)) ;Work around emacs-20 font-lock bug | |
1262 ;causing an endless loop. | |
1263 (save-restriction | |
1264 (goto-char start) | |
1265 (if (search-forward "\n\n" nil 'move) | |
1266 (backward-char 1)) | |
1267 (narrow-to-region start (point)) | |
1268 (goto-char (point-min)) | |
1269 (if visible-headers | |
1270 (while (< (point) (point-max)) | |
1271 (cond ((looking-at visible-headers) | |
1272 (forward-line 1) | |
1273 (while (looking-at "[ \t]") (forward-line 1))) | |
1274 (t | |
1275 (mh-delete-line 1) | |
1276 (while (looking-at "[ \t]") | |
1277 (mh-delete-line 1))))) | |
1278 (while (re-search-forward invisible-headers nil t) | |
1279 (beginning-of-line) | |
1280 (mh-delete-line 1) | |
1281 (while (looking-at "[ \t]") | |
1282 (mh-delete-line 1)))) | |
1283 (unlock-buffer)))) | |
1284 | |
1285 (defun mh-delete-line (lines) | |
1286 "Delete the next LINES lines." | |
1287 (delete-region (point) (progn (forward-line lines) (point)))) | |
1288 | |
1289 (defun mh-notate (msg notation offset) | |
1290 "Mark MSG with the character NOTATION at position OFFSET. | |
1291 Null MSG means the message at cursor." | |
1292 (save-excursion | |
1293 (if (or (null msg) | |
1294 (mh-goto-msg msg t t)) | |
1295 (with-mh-folder-updating (t) | |
1296 (beginning-of-line) | |
1297 (forward-char offset) | |
1298 (delete-char 1) | |
1299 (insert notation))))) | |
1300 | |
1301 (defun mh-find-msg-get-num (step) | |
1302 "Return the message number of the message nearest the cursor. | |
1303 Jumps over non-message lines, such as inc errors. | |
1304 If we have to search, STEP tells whether to search forward or backward." | |
1305 (or (mh-get-msg-num nil) | |
1306 (let ((msg-num nil) | |
1307 (nreverses 0)) | |
1308 (while (and (not msg-num) | |
1309 (< nreverses 2)) | |
1310 (cond ((eobp) | |
1311 (setq step -1) | |
1312 (setq nreverses (1+ nreverses))) | |
1313 ((bobp) | |
1314 (setq step 1) | |
1315 (setq nreverses (1+ nreverses)))) | |
1316 (forward-line step) | |
1317 (setq msg-num (mh-get-msg-num nil))) | |
1318 msg-num))) | |
1319 | |
1320 (defun mh-goto-msg (number &optional no-error-if-no-message dont-show) | |
1321 "Position the cursor at message NUMBER. | |
1322 Optional non-nil second argument NO-ERROR-IF-NO-MESSAGE means return nil | |
1323 instead of signaling an error if message does not exist; in this case, the | |
1324 cursor is positioned near where the message would have been. | |
1325 Non-nil third argument DONT-SHOW means not to show the message." | |
1326 (interactive "NGo to message: ") | |
1327 (setq number (prefix-numeric-value number)) | |
1328 (let ((point (point)) | |
1329 (return-value t)) | |
1330 (goto-char (point-min)) | |
1331 (unless (re-search-forward (format "^[ ]*%s[^0-9]+" number) nil t) | |
1332 (goto-char point) | |
1333 (unless no-error-if-no-message | |
1334 (error "No message %d" number)) | |
1335 (setq return-value nil)) | |
1336 (beginning-of-line) | |
1337 (or dont-show (not return-value) (mh-maybe-show number)) | |
1338 return-value)) | |
1339 | |
1340 (defun mh-msg-search-pat (n) | |
1341 "Return a search pattern for message N in the scan listing." | |
1342 (format mh-scan-msg-search-regexp n)) | |
1343 | |
1344 (defun mh-get-profile-field (field) | |
1345 "Find and return the value of FIELD in the current buffer. | |
1346 Returns nil if the field is not in the buffer." | |
1347 (let ((case-fold-search t)) | |
1348 (goto-char (point-min)) | |
1349 (cond ((not (re-search-forward (format "^%s" field) nil t)) nil) | |
1350 ((looking-at "[\t ]*$") nil) | |
1351 (t | |
1352 (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t) | |
1353 (let ((start (match-beginning 1))) | |
1354 (end-of-line) | |
1355 (buffer-substring start (point))))))) | |
1356 | |
1357 (defvar mail-user-agent) | |
1358 (defvar read-mail-command) | |
1359 | |
1360 (defvar mh-find-path-run nil | |
1361 "Non-nil if `mh-find-path' has been run already.") | |
1362 | |
1363 (defun mh-find-path () | |
1364 "Set `mh-progs', `mh-lib', and `mh-lib-progs' variables. | |
1365 Set `mh-user-path', `mh-draft-folder', `mh-unseen-seq', `mh-previous-seq', | |
1366 `mh-inbox' from user's MH profile. | |
1367 The value of `mh-find-path-hook' is a list of functions to be called, with no | |
1368 arguments, after these variable have been set." | |
1369 (mh-find-progs) | |
1370 (unless mh-find-path-run | |
1371 (setq mh-find-path-run t) | |
1372 (setq read-mail-command 'mh-rmail) | |
1373 (setq mail-user-agent 'mh-e-user-agent)) | |
1374 (save-excursion | |
1375 ;; Be sure profile is fully expanded before switching buffers | |
1376 (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile")))) | |
1377 (set-buffer (get-buffer-create mh-temp-buffer)) | |
1378 (setq buffer-offer-save nil) ;for people who set default to t | |
1379 (erase-buffer) | |
1380 (condition-case err | |
1381 (insert-file-contents profile) | |
1382 (file-error | |
1383 (mh-install profile err))) | |
1384 (setq mh-user-path (mh-get-profile-field "Path:")) | |
1385 (if (not mh-user-path) | |
1386 (setq mh-user-path "Mail")) | |
1387 (setq mh-user-path | |
1388 (file-name-as-directory | |
1389 (expand-file-name mh-user-path (expand-file-name "~")))) | |
1390 (setq mh-draft-folder (mh-get-profile-field "Draft-Folder:")) | |
1391 (if mh-draft-folder | |
1392 (progn | |
1393 (if (not (mh-folder-name-p mh-draft-folder)) | |
1394 (setq mh-draft-folder (format "+%s" mh-draft-folder))) | |
1395 (if (not (file-exists-p (mh-expand-file-name mh-draft-folder))) | |
1396 (error "Draft folder \"%s\" not found. Create it and try again" | |
1397 (mh-expand-file-name mh-draft-folder))))) | |
1398 (setq mh-inbox (mh-get-profile-field "Inbox:")) | |
1399 (cond ((not mh-inbox) | |
1400 (setq mh-inbox "+inbox")) | |
1401 ((not (mh-folder-name-p mh-inbox)) | |
1402 (setq mh-inbox (format "+%s" mh-inbox)))) | |
1403 (setq mh-unseen-seq (mh-get-profile-field "Unseen-Sequence:")) | |
1404 (if mh-unseen-seq | |
1405 (setq mh-unseen-seq (intern mh-unseen-seq)) | |
1406 (setq mh-unseen-seq 'unseen)) ;old MH default? | |
1407 (setq mh-previous-seq (mh-get-profile-field "Previous-Sequence:")) | |
1408 (if mh-previous-seq | |
1409 (setq mh-previous-seq (intern mh-previous-seq))) | |
1410 (run-hooks 'mh-find-path-hook))) | |
1411 (and mh-auto-folder-collect-flag | |
1412 (let ((mh-no-install t)) ;only get folders if MH installed | |
1413 (condition-case err | |
1414 (mh-make-folder-list-background) | |
1415 (file-error))))) ;so don't complain if not installed | |
1416 | |
1417 (defun mh-file-command-p (file) | |
1418 "Return t if file FILE is the name of a executable regular file." | |
1419 (and (file-regular-p file) (file-executable-p file))) | |
1420 | |
1421 (defun mh-find-progs () | |
1422 "Find the directories for the installed MH/nmh binaries and config files. | |
1423 Set the `mh-progs' and `mh-lib', and `mh-lib-progs' variables to the | |
1424 directory names and set `mh-nmh-flag' if we detect nmh instead of MH." | |
1425 (unless (and mh-progs mh-lib mh-lib-progs) | |
1426 (let ((path (or (mh-path-search exec-path "mhparam") | |
1427 (mh-path-search '("/usr/local/nmh/bin" ; nmh default | |
1428 "/usr/local/bin/mh/" | |
1429 "/usr/local/mh/" | |
1430 "/usr/bin/mh/" ;Ultrix 4.2, Linux | |
1431 "/usr/new/mh/" ;Ultrix <4.2 | |
1432 "/usr/contrib/mh/bin/" ;BSDI | |
1433 "/usr/pkg/bin/" ; NetBSD | |
1434 "/usr/local/bin/" | |
1435 ) | |
1436 "mhparam")))) | |
1437 (if (not path) | |
1438 (error "Unable to find the `mhparam' command")) | |
1439 (save-excursion | |
1440 (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) | |
1441 (set-buffer tmp-buffer) | |
1442 (unwind-protect | |
1443 (progn | |
1444 (call-process (expand-file-name "mhparam" path) | |
1445 nil '(t nil) nil "libdir" "etcdir") | |
1446 (goto-char (point-min)) | |
1447 (if (search-forward-regexp "^libdir:\\s-\\(\\S-+\\)\\s-*$" | |
1448 nil t) | |
1449 (setq mh-lib-progs (match-string 1) | |
1450 mh-lib mh-lib-progs | |
1451 mh-progs path)) | |
1452 (goto-char (point-min)) | |
1453 (if (search-forward-regexp "^etcdir:\\s-\\(\\S-+\\)\\s-*$" | |
1454 nil t) | |
1455 (setq mh-lib (match-string 1) | |
1456 mh-nmh-flag t))) | |
1457 (kill-buffer tmp-buffer)))) | |
1458 (unless (and mh-progs mh-lib mh-lib-progs) | |
1459 (error "Unable to determine paths from `mhparam' command"))))) | |
1460 | |
1461 (defun mh-path-search (path file) | |
1462 "Search PATH, a list of directory names, for FILE. | |
1463 Returns the element of PATH that contains FILE, or nil if not found." | |
1464 (while (and path | |
1465 (not (funcall 'mh-file-command-p | |
1466 (expand-file-name file (car path))))) | |
1467 (setq path (cdr path))) | |
1468 (car path)) | |
1469 | |
1470 (defvar mh-no-install nil) ;do not run install-mh | |
1471 | |
1472 (defun mh-install (profile error-val) | |
1473 "Initialize the MH environment. | |
1474 This is called if we fail to read the PROFILE file. ERROR-VAL is the error | |
1475 that made this call necessary." | |
1476 (if (or (getenv "MH") | |
1477 (file-exists-p profile) | |
1478 mh-no-install) | |
1479 (signal (car error-val) | |
1480 (list (format "Cannot read MH profile \"%s\"" profile) | |
1481 (car (cdr (cdr error-val)))))) | |
1482 ;; The "install-mh" command will output a short note which | |
1483 ;; mh-exec-cmd will display to the user. | |
1484 ;; The MH 5 version of install-mh might try prompt the user | |
1485 ;; for information, which would fail here. | |
1486 (mh-exec-cmd (expand-file-name "install-mh" mh-lib-progs) "-auto") | |
1487 ;; now try again to read the profile file | |
1488 (erase-buffer) | |
1489 (condition-case err | |
1490 (insert-file-contents profile) | |
1491 (file-error | |
1492 (signal (car err) ;re-signal with more specific msg | |
1493 (list (format "Cannot read MH profile \"%s\"" profile) | |
1494 (car (cdr (cdr err)))))))) | |
1495 | |
1496 (defun mh-set-folder-modified-p (flag) | |
1497 "Mark current folder as modified or unmodified according to FLAG." | |
1498 (set-buffer-modified-p flag)) | |
1499 | |
1500 (defun mh-find-seq (name) | |
1501 "Return sequence NAME." | |
1502 (assoc name mh-seq-list)) | |
1503 | |
1504 (defun mh-seq-to-msgs (seq) | |
1505 "Return a list of the messages in SEQ." | |
1506 (mh-seq-msgs (mh-find-seq seq))) | |
1507 | |
1508 (defun mh-update-scan-format (fmt width) | |
1509 "Return a scan format with the (msg) width in the FMT replaced with WIDTH. | |
1510 | |
1511 The message number width portion of the format is discovered using | |
1512 `mh-scan-msg-format-regexp'. Its replacement is controlled with | |
1513 `mh-scan-msg-format-string'." | |
1514 (or (and | |
1515 (string-match mh-scan-msg-format-regexp fmt) | |
1516 (let ((begin (match-beginning 1)) | |
1517 (end (match-end 1))) | |
1518 (concat (substring fmt 0 begin) | |
1519 (format mh-scan-msg-format-string width) | |
1520 (substring fmt end)))) | |
1521 fmt)) | |
1522 | |
1523 (defun mh-message-number-width (folder) | |
1524 "Return the widest message number in this FOLDER." | |
1525 (or mh-progs (mh-find-path)) | |
1526 (let ((tmp-buffer (get-buffer-create mh-temp-buffer)) | |
1527 (width 0)) | |
1528 (save-excursion | |
1529 (set-buffer tmp-buffer) | |
1530 (erase-buffer) | |
1531 (apply 'call-process | |
1532 (expand-file-name "scan" mh-progs) nil '(t nil) nil | |
1533 (list folder "last" "-format" "%(msg)")) | |
1534 (goto-char (point-min)) | |
1535 (if (re-search-forward mh-scan-msg-number-regexp nil 0 1) | |
1536 (setq width (length (buffer-substring | |
1537 (match-beginning 1) (match-end 1)))))) | |
1538 width)) | |
1539 | |
1540 (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) | |
1541 "Add MSGS to SEQ. | |
1542 Remove duplicates and keep sequence sorted. If optional INTERNAL-FLAG is | |
1543 non-nil, do not mark the message in the scan listing or inform MH of the | |
1544 addition." | |
1545 (let ((entry (mh-find-seq seq))) | |
1546 (if (and msgs (atom msgs)) (setq msgs (list msgs))) | |
1547 (if (null entry) | |
1548 (setq mh-seq-list | |
1549 (cons (mh-make-seq seq (mh-canonicalize-sequence msgs)) | |
1550 mh-seq-list)) | |
1551 (if msgs (setcdr entry (mh-canonicalize-sequence | |
1552 (append msgs (mh-seq-msgs entry)))))) | |
1553 (cond ((not internal-flag) | |
1554 (mh-add-to-sequence seq msgs) | |
1555 (mh-notate-seq seq mh-note-seq (1+ mh-cmd-note)))))) | |
1556 | |
1557 (defun mh-canonicalize-sequence (msgs) | |
1558 "Sort MSGS in decreasing order and remove duplicates." | |
1559 (let* ((sorted-msgs (sort (copy-sequence msgs) '>)) | |
1560 (head sorted-msgs)) | |
1561 (while (cdr head) | |
1562 (if (= (car head) (cadr head)) | |
1563 (setcdr head (cddr head)) | |
1564 (setq head (cdr head)))) | |
1565 sorted-msgs)) | |
1566 | |
1567 (defvar mh-folder-hist nil) | |
1568 (defvar mh-speed-folder-map) | |
1569 | |
1570 (defun mh-prompt-for-folder (prompt default can-create | |
1571 &optional default-string) | |
1572 "Prompt for a folder name with PROMPT. | |
1573 Returns the folder's name as a string. DEFAULT is used if the folder exists | |
1574 and the user types return. If the CAN-CREATE flag is t, then a folder is | |
1575 created if it doesn't already exist. If optional argument DEFAULT-STRING is | |
1576 non-nil, use it in the prompt instead of DEFAULT. | |
1577 The value of `mh-folder-list-change-hook' is a list of functions to be called, | |
1578 with no arguments, whenever the cached folder list `mh-folder-list' is | |
1579 changed." | |
1580 (if (null default) | |
1581 (setq default "")) | |
1582 (let* ((default-string (cond (default-string (format " [%s]? " | |
1583 default-string)) | |
1584 ((equal "" default) "? ") | |
1585 (t (format " [%s]? " default)))) | |
1586 (prompt (format "%s folder%s" prompt default-string)) | |
1587 read-name folder-name) | |
1588 (if (null mh-folder-list) | |
1589 (mh-set-folder-list)) | |
1590 (while (and (setq read-name (completing-read prompt mh-folder-list nil nil | |
1591 "+" 'mh-folder-hist)) | |
1592 (equal read-name "") | |
1593 (equal default ""))) | |
1594 (cond ((or (equal read-name "") (equal read-name "+")) | |
1595 (setq read-name default)) | |
1596 ((not (mh-folder-name-p read-name)) | |
1597 (setq read-name (format "+%s" read-name)))) | |
1598 (if (or (not read-name) (equal "" read-name)) | |
1599 (error "No folder specified")) | |
1600 (setq folder-name read-name) | |
1601 (cond ((and (> (length folder-name) 0) | |
1602 (eq (aref folder-name (1- (length folder-name))) ?/)) | |
1603 (setq folder-name (substring folder-name 0 -1)))) | |
1604 (let ((new-file-flag | |
1605 (not (file-exists-p (mh-expand-file-name folder-name))))) | |
1606 (cond ((and new-file-flag | |
1607 (y-or-n-p | |
1608 (format "Folder %s does not exist. Create it? " | |
1609 folder-name))) | |
1610 (message "Creating %s" folder-name) | |
1611 (mh-exec-cmd-error nil "folder" folder-name) | |
1612 (when (boundp 'mh-speed-folder-map) | |
1613 (mh-speed-add-folder folder-name)) | |
1614 (message "Creating %s...done" folder-name) | |
1615 (setq mh-folder-list (cons (list read-name) mh-folder-list)) | |
1616 (run-hooks 'mh-folder-list-change-hook)) | |
1617 (new-file-flag | |
1618 (error "Folder %s is not created" folder-name)) | |
1619 ((not (file-directory-p (mh-expand-file-name folder-name))) | |
1620 (error "\"%s\" is not a directory" | |
1621 (mh-expand-file-name folder-name))) | |
1622 ((and (null (assoc read-name mh-folder-list)) | |
1623 (null (assoc (concat read-name "/") mh-folder-list))) | |
1624 (setq mh-folder-list (cons (list read-name) mh-folder-list)) | |
1625 (run-hooks 'mh-folder-list-change-hook)))) | |
1626 folder-name)) | |
1627 | |
1628 (defvar mh-make-folder-list-process nil) ;The background process collecting | |
1629 ;the folder list. | |
1630 | |
1631 (defvar mh-folder-list-temp nil) ;mh-folder-list as it is being built. | |
1632 | |
1633 (defvar mh-folder-list-partial-line "") ;Start of last incomplete line from | |
1634 ;folder process. | |
1635 | |
1636 (defun mh-set-folder-list () | |
1637 "Set `mh-folder-list' correctly. | |
1638 A useful function for the command line or for when you need to | |
1639 sync by hand. Format is in a form suitable for completing read. | |
1640 The value of `mh-folder-list-change-hook' is a list of functions to be called, | |
1641 with no arguments, once the list of folders has been created." | |
1642 (message "Collecting folder names...") | |
1643 (if (not mh-make-folder-list-process) | |
1644 (mh-make-folder-list-background)) | |
1645 (while (eq (process-status mh-make-folder-list-process) 'run) | |
1646 (accept-process-output mh-make-folder-list-process)) | |
1647 (setq mh-folder-list mh-folder-list-temp) | |
1648 (run-hooks 'mh-folder-list-change-hook) | |
1649 (setq mh-folder-list-temp nil) | |
1650 (delete-process mh-make-folder-list-process) | |
1651 (setq mh-make-folder-list-process nil) | |
1652 (message "Collecting folder names...done")) | |
1653 | |
1654 (defun mh-make-folder-list-background () | |
1655 "Start a background process to compute a list of the user's folders. | |
1656 Call `mh-set-folder-list' to wait for the result." | |
1657 (cond | |
1658 ((not mh-make-folder-list-process) | |
1659 (unless mh-inbox | |
1660 (mh-find-path)) | |
1661 (let ((process-connection-type nil)) | |
1662 (setq mh-make-folder-list-process | |
1663 (start-process "folders" nil (expand-file-name "folders" mh-progs) | |
1664 "-fast" | |
1665 (if mh-recursive-folders-flag | |
1666 "-recurse" | |
1667 "-norecurse"))) | |
1668 (set-process-filter mh-make-folder-list-process | |
1669 'mh-make-folder-list-filter) | |
1670 (process-kill-without-query mh-make-folder-list-process))))) | |
1671 | |
1672 (defun mh-make-folder-list-filter (process output) | |
1673 "Given the PROCESS \"folders -fast\", parse OUTPUT. | |
1674 See also `set-process-filter'." | |
1675 (let ((position 0) | |
1676 line-end | |
1677 new-folder | |
1678 (prevailing-match-data (match-data))) | |
1679 (unwind-protect | |
1680 ;; make sure got complete line | |
1681 (while (setq line-end (string-match "\n" output position)) | |
1682 (setq new-folder (format "+%s%s" | |
1683 mh-folder-list-partial-line | |
1684 (substring output position line-end))) | |
1685 (setq mh-folder-list-partial-line "") | |
1686 ;; is new folder a subfolder of previous? | |
1687 (if (and mh-folder-list-temp | |
1688 (string-match | |
1689 (regexp-quote | |
1690 (concat (car (car mh-folder-list-temp)) "/")) | |
1691 new-folder)) | |
1692 ;; append slash to parent folder for better completion | |
1693 ;; (undone by mh-prompt-for-folder) | |
1694 (setq mh-folder-list-temp | |
1695 (cons | |
1696 (list new-folder) | |
1697 (cons | |
1698 (list (concat (car (car mh-folder-list-temp)) "/")) | |
1699 (cdr mh-folder-list-temp)))) | |
1700 (setq mh-folder-list-temp | |
1701 (cons (list new-folder) | |
1702 mh-folder-list-temp))) | |
1703 (setq position (1+ line-end))) | |
1704 (set-match-data prevailing-match-data)) | |
1705 (setq mh-folder-list-partial-line (substring output position)))) | |
1706 | |
1707 ;;; Issue commands to MH. | |
1708 | |
1709 (defun mh-exec-cmd (command &rest args) | |
1710 "Execute mh-command COMMAND with ARGS. | |
1711 The side effects are what is desired. | |
1712 Any output is assumed to be an error and is shown to the user. | |
1713 The output is not read or parsed by MH-E." | |
1714 (save-excursion | |
1715 (set-buffer (get-buffer-create mh-temp-buffer)) | |
1716 (erase-buffer) | |
1717 (apply 'call-process | |
1718 (expand-file-name command mh-progs) nil t nil | |
1719 (mh-list-to-string args)) | |
1720 (if (> (buffer-size) 0) | |
1721 (save-window-excursion | |
1722 (switch-to-buffer-other-window mh-temp-buffer) | |
1723 (sit-for 5))))) | |
1724 | |
1725 (defun mh-exec-cmd-error (env command &rest args) | |
1726 "In environment ENV, execute mh-command COMMAND with ARGS. | |
1727 ENV is nil or a string of space-separated \"var=value\" elements. | |
1728 Signals an error if process does not complete successfully." | |
1729 (save-excursion | |
1730 (set-buffer (get-buffer-create mh-temp-buffer)) | |
1731 (erase-buffer) | |
1732 (let ((status | |
1733 (if env | |
1734 ;; the shell hacks necessary here shows just how broken Unix is | |
1735 (apply 'call-process "/bin/sh" nil t nil "-c" | |
1736 (format "%s %s ${1+\"$@\"}" | |
1737 env | |
1738 (expand-file-name command mh-progs)) | |
1739 command | |
1740 (mh-list-to-string args)) | |
1741 (apply 'call-process | |
1742 (expand-file-name command mh-progs) nil t nil | |
1743 (mh-list-to-string args))))) | |
1744 (mh-handle-process-error command status)))) | |
1745 | |
1746 (defun mh-exec-cmd-daemon (command &rest args) | |
1747 "Execute MH command COMMAND with ARGS in the background. | |
1748 Any output from command is displayed in an asynchronous pop-up window." | |
1749 (save-excursion | |
1750 (set-buffer (get-buffer-create mh-temp-buffer)) | |
1751 (erase-buffer)) | |
1752 (let* ((process-connection-type nil) | |
1753 (process (apply 'start-process | |
1754 command nil | |
1755 (expand-file-name command mh-progs) | |
1756 (mh-list-to-string args)))) | |
1757 (set-process-filter process 'mh-process-daemon))) | |
1758 | |
1759 (defun mh-process-daemon (process output) | |
1760 "PROCESS daemon that puts OUTPUT into a temporary buffer." | |
1761 (set-buffer (get-buffer-create mh-temp-buffer)) | |
1762 (insert-before-markers output) | |
1763 (display-buffer mh-temp-buffer)) | |
1764 | |
1765 (defun mh-exec-cmd-quiet (raise-error command &rest args) | |
1766 "Signal RAISE-ERROR if COMMAND with ARGS fails. | |
1767 Execute MH command COMMAND with ARGS. ARGS is a list of strings. | |
1768 Return at start of mh-temp buffer, where output can be parsed and used. | |
1769 Returns value of `call-process', which is 0 for success, unless RAISE-ERROR is | |
1770 non-nil, in which case an error is signaled if `call-process' returns non-0." | |
1771 (set-buffer (get-buffer-create mh-temp-buffer)) | |
1772 (erase-buffer) | |
1773 (let ((value | |
1774 (apply 'call-process | |
1775 (expand-file-name command mh-progs) nil t nil | |
1776 args))) | |
1777 (goto-char (point-min)) | |
1778 (if raise-error | |
1779 (mh-handle-process-error command value) | |
1780 value))) | |
1781 | |
1782 (defun mh-profile-component (component) | |
1783 "Return COMPONENT value from mhparam, or nil if unset." | |
1784 (save-excursion | |
1785 (mh-exec-cmd-quiet nil "mhparam" "-components" component) | |
1786 (mh-get-profile-field (concat component ":")))) | |
1787 | |
1788 (defun mh-exchange-point-and-mark-preserving-active-mark () | |
1789 "Put the mark where point is now, and point where the mark is now. | |
1790 This command works even when the mark is not active, and preserves whether the | |
1791 mark is active or not." | |
1792 (interactive nil) | |
1793 (let ((is-active (and (boundp 'mark-active) mark-active))) | |
1794 (let ((omark (mark t))) | |
1795 (if (null omark) | |
1796 (error "No mark set in this buffer")) | |
1797 (set-mark (point)) | |
1798 (goto-char omark) | |
1799 (if (boundp 'mark-active) | |
1800 (setq mark-active is-active)) | |
1801 nil))) | |
1802 | |
1803 (defun mh-exec-cmd-output (command display &rest args) | |
1804 "Execute MH command COMMAND with DISPLAY flag and ARGS. | |
1805 Put the output into buffer after point. Set mark after inserted text. | |
1806 Output is expected to be shown to user, not parsed by MH-E." | |
1807 (push-mark (point) t) | |
1808 (apply 'call-process | |
1809 (expand-file-name command mh-progs) nil t display | |
1810 (mh-list-to-string args)) | |
1811 | |
1812 ;; The following is used instead of 'exchange-point-and-mark because the | |
1813 ;; latter activates the current region (between point and mark), which | |
1814 ;; turns on highlighting. So prior to this bug fix, doing "inc" would | |
1815 ;; highlight a region containing the new messages, which is undesirable. | |
1816 ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4. | |
1817 (mh-exchange-point-and-mark-preserving-active-mark)) | |
1818 | |
1819 (defun mh-exec-lib-cmd-output (command &rest args) | |
1820 "Execute MH library command COMMAND with ARGS. | |
1821 Put the output into buffer after point. Set mark after inserted text." | |
1822 (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args)) | |
1823 | |
1824 (defun mh-handle-process-error (command status) | |
1825 "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS. | |
1826 STATUS is return value from `call-process'. | |
1827 Program output is in current buffer. | |
1828 If output is too long to include in error message, display the buffer." | |
1829 (cond ((eq status 0) ;success | |
1830 status) | |
1831 ((stringp status) ;kill string | |
1832 (error "%s: %s" command status)) | |
1833 (t ;exit code | |
1834 (cond | |
1835 ((= (buffer-size) 0) ;program produced no error message | |
1836 (error "%s: exit code %d" command status)) | |
1837 (t | |
1838 ;; will error message fit on one line? | |
1839 (goto-line 2) | |
1840 (if (and (< (buffer-size) (frame-width)) | |
1841 (eobp)) | |
1842 (error "%s" | |
1843 (buffer-substring 1 (progn (goto-char 1) | |
1844 (end-of-line) | |
1845 (point)))) | |
1846 (display-buffer (current-buffer)) | |
1847 (error "%s failed with status %d. See error message in other window" | |
1848 command status))))))) | |
1849 | |
1850 (defun mh-list-to-string (l) | |
1851 "Flatten the list L and make every element of the new list into a string." | |
1852 (nreverse (mh-list-to-string-1 l))) | |
1853 | |
1854 (defun mh-list-to-string-1 (l) | |
1855 "Flatten the list L and make every element of the new list into a string." | |
1856 (let ((new-list nil)) | |
1857 (while l | |
1858 (cond ((null (car l))) | |
1859 ((symbolp (car l)) | |
1860 (setq new-list (cons (symbol-name (car l)) new-list))) | |
1861 ((numberp (car l)) | |
1862 (setq new-list (cons (int-to-string (car l)) new-list))) | |
1863 ((equal (car l) "")) | |
1864 ((stringp (car l)) (setq new-list (cons (car l) new-list))) | |
1865 ((listp (car l)) | |
1866 (setq new-list (nconc (mh-list-to-string-1 (car l)) | |
1867 new-list))) | |
1868 (t (error "Bad element in mh-list-to-string: %s" (car l)))) | |
1869 (setq l (cdr l))) | |
1870 new-list)) | |
1871 | |
1872 (provide 'mh-utils) | |
1873 | |
1874 ;;; Local Variables: | |
1875 ;;; indent-tabs-mode: nil | |
1876 ;;; sentence-end-double-space: nil | |
1877 ;;; End: | |
1878 | |
1879 ;;; mh-utils.el ends here |