Mercurial > emacs
comparison lisp/mh-e/mh-utils.el @ 88155:d7ddb3e565de
sync with trunk
author | Henrik Enberg <henrik.enberg@telia.com> |
---|---|
date | Mon, 16 Jan 2006 00:03:54 +0000 |
parents | 0d8b17d428b5 |
children |
comparison
equal
deleted
inserted
replaced
88154:8ce476d3ba36 | 88155:d7ddb3e565de |
---|---|
1 ;;; mh-utils.el --- MH-E code needed for both sending and reading | 1 ;;; mh-utils.el --- MH-E code needed for both sending and reading |
2 | 2 |
3 ;; Copyright (C) 1993, 1995, 1997, 2000, 2001, 2002 Free Software Foundation, Inc. | 3 ;; Copyright (C) 1993, 1995, 1997, |
4 ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. | |
4 | 5 |
5 ;; Author: Bill Wohler <wohler@newt.com> | 6 ;; Author: Bill Wohler <wohler@newt.com> |
6 ;; Maintainer: Bill Wohler <wohler@newt.com> | 7 ;; Maintainer: Bill Wohler <wohler@newt.com> |
7 ;; Keywords: mail | 8 ;; Keywords: mail |
8 ;; See: mh-e.el | 9 ;; See: mh-e.el |
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
20 ;; GNU General Public License for more details. | 21 ;; GNU General Public License for more details. |
21 | 22 |
22 ;; You should have received a copy of the GNU General Public License | 23 ;; 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 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | 25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
25 ;; Boston, MA 02111-1307, USA. | 26 ;; Boston, MA 02110-1301, USA. |
26 | 27 |
27 ;;; Commentary: | 28 ;;; Commentary: |
28 | 29 |
29 ;; Internal support for MH-E package. | 30 ;; Internal support for MH-E package. |
30 | 31 |
31 ;;; Change Log: | 32 ;;; Change Log: |
32 | 33 |
33 ;; $Id: mh-utils.el,v 1.2 2003/02/03 20:55:30 wohler Exp $ | |
34 | |
35 ;;; Code: | 34 ;;; Code: |
36 | 35 |
37 ;; Is this XEmacs-land? Located here since needed by mh-customize.el. | 36 ;;(message "> mh-utils") |
38 (defvar mh-xemacs-flag (featurep 'xemacs) | 37 (eval-and-compile |
39 "Non-nil means the current Emacs is XEmacs.") | 38 (defvar recursive-load-depth-limit) |
40 | 39 (if (and (boundp 'recursive-load-depth-limit) |
41 (require 'cl) | 40 (integerp recursive-load-depth-limit) |
41 (< recursive-load-depth-limit 50)) | |
42 (setq recursive-load-depth-limit 50))) | |
43 | |
44 (eval-when-compile (require 'mh-acros)) | |
45 (mh-require-cl) | |
46 | |
47 (require 'font-lock) | |
42 (require 'gnus-util) | 48 (require 'gnus-util) |
43 (require 'font-lock) | 49 (require 'mh-buffers) |
44 (require 'mh-loaddefs) | |
45 (require 'mh-customize) | 50 (require 'mh-customize) |
46 | 51 (require 'mh-inc) |
47 (load "mm-decode" t t) ; Non-fatal dependency | 52 (require 'mouse) |
48 (load "mm-view" t t) ; Non-fatal dependency | 53 (require 'sendmail) |
49 (load "executable" t t) ; Non-fatal dependency on | 54 ;;(message "< mh-utils") |
50 ; executable-find | 55 |
51 | 56 ;; Non-fatal dependencies |
52 ;; Shush the byte-compiler | 57 (load "hl-line" t t) |
53 (defvar font-lock-auto-fontify) | 58 (load "mm-decode" t t) |
54 (defvar font-lock-defaults) | 59 (load "mm-view" t t) |
55 (defvar mark-active) | 60 (load "tool-bar" t t) |
56 (defvar tool-bar-mode) | 61 (load "vcard" t t) |
62 | |
63 | |
57 | 64 |
58 ;;; Autoloads | 65 ;;; Autoloads |
66 | |
59 (autoload 'gnus-article-highlight-citation "gnus-cite") | 67 (autoload 'gnus-article-highlight-citation "gnus-cite") |
60 (autoload 'mail-header-end "sendmail") | 68 (autoload 'message-fetch-field "message") |
61 (autoload 'Info-goto-node "info") | 69 (autoload 'message-tokenize-header "message") |
62 (unless (fboundp 'make-hash-table) | 70 (unless (fboundp 'make-hash-table) |
63 (autoload 'make-hash-table "cl")) | 71 (autoload 'make-hash-table "cl")) |
64 | 72 |
65 ;;; Set for local environment: | 73 |
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 | 74 |
94 ;;; CL Replacements | 75 ;;; CL Replacements |
76 | |
95 (defun mh-search-from-end (char string) | 77 (defun mh-search-from-end (char string) |
96 "Return the position of last occurrence of CHAR in STRING. | 78 "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 | 79 If CHAR is not present in STRING then return nil. The function is |
98 of `search' in the CL package." | 80 used in lieu of `search' in the CL package." |
99 (loop for index from (1- (length string)) downto 0 | 81 (loop for index from (1- (length string)) downto 0 |
100 when (equal (aref string index) char) return index | 82 when (equal (aref string index) char) return index |
101 finally return nil)) | 83 finally return nil)) |
102 | 84 |
103 ;;; Macro to generate correct code for different emacs variants | 85 ;; Additional header fields that might someday be added: |
104 | 86 ;; "Sender: " "Reply-to: " |
105 (defmacro mh-mark-active-p (check-transient-mark-mode-flag) | 87 |
106 "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs. | 88 |
107 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if | 89 |
108 variable `transient-mark-mode' is active." | 90 ;;; Scan Line Formats |
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 | 91 |
120 (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" | 92 (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" |
121 "Regexp to find the number of a message in a scan line. | 93 "This regular expression extracts the message number. |
122 The message's number must be surrounded with \\( \\)") | 94 |
95 It must match from the beginning of the line. Note that the | |
96 message number must be placed in a parenthesized expression as in | |
97 the default of \"^ *\\\\([0-9]+\\\\)\".") | |
123 | 98 |
124 (defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]" | 99 (defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]" |
125 "Regexp to find a scan line in which the message number overflowed. | 100 "This regular expression matches overflowed message numbers.") |
126 The message's number is left truncated in this case.") | |
127 | 101 |
128 (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" | 102 (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" |
129 "Regexp to find message number width in an scan format. | 103 "This regular expression finds the message number width in a scan format. |
130 The message number width must be surrounded with \\( \\).") | 104 |
105 Note that the message number must be placed in a parenthesized | |
106 expression as in the default of \"%\\\\([0-9]*\\\\)(msg)\". This | |
107 variable is only consulted if `mh-scan-format-file' is set to | |
108 \"Use MH-E scan Format\".") | |
131 | 109 |
132 (defvar mh-scan-msg-format-string "%d" | 110 (defvar mh-scan-msg-format-string "%d" |
133 "Format string for width of the message number in a scan format. | 111 "This is a format string for width of the message number in a scan format. |
134 Use `0%d' for zero-filled message numbers.") | 112 |
113 Use \"0%d\" for zero-filled message numbers. This variable is only | |
114 consulted if `mh-scan-format-file' is set to \"Use MH-E scan | |
115 Format\".") | |
135 | 116 |
136 (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" | 117 (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" |
137 "Format string containing a regexp matching the scan listing for a message. | 118 "This regular expression matches a particular message. |
138 The desired message's number will be an argument to format.") | 119 |
139 | 120 It is a format string; use \"%d\" to represent the location of the |
140 (defvar mh-default-folder-for-message-function nil | 121 message number within the expression as in the default of |
141 "Function to select a default folder for refiling or Fcc. | 122 \"^[^0-9]*%d[^0-9]\".") |
142 If set to a function, that function is called with no arguments by | 123 |
143 `\\[mh-refile-msg]' and `\\[mh-to-fcc]' to get a default when | 124 (defvar mh-cmd-note 4 |
144 prompting the user for a folder. The function is called from within a | 125 "Column for notations. |
145 `save-excursion', with point at the start of the message. It should | 126 |
146 return the folder to offer as the refile or Fcc folder, as a string | 127 This variable should be set with the function `mh-set-cmd-note'. |
147 with a leading `+' sign. It can also return an empty string to use no | 128 This variable may be updated dynamically if |
148 default, or nil to calculate the default the usual way. | 129 `mh-adaptive-cmd-note-flag' is on. |
149 NOTE: This variable is not an ordinary hook; | 130 |
150 It may not be a list of functions.") | 131 Note that columns in Emacs start with 0.") |
132 (make-variable-buffer-local 'mh-cmd-note) | |
133 | |
134 (defvar mh-note-seq ?% | |
135 "Messages in a user-defined sequence are marked by this character. | |
136 | |
137 Messages in the \"search\" sequence are marked by this character as | |
138 well.") | |
139 | |
140 | |
151 | 141 |
152 (defvar mh-show-buffer-mode-line-buffer-id " {show-%s} %d" | 142 (defvar mh-show-buffer-mode-line-buffer-id " {show-%s} %d" |
153 "Format string to produce `mode-line-buffer-identification' for show buffers. | 143 "Format string to produce `mode-line-buffer-identification' for show buffers. |
154 First argument is folder name. Second is message number.") | 144 |
155 | 145 First argument is folder name. Second is message number.") |
156 (defvar mh-cmd-note 4 | 146 |
157 "Column to insert notation. | 147 |
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 | 148 |
167 (defvar mh-mail-header-separator "--------" | 149 (defvar mh-mail-header-separator "--------" |
168 "*Line used by MH to separate headers from text in messages being composed. | 150 "*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 | 151 |
170 `mail-header-separator' instead. `mail-header-separator' is initialized to | 152 This variable should not be used directly in programs. Programs |
171 `mh-mail-header-separator' in `mh-letter-mode'; in other contexts, you may | 153 should use `mail-header-separator' instead. |
172 have to perform this initialization yourself. | 154 `mail-header-separator' is initialized to |
173 | 155 `mh-mail-header-separator' in `mh-letter-mode'; in other |
174 Do not make this a regexp as it may be the argument to `insert' and it is | 156 contexts, you may have to perform this initialization yourself. |
175 passed through `regexp-quote' before being used by functions like | 157 |
176 `re-search-forward'.") | 158 Do not make this a regular expression as it may be the argument |
159 to `insert' and it is passed through `regexp-quote' before being | |
160 used by functions like `re-search-forward'.") | |
161 | |
162 (defvar mh-signature-separator-regexp "^-- $" | |
163 "This regular expression matches the signature separator. | |
164 See `mh-signature-separator'.") | |
165 | |
166 (defvar mh-signature-separator "-- \n" | |
167 "Text of a signature separator. | |
168 | |
169 A signature separator is used to separate the body of a message | |
170 from the signature. This can be used by user agents such as MH-E | |
171 to render the signature differently or to suppress the inclusion | |
172 of the signature in a reply. Use `mh-signature-separator-regexp' | |
173 when searching for a separator.") | |
174 | |
175 (defun mh-signature-separator-p () | |
176 "Return non-nil if buffer includes \"^-- $\"." | |
177 (save-excursion | |
178 (goto-char (point-min)) | |
179 (re-search-forward mh-signature-separator-regexp nil t))) | |
177 | 180 |
178 ;; Variables for MIME display | 181 ;; Variables for MIME display |
179 | 182 |
180 ;; Structure to keep track of MIME handles on a per buffer basis. | 183 ;; Structure to keep track of MIME handles on a per buffer basis. |
181 (defstruct (mh-buffer-data (:conc-name mh-mime-) | 184 (mh-defstruct (mh-buffer-data (:conc-name mh-mime-) |
182 (:constructor mh-make-buffer-data)) | 185 (:constructor mh-make-buffer-data)) |
183 (handles ()) ; List of MIME handles | 186 (handles ()) ; List of MIME handles |
184 (handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of | 187 (handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of |
185 ; nested messages | 188 ; nested messages |
186 (parts-count 0) ; The button number is generated from | 189 (parts-count 0) ; The button number is generated from |
187 ; this number | 190 ; this number |
188 (part-index-hash (make-hash-table))) ; Avoid incrementing the part number | 191 (part-index-hash (make-hash-table))) ; Avoid incrementing the part number |
189 ; for nested messages | 192 ; for nested messages |
190 ;;; This has to be a macro, since we do: (setf (mh-buffer-data) ...) | 193 |
194 ;; This has to be a macro, since we do: (setf (mh-buffer-data) ...) | |
191 (defmacro mh-buffer-data () | 195 (defmacro mh-buffer-data () |
192 "Convenience macro to get the MIME data structures of the current buffer." | 196 "Convenience macro to get the MIME data structures of the current buffer." |
193 `(gethash (current-buffer) mh-globals-hash)) | 197 `(gethash (current-buffer) mh-globals-hash)) |
194 | 198 |
195 (defvar mh-globals-hash (make-hash-table) | 199 (defvar mh-globals-hash (make-hash-table) |
196 "Keeps track of MIME data on a per buffer basis.") | 200 "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 |
201 (defvar mh-mm-inline-media-tests | 202 (defvar mh-mm-inline-media-tests |
202 `(("image/jpeg" | 203 `(("image/jpeg" |
203 mm-inline-image | 204 mm-inline-image |
204 (lambda (handle) | 205 (lambda (handle) |
285 ("image/.*" ignore ignore) | 286 ("image/.*" ignore ignore) |
286 ;; Default to displaying as text | 287 ;; Default to displaying as text |
287 (".*" mm-inline-text mm-readable-p)) | 288 (".*" mm-inline-text mm-readable-p)) |
288 "Alist of media types/tests saying whether types can be displayed inline.") | 289 "Alist of media types/tests saying whether types can be displayed inline.") |
289 | 290 |
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' | 291 ;; Copy of `goto-address-mail-regexp' |
304 (defvar mh-address-mail-regexp | 292 (defvar mh-address-mail-regexp |
305 "[-a-zA-Z0-9._]+@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+" | 293 "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" |
306 "A regular expression probably matching an e-mail address.") | 294 "A regular expression probably matching an e-mail address.") |
307 | 295 |
308 ;; From goto-addr.el, which we don't want to force-load on users. | 296 ;; From goto-addr.el, which we don't want to force-load on users. |
309 ;;;###mh-autoload | 297 |
310 (defun mh-goto-address-find-address-at-point () | 298 (defun mh-goto-address-find-address-at-point () |
311 "Find e-mail address around or before point. | 299 "Find e-mail address around or before point. |
312 Then search backwards to beginning of line for the start of an e-mail | 300 |
313 address. If no e-mail address found, return nil." | 301 Then search backwards to beginning of line for the start of an |
302 e-mail address. If no e-mail address found, return nil." | |
314 (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) | 303 (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) |
315 (if (or (looking-at mh-address-mail-regexp) ; already at start | 304 (if (or (looking-at mh-address-mail-regexp) ; already at start |
316 (and (re-search-forward mh-address-mail-regexp | 305 (and (re-search-forward mh-address-mail-regexp |
317 (line-end-position) 'lim) | 306 (line-end-position) 'lim) |
318 (goto-char (match-beginning 0)))) | 307 (goto-char (match-beginning 0)))) |
319 (match-string-no-properties 0))) | 308 (match-string-no-properties 0))) |
320 | 309 |
310 (defun mh-mail-header-end () | |
311 "Substitute for `mail-header-end' that doesn't widen the buffer. | |
312 | |
313 In MH-E we frequently need to find the end of headers in nested | |
314 messages, where the buffer has been narrowed. This function works | |
315 in this situation." | |
316 (save-excursion | |
317 ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally, | |
318 ;; mail headers that MH-E has to read contains lines of the form: | |
319 ;; From xxx@yyy Mon May 10 11:48:07 2004 | |
320 ;; In this situation, rfc822-goto-eoh doesn't go to the end of the | |
321 ;; header. The replacement allows From_ lines in the mail header. | |
322 (goto-char (point-min)) | |
323 (loop for p = (re-search-forward | |
324 "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) | |
325 do (cond ((null p) (return)) | |
326 (t (goto-char (match-beginning 0)) | |
327 (unless (looking-at "From ") (return)) | |
328 (goto-char p)))) | |
329 (point))) | |
330 | |
321 (defun mh-in-header-p () | 331 (defun mh-in-header-p () |
322 "Return non-nil if the point is in the header of a draft message." | 332 "Return non-nil if the point is in the header of a draft message." |
323 (< (point) (mail-header-end))) | 333 (< (point) (mh-mail-header-end))) |
324 | 334 |
325 (defun mh-header-field-beginning () | 335 (defun mh-header-field-beginning () |
326 "Move to the beginning of the current header field. | 336 "Move to the beginning of the current header field. |
327 Handles RFC 822 continuation lines." | 337 Handles RFC 822 continuation lines." |
328 (beginning-of-line) | 338 (beginning-of-line) |
340 (defun mh-letter-header-font-lock (limit) | 350 (defun mh-letter-header-font-lock (limit) |
341 "Return the entire mail header to font-lock. | 351 "Return the entire mail header to font-lock. |
342 Argument LIMIT limits search." | 352 Argument LIMIT limits search." |
343 (if (= (point) limit) | 353 (if (= (point) limit) |
344 nil | 354 nil |
345 (let* ((mail-header-end (save-match-data (mail-header-end))) | 355 (let* ((mail-header-end (save-match-data (mh-mail-header-end))) |
346 (lesser-limit (if (< mail-header-end limit) mail-header-end limit))) | 356 (lesser-limit (if (< mail-header-end limit) mail-header-end limit))) |
347 (when (mh-in-header-p) | 357 (when (mh-in-header-p) |
348 (set-match-data (list 1 lesser-limit)) | 358 (set-match-data (list 1 lesser-limit)) |
349 (goto-char lesser-limit) | 359 (goto-char lesser-limit) |
350 t)))) | 360 t)))) |
352 (defun mh-header-field-font-lock (field limit) | 362 (defun mh-header-field-font-lock (field limit) |
353 "Return the value of a header field FIELD to font-lock. | 363 "Return the value of a header field FIELD to font-lock. |
354 Argument LIMIT limits search." | 364 Argument LIMIT limits search." |
355 (if (= (point) limit) | 365 (if (= (point) limit) |
356 nil | 366 nil |
357 (let* ((mail-header-end (mail-header-end)) | 367 (let* ((mail-header-end (mh-mail-header-end)) |
358 (lesser-limit (if (< mail-header-end limit) mail-header-end limit)) | 368 (lesser-limit (if (< mail-header-end limit) mail-header-end limit)) |
359 (case-fold-search t)) | 369 (case-fold-search t)) |
360 (when (and (< (point) mail-header-end) ;Only within header | 370 (when (and (< (point) mail-header-end) ;Only within header |
361 (re-search-forward (format "^%s" field) lesser-limit t)) | 371 (re-search-forward (format "^%s" field) lesser-limit t)) |
362 (let ((match-one-b (match-beginning 0)) | 372 (let ((match-one-b (match-beginning 0)) |
384 (mh-header-field-font-lock "Subject:" limit)) | 394 (mh-header-field-font-lock "Subject:" limit)) |
385 | 395 |
386 (eval-and-compile | 396 (eval-and-compile |
387 ;; Otherwise byte-compilation fails on `mh-show-font-lock-keywords-with-cite' | 397 ;; Otherwise byte-compilation fails on `mh-show-font-lock-keywords-with-cite' |
388 (defvar mh-show-font-lock-keywords | 398 (defvar mh-show-font-lock-keywords |
389 '(("^\\(From:\\|Sender:\\)\\(.*\\)" (1 'default) (2 mh-show-from-face)) | 399 '(("^\\(From:\\|Sender:\\)\\(.*\\)" |
390 (mh-header-to-font-lock (0 'default) (1 mh-show-to-face)) | 400 (1 'default) |
391 (mh-header-cc-font-lock (0 'default) (1 mh-show-cc-face)) | 401 (2 'mh-show-from)) |
402 (mh-header-to-font-lock | |
403 (0 'default) | |
404 (1 'mh-show-to)) | |
405 (mh-header-cc-font-lock | |
406 (0 'default) | |
407 (1 'mh-show-cc)) | |
392 ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" | 408 ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" |
393 (1 'default) (2 mh-show-from-face)) | 409 (1 'default) |
394 (mh-header-subject-font-lock (0 'default) (1 mh-show-subject-face)) | 410 (2 'mh-show-from)) |
411 (mh-header-subject-font-lock | |
412 (0 'default) | |
413 (1 'mh-show-subject)) | |
395 ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" | 414 ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" |
396 (1 'default) (2 mh-show-cc-face)) | 415 (1 'default) |
416 (2 'mh-show-cc)) | |
397 ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" | 417 ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" |
398 (1 'default) (2 mh-show-date-face)) | 418 (1 'default) |
399 (mh-letter-header-font-lock (0 mh-show-header-face append t))) | 419 (2 'mh-show-date)) |
400 "Additional expressions to highlight in MH-show mode.")) | 420 (mh-letter-header-font-lock |
421 (0 'mh-show-header append t))) | |
422 "Additional expressions to highlight in MH-Show buffers.")) | |
401 | 423 |
402 (defvar mh-show-font-lock-keywords-with-cite | 424 (defvar mh-show-font-lock-keywords-with-cite |
403 (eval-when-compile | 425 (eval-when-compile |
404 (let* ((cite-chars "[>|}]") | 426 (let* ((cite-chars "[>|}]") |
405 (cite-prefix "A-Za-z") | 427 (cite-prefix "A-Za-z") |
414 "\\(" cite-chars "[ \t]*\\)\\)+" | 436 "\\(" cite-chars "[ \t]*\\)\\)+" |
415 "\\(.*\\)") | 437 "\\(.*\\)") |
416 (beginning-of-line) (end-of-line) | 438 (beginning-of-line) (end-of-line) |
417 (2 font-lock-constant-face nil t) | 439 (2 font-lock-constant-face nil t) |
418 (4 font-lock-comment-face nil t))))))) | 440 (4 font-lock-comment-face nil t))))))) |
419 "Additional expressions to highlight in MH-show mode.") | 441 "Additional expressions to highlight in MH-Show buffers.") |
442 | |
443 (defvar mh-letter-font-lock-keywords | |
444 `(,@mh-show-font-lock-keywords-with-cite | |
445 (mh-font-lock-field-data | |
446 (1 'mh-letter-header-field prepend t))) | |
447 "Additional expressions to highlight in MH-Letter buffers.") | |
420 | 448 |
421 (defun mh-show-font-lock-fontify-region (beg end loudly) | 449 (defun mh-show-font-lock-fontify-region (beg end loudly) |
422 "Limit font-lock in `mh-show-mode' to the header. | 450 "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 | 451 |
424 dealt with by gnus highlighting. The region between BEG and END is | 452 Used when the option `mh-highlight-citation-style' is set to |
425 given over to be fontified and LOUDLY controls if a user sees a | 453 \"Gnus\", leaving the body to be dealt with by Gnus highlighting. |
426 message about the fontification operation." | 454 The region between BEG and END is given over to be fontified and |
427 (let ((header-end (mail-header-end))) | 455 LOUDLY controls if a user sees a message about the fontification |
456 operation." | |
457 (let ((header-end (mh-mail-header-end))) | |
428 (cond | 458 (cond |
429 ((and (< beg header-end)(< end header-end)) | 459 ((and (< beg header-end)(< end header-end)) |
430 (font-lock-default-fontify-region beg end loudly)) | 460 (font-lock-default-fontify-region beg end loudly)) |
431 ((and (< beg header-end)(>= end header-end)) | 461 ((and (< beg header-end)(>= end header-end)) |
432 (font-lock-default-fontify-region beg header-end loudly)) | 462 (font-lock-default-fontify-region beg header-end loudly)) |
433 (t | 463 (t |
434 nil)))) | 464 nil)))) |
435 | 465 |
436 ;; Needed to help shush the byte-compiler. | 466 ;; Shush compiler. |
437 (if mh-xemacs-flag | 467 (if mh-xemacs-flag |
438 (progn | 468 (eval-and-compile |
439 (eval-and-compile | 469 (require 'gnus) |
440 (require 'gnus) | 470 (require 'gnus-art) |
441 (require 'gnus-art) | 471 (require 'gnus-cite))) |
442 (require 'gnus-cite)))) | |
443 | 472 |
444 (defun mh-gnus-article-highlight-citation () | 473 (defun mh-gnus-article-highlight-citation () |
445 "Highlight cited text in current buffer using gnus." | 474 "Highlight cited text in current buffer using Gnus." |
446 (interactive) | 475 (interactive) |
447 ;; Requiring gnus-cite should have been sufficient. However for Emacs21.1, | 476 ;; 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 | 477 ;; 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 | 478 ;; 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 | 479 ;; of recursive-load-depth-limit). That gets rid of a compiler warning as |
460 (gnus-cite-face-list `(,@(cdr gnus-cite-face-list) | 489 (gnus-cite-face-list `(,@(cdr gnus-cite-face-list) |
461 ,(car gnus-cite-face-list)))) | 490 ,(car gnus-cite-face-list)))) |
462 (gnus-article-highlight-citation t) | 491 (gnus-article-highlight-citation t) |
463 (set-buffer-modified-p modified)))) | 492 (set-buffer-modified-p modified)))) |
464 | 493 |
494 | |
495 | |
465 ;;; Internal bookkeeping variables: | 496 ;;; Internal bookkeeping variables: |
466 | 497 |
467 ;; Cached value of the `Path:' component in the user's MH profile. | 498 (defvar mh-user-path nil |
468 ;; User's mail folder directory. | 499 "Cached value of the \"Path:\" MH profile component. |
469 (defvar mh-user-path nil) | 500 User's mail folder directory.") |
470 | 501 |
471 ;; An mh-draft-folder of nil means do not use a draft folder. | 502 (defvar mh-draft-folder nil |
472 ;; Cached value of the `Draft-Folder:' component in the user's MH profile. | 503 "Cached value of the \"Draft-Folder:\" MH profile component. |
473 ;; Name of folder containing draft messages. | 504 Name of folder containing draft messages. |
474 (defvar mh-draft-folder nil) | 505 Nil means do not use a draft folder.") |
475 | 506 |
476 ;; Cached value of the `Unseen-Sequence:' component in the user's MH profile. | 507 (defvar mh-unseen-seq nil |
477 ;; Name of the Unseen sequence. | 508 "Cached value of the \"Unseen-Sequence:\" MH profile component. |
478 (defvar mh-unseen-seq nil) | 509 Name of the Unseen sequence.") |
479 | 510 |
480 ;; Cached value of the `Previous-Sequence:' component in the user's MH | 511 (defvar mh-previous-seq nil |
481 ;; profile. | 512 "Cached value of the \"Previous-Sequence:\" MH profile component. |
482 ;; Name of the Previous sequence. | 513 Name of the Previous sequence.") |
483 (defvar mh-previous-seq nil) | 514 |
484 | 515 (defvar mh-inbox nil |
485 ;; Cached value of the `Inbox:' component in the user's MH profile, | 516 "Cached value of the \"Inbox:\" MH profile component. |
486 ;; or "+inbox" if no such component. | 517 Set to \"+inbox\" if no such component. |
487 ;; Name of the Inbox folder. | 518 Name of the Inbox folder.") |
488 (defvar mh-inbox nil) | 519 |
489 | 520 (defvar mh-previous-window-config nil |
490 ;; The names of ephemeral buffers have a " *mh-" prefix (so that they are | 521 "Window configuration before MH-E command.") |
491 ;; hidden and can be programmatically removed in mh-quit), and the variable | 522 |
492 ;; names have the form mh-temp-.*-buffer. | 523 (defvar mh-page-to-next-msg-flag nil |
493 (defconst mh-temp-buffer " *mh-temp*") ;scratch | 524 "Non-nil means next SPC or whatever goes to next undeleted message.") |
494 | 525 |
495 ;; The names of MH-E buffers that are not ephemeral and can be used by the | 526 |
496 ;; user (and deleted by the user when no longer needed) have a "*MH-E " prefix | |
497 ;; (so they can be programmatically removed in mh-quit), and the variable | |
498 ;; names have the form mh-.*-buffer. | |
499 (defconst mh-folders-buffer "*MH-E Folders*") ;folder list | |
500 (defconst mh-info-buffer "*MH-E Info*") ;version information buffer | |
501 (defconst mh-log-buffer "*MH-E Log*") ;output of MH commands and so on | |
502 (defconst mh-recipients-buffer "*MH-E Recipients*") ;killed when draft sent | |
503 (defconst mh-sequences-buffer "*MH-E Sequences*") ;sequences list | |
504 | |
505 ;; Window configuration before MH-E command. | |
506 (defvar mh-previous-window-config nil) | |
507 | |
508 ;;Non-nil means next SPC or whatever goes to next undeleted message. | |
509 (defvar mh-page-to-next-msg-flag nil) | |
510 | 527 |
511 ;;; Internal variables local to a folder. | 528 ;;; Internal variables local to a folder. |
512 | 529 |
513 ;; Name of current folder, a string. | 530 (defvar mh-current-folder nil |
514 (defvar mh-current-folder nil) | 531 "Name of current folder, a string.") |
515 | 532 |
516 ;; Buffer that displays message for this folder. | 533 (defvar mh-show-buffer nil |
517 (defvar mh-show-buffer nil) | 534 "Buffer that displays message for this folder.") |
518 | 535 |
519 ;; Full path of directory for this folder. | 536 (defvar mh-folder-filename nil |
520 (defvar mh-folder-filename nil) | 537 "Full path of directory for this folder.") |
521 | 538 |
522 ;;Number of msgs in buffer. | 539 (defvar mh-msg-count nil |
523 (defvar mh-msg-count nil) | 540 "Number of msgs in buffer.") |
524 | 541 |
525 ;; If non-nil, show the message in a separate window. | 542 (defvar mh-showing-mode nil |
526 (defvar mh-showing-mode nil) | 543 "If non-nil, show the message in a separate window.") |
527 | 544 |
528 (defvar mh-show-mode-map (make-sparse-keymap) | 545 (defvar mh-show-mode-map (make-sparse-keymap) |
529 "Keymap used by the show buffer.") | 546 "Keymap used by the show buffer.") |
530 | 547 |
531 (defvar mh-show-folder-buffer nil | 548 (defvar mh-show-folder-buffer nil |
533 | 550 |
534 (defvar mh-logo-cache nil) | 551 (defvar mh-logo-cache nil) |
535 | 552 |
536 (defun mh-logo-display () | 553 (defun mh-logo-display () |
537 "Modify mode line to display MH-E logo." | 554 "Modify mode line to display MH-E logo." |
538 (when (fboundp 'find-image) | 555 (mh-do-in-gnu-emacs |
539 (add-text-properties | 556 (add-text-properties |
540 0 2 | 557 0 2 |
541 `(display ,(or mh-logo-cache | 558 `(display ,(or mh-logo-cache |
542 (setq mh-logo-cache | 559 (setq mh-logo-cache |
543 (find-image '((:type xpm :ascent center | 560 (mh-funcall-if-exists |
544 :file "mh-logo.xpm")))))) | 561 find-image '((:type xpm :ascent center |
545 (car mode-line-buffer-identification)))) | 562 :file "mh-logo.xpm")))))) |
546 | 563 (car mode-line-buffer-identification))) |
547 ;;; This holds a documentation string used by describe-mode. | 564 (mh-do-in-xemacs |
565 (setq modeline-buffer-identification | |
566 (list | |
567 (if mh-modeline-glyph | |
568 (cons modeline-buffer-id-left-extent mh-modeline-glyph) | |
569 (cons modeline-buffer-id-left-extent "XEmacs%N:")) | |
570 (cons modeline-buffer-id-right-extent " %17b"))))) | |
571 | |
548 (defun mh-showing-mode (&optional arg) | 572 (defun mh-showing-mode (&optional arg) |
549 "Change whether messages should be displayed. | 573 "Change whether messages should be displayed. |
550 With arg, display messages iff ARG is positive." | 574 |
575 With ARG, display messages iff ARG is positive." | |
551 (setq mh-showing-mode | 576 (setq mh-showing-mode |
552 (if (null arg) | 577 (if (null arg) |
553 (not mh-showing-mode) | 578 (not mh-showing-mode) |
554 (> (prefix-numeric-value arg) 0)))) | 579 (> (prefix-numeric-value arg) 0)))) |
555 | 580 |
556 ;; The sequences of this folder. An alist of (seq . msgs). | 581 (defvar mh-seq-list nil |
557 (defvar mh-seq-list nil) | 582 "Alist of this folder's sequences. |
558 | 583 Elements have the form (SEQUENCE . MESSAGES).") |
559 ;; List of displayed messages to be removed from the Unseen sequence. | 584 |
560 (defvar mh-seen-list nil) | 585 (defvar mh-seen-list nil |
561 | 586 "List of displayed messages to be removed from the \"Unseen\" sequence.") |
562 ;; If non-nil, show buffer contains message with all headers. | 587 |
563 ;; If nil, show buffer contains message processed normally. | 588 (defvar mh-showing-with-headers nil |
564 ;; Showing message with headers or normally. | 589 "If non-nil, MH-Show buffer contains message with all header fields. |
565 (defvar mh-showing-with-headers nil) | 590 If nil, MH-Show buffer contains message processed normally.") |
566 | 591 |
592 | |
567 | 593 |
568 ;;; MH-E macros | 594 ;;; MH-E macros |
569 | 595 |
570 (defmacro with-mh-folder-updating (save-modification-flag &rest body) | 596 (defmacro with-mh-folder-updating (save-modification-flag &rest body) |
571 "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). | 597 "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). |
572 Execute BODY, which can modify the folder buffer without having to | 598 Execute BODY, which can modify the folder buffer without having to |
573 worry about file locking or the read-only flag, and return its result. | 599 worry about file locking or the read-only flag, and return its result. |
574 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification | 600 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification flag |
575 flag is unchanged, otherwise it is cleared." | 601 is unchanged, otherwise it is cleared." |
576 (setq save-modification-flag (car save-modification-flag)) ; CL style | 602 (setq save-modification-flag (car save-modification-flag)) ; CL style |
577 `(prog1 | 603 `(prog1 |
578 (let ((mh-folder-updating-mod-flag (buffer-modified-p)) | 604 (let ((mh-folder-updating-mod-flag (buffer-modified-p)) |
579 (buffer-read-only nil) | 605 (buffer-read-only nil) |
580 (buffer-file-name nil)) ;don't let the buffer get locked | 606 (buffer-file-name nil)) ;don't let the buffer get locked |
583 ,@body) | 609 ,@body) |
584 (mh-set-folder-modified-p mh-folder-updating-mod-flag))) | 610 (mh-set-folder-modified-p mh-folder-updating-mod-flag))) |
585 ,@(if (not save-modification-flag) | 611 ,@(if (not save-modification-flag) |
586 '((mh-set-folder-modified-p nil))))) | 612 '((mh-set-folder-modified-p nil))))) |
587 | 613 |
588 (put 'with-mh-folder-updating 'lisp-indent-hook 1) | 614 (put 'with-mh-folder-updating 'lisp-indent-hook 'defun) |
589 | 615 |
590 (defmacro mh-in-show-buffer (show-buffer &rest body) | 616 (defmacro mh-in-show-buffer (show-buffer &rest body) |
591 "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY). | 617 "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY). |
592 Display buffer SHOW-BUFFER in other window and execute BODY in it. | 618 Display buffer SHOW-BUFFER in other window and execute BODY in it. |
593 Stronger than `save-excursion', weaker than `save-window-excursion'." | 619 Stronger than `save-excursion', weaker than `save-window-excursion'." |
598 (unwind-protect | 624 (unwind-protect |
599 (progn | 625 (progn |
600 ,@body) | 626 ,@body) |
601 (select-window mh-in-show-buffer-saved-window)))) | 627 (select-window mh-in-show-buffer-saved-window)))) |
602 | 628 |
603 (put 'mh-in-show-buffer 'lisp-indent-hook 1) | 629 (put 'mh-in-show-buffer 'lisp-indent-hook 'defun) |
630 | |
631 (defmacro mh-do-at-event-location (event &rest body) | |
632 "Switch to the location of EVENT and execute BODY. | |
633 After BODY has been executed return to original window. The | |
634 modification flag of the buffer in the event window is | |
635 preserved." | |
636 (let ((event-window (make-symbol "event-window")) | |
637 (event-position (make-symbol "event-position")) | |
638 (original-window (make-symbol "original-window")) | |
639 (original-position (make-symbol "original-position")) | |
640 (modified-flag (make-symbol "modified-flag"))) | |
641 `(save-excursion | |
642 (let* ((,event-window | |
643 (or (mh-funcall-if-exists posn-window (event-start ,event)) | |
644 (mh-funcall-if-exists event-window ,event))) | |
645 (,event-position | |
646 (or (mh-funcall-if-exists posn-point (event-start ,event)) | |
647 (mh-funcall-if-exists event-closest-point ,event))) | |
648 (,original-window (selected-window)) | |
649 (,original-position (progn | |
650 (set-buffer (window-buffer ,event-window)) | |
651 (set-marker (make-marker) (point)))) | |
652 (,modified-flag (buffer-modified-p)) | |
653 (buffer-read-only nil)) | |
654 (unwind-protect (progn | |
655 (select-window ,event-window) | |
656 (goto-char ,event-position) | |
657 ,@body) | |
658 (set-buffer-modified-p ,modified-flag) | |
659 (goto-char ,original-position) | |
660 (set-marker ,original-position nil) | |
661 (select-window ,original-window)))))) | |
662 | |
663 (put 'mh-do-at-event-location 'lisp-indent-hook 'defun) | |
604 | 664 |
605 (defmacro mh-make-seq (name msgs) | 665 (defmacro mh-make-seq (name msgs) |
606 "Create sequence NAME with the given MSGS." | 666 "Create sequence NAME with the given MSGS." |
607 (list 'cons name msgs)) | 667 (list 'cons name msgs)) |
608 | 668 |
614 "Extract messages from the given SEQUENCE." | 674 "Extract messages from the given SEQUENCE." |
615 (list 'cdr sequence)) | 675 (list 'cdr sequence)) |
616 | 676 |
617 (defun mh-recenter (arg) | 677 (defun mh-recenter (arg) |
618 "Like recenter but with three improvements: | 678 "Like recenter but with three improvements: |
679 | |
619 - At the end of the buffer it tries to show fewer empty lines. | 680 - At the end of the buffer it tries to show fewer empty lines. |
681 | |
620 - operates only if the current buffer is in the selected window. | 682 - operates only if the current buffer is in the selected window. |
621 (Commands like `save-some-buffers' can make this false.) | 683 (Commands like `save-some-buffers' can make this false.) |
684 | |
622 - nil ARG means recenter as if prefix argument had been given." | 685 - nil ARG means recenter as if prefix argument had been given." |
623 (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) | 686 (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) |
624 nil) | 687 nil) |
625 ((= (point-max) (save-excursion | 688 ((= (point-max) (save-excursion |
626 (forward-line (- (/ (window-height) 2) 2)) | 689 (forward-line (- (/ (window-height) 2) 2)) |
657 (error "Flushing changes not confirmed")) | 720 (error "Flushing changes not confirmed")) |
658 (clear-visited-file-modtime) | 721 (clear-visited-file-modtime) |
659 (unlock-buffer) | 722 (unlock-buffer) |
660 (setq buffer-file-name nil)) | 723 (setq buffer-file-name nil)) |
661 | 724 |
662 ;;;###mh-autoload | |
663 (defun mh-get-msg-num (error-if-no-message) | 725 (defun mh-get-msg-num (error-if-no-message) |
664 "Return the message number of the displayed message. | 726 "Return the message number of the displayed message. |
665 If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is | 727 If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if |
666 not pointing to a message." | 728 the cursor is not pointing to a message." |
667 (save-excursion | 729 (save-excursion |
668 (beginning-of-line) | 730 (beginning-of-line) |
669 (cond ((looking-at mh-scan-msg-number-regexp) | 731 (cond ((looking-at mh-scan-msg-number-regexp) |
670 (string-to-int (buffer-substring (match-beginning 1) | 732 (string-to-number (buffer-substring (match-beginning 1) |
671 (match-end 1)))) | 733 (match-end 1)))) |
672 (error-if-no-message | 734 (error-if-no-message |
673 (error "Cursor not pointing to message")) | 735 (error "Cursor not pointing to message")) |
674 (t nil)))) | 736 (t nil)))) |
675 | 737 |
676 (defun mh-folder-name-p (name) | 738 (defun mh-folder-name-p (name) |
677 "Return non-nil if NAME is the name of a folder. | 739 "Return non-nil if NAME is the name of a folder. |
678 A name (a string or symbol) can be a folder name if it begins with \"+\"." | 740 A name (a string or symbol) can be a folder name if it begins |
741 with \"+\"." | |
679 (if (symbolp name) | 742 (if (symbolp name) |
680 (eq (aref (symbol-name name) 0) ?+) | 743 (eq (aref (symbol-name name) 0) ?+) |
681 (and (> (length name) 0) | 744 (and (> (length name) 0) |
682 (eq (aref name 0) ?+)))) | 745 (eq (aref name 0) ?+)))) |
683 | |
684 | 746 |
685 (defun mh-expand-file-name (filename &optional default) | 747 (defun mh-expand-file-name (filename &optional default) |
686 "Expand FILENAME like `expand-file-name', but also handle MH folder names. | 748 "Expand FILENAME like `expand-file-name', but also handle MH folder names. |
687 Any filename that starts with '+' is treated as a folder name. | 749 Any filename that starts with '+' is treated as a folder name. |
688 See `expand-file-name' for description of DEFAULT." | 750 See `expand-file-name' for description of DEFAULT." |
689 (if (mh-folder-name-p filename) | 751 (if (mh-folder-name-p filename) |
690 (expand-file-name (substring filename 1) mh-user-path) | 752 (expand-file-name (substring filename 1) mh-user-path) |
691 (expand-file-name filename default))) | 753 (expand-file-name filename default))) |
692 | 754 |
693 | |
694 (defun mh-msg-filename (msg &optional folder) | 755 (defun mh-msg-filename (msg &optional folder) |
695 "Return the file name of MSG in FOLDER (default current folder)." | 756 "Return the file name of MSG in FOLDER (default current folder)." |
696 (expand-file-name (int-to-string msg) | 757 (expand-file-name (int-to-string msg) |
697 (if folder | 758 (if folder |
698 (mh-expand-file-name folder) | 759 (mh-expand-file-name folder) |
699 mh-folder-filename))) | 760 mh-folder-filename))) |
700 | 761 |
701 ;;; Infrastructure to generate show-buffer functions from folder functions | 762 ;; Infrastructure to generate show-buffer functions from folder functions |
702 ;;; XEmacs does not have deactivate-mark? What is the equivalent of | 763 ;; XEmacs does not have deactivate-mark? What is the equivalent of |
703 ;;; transient-mark-mode for XEmacs? Should we be restoring the mark in the | 764 ;; transient-mark-mode for XEmacs? Should we be restoring the mark in the |
704 ;;; folder buffer after the operation has been carried out. | 765 ;; folder buffer after the operation has been carried out. |
705 (defmacro mh-defun-show-buffer (function original-function | 766 (defmacro mh-defun-show-buffer (function original-function |
706 &optional dont-return) | 767 &optional dont-return) |
707 "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. | 768 "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. |
708 If the buffer we start in is still visible and DONT-RETURN is nil then switch | 769 If the buffer we start in is still visible and DONT-RETURN is nil |
709 to it after that." | 770 then switch to it after that." |
710 `(defun ,function () | 771 `(defun ,function () |
711 ,(format "Calls %s from the message's folder.\n%s\nSee `%s' for more info.\n" | 772 ,(format "Calls %s from the message's folder.\n%s\nSee \"%s\" for more info.\n" |
712 original-function | 773 original-function |
713 (if dont-return "" | 774 (if dont-return "" |
714 "When function completes, returns to the show buffer if it is | 775 "When function completes, returns to the show buffer if it is |
715 still visible.\n") | 776 still visible.\n") |
716 original-function) | 777 original-function) |
724 (unless (equal (buffer-name | 785 (unless (equal (buffer-name |
725 (window-buffer (frame-first-window (selected-frame)))) | 786 (window-buffer (frame-first-window (selected-frame)))) |
726 folder-buffer) | 787 folder-buffer) |
727 (delete-other-windows)) | 788 (delete-other-windows)) |
728 (mh-goto-cur-msg t) | 789 (mh-goto-cur-msg t) |
729 (and (fboundp 'deactivate-mark) (deactivate-mark)) | 790 (mh-funcall-if-exists deactivate-mark) |
730 (unwind-protect | 791 (unwind-protect |
731 (prog1 (call-interactively (function ,original-function)) | 792 (prog1 (call-interactively (function ,original-function)) |
732 (setq normal-exit t)) | 793 (setq normal-exit t)) |
733 (and (fboundp 'deactivate-mark) (deactivate-mark)) | 794 (mh-funcall-if-exists deactivate-mark) |
795 (when (eq major-mode 'mh-folder-mode) | |
796 (mh-funcall-if-exists hl-line-highlight)) | |
734 (cond ((not normal-exit) | 797 (cond ((not normal-exit) |
735 (set-window-configuration config)) | 798 (set-window-configuration config)) |
736 ,(if dont-return | 799 ,(if dont-return |
737 `(t (setq mh-previous-window-config config)) | 800 `(t (setq mh-previous-window-config config)) |
738 `((and (get-buffer cur-buffer-name) | 801 `((and (get-buffer cur-buffer-name) |
739 (window-live-p (get-buffer-window | 802 (window-live-p (get-buffer-window |
740 (get-buffer cur-buffer-name)))) | 803 (get-buffer cur-buffer-name)))) |
741 (pop-to-buffer (get-buffer cur-buffer-name) nil))))))))) | 804 (pop-to-buffer (get-buffer cur-buffer-name) nil))))))))) |
742 | 805 |
743 ;;; Generate interactive functions for the show buffer from the corresponding | 806 ;; Generate interactive functions for the show buffer from the corresponding |
744 ;;; folder functions. | 807 ;; folder functions. |
745 (mh-defun-show-buffer mh-show-previous-undeleted-msg | 808 (mh-defun-show-buffer mh-show-previous-undeleted-msg |
746 mh-previous-undeleted-msg) | 809 mh-previous-undeleted-msg) |
747 (mh-defun-show-buffer mh-show-next-undeleted-msg | 810 (mh-defun-show-buffer mh-show-next-undeleted-msg |
748 mh-next-undeleted-msg) | 811 mh-next-undeleted-msg) |
749 (mh-defun-show-buffer mh-show-quit mh-quit) | 812 (mh-defun-show-buffer mh-show-quit mh-quit) |
781 (mh-defun-show-buffer mh-show-visit-folder mh-visit-folder t) | 844 (mh-defun-show-buffer mh-show-visit-folder mh-visit-folder t) |
782 (mh-defun-show-buffer mh-show-rescan-folder mh-rescan-folder) | 845 (mh-defun-show-buffer mh-show-rescan-folder mh-rescan-folder) |
783 (mh-defun-show-buffer mh-show-pack-folder mh-pack-folder) | 846 (mh-defun-show-buffer mh-show-pack-folder mh-pack-folder) |
784 (mh-defun-show-buffer mh-show-kill-folder mh-kill-folder t) | 847 (mh-defun-show-buffer mh-show-kill-folder mh-kill-folder t) |
785 (mh-defun-show-buffer mh-show-list-folders mh-list-folders t) | 848 (mh-defun-show-buffer mh-show-list-folders mh-list-folders t) |
786 (mh-defun-show-buffer mh-show-search-folder mh-search-folder t) | |
787 (mh-defun-show-buffer mh-show-undo-folder mh-undo-folder) | 849 (mh-defun-show-buffer mh-show-undo-folder mh-undo-folder) |
788 (mh-defun-show-buffer mh-show-delete-msg-from-seq | 850 (mh-defun-show-buffer mh-show-delete-msg-from-seq |
789 mh-delete-msg-from-seq) | 851 mh-delete-msg-from-seq) |
790 (mh-defun-show-buffer mh-show-delete-seq mh-delete-seq) | 852 (mh-defun-show-buffer mh-show-delete-seq mh-delete-seq) |
791 (mh-defun-show-buffer mh-show-list-sequences mh-list-sequences) | 853 (mh-defun-show-buffer mh-show-list-sequences mh-list-sequences) |
792 (mh-defun-show-buffer mh-show-narrow-to-seq mh-narrow-to-seq) | 854 (mh-defun-show-buffer mh-show-narrow-to-seq mh-narrow-to-seq) |
793 (mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq) | 855 (mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq) |
794 (mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq) | 856 (mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq) |
795 (mh-defun-show-buffer mh-show-widen mh-widen) | 857 (mh-defun-show-buffer mh-show-widen mh-widen) |
796 (mh-defun-show-buffer mh-show-narrow-to-subject | 858 (mh-defun-show-buffer mh-show-narrow-to-subject mh-narrow-to-subject) |
797 mh-narrow-to-subject) | 859 (mh-defun-show-buffer mh-show-narrow-to-from mh-narrow-to-from) |
860 (mh-defun-show-buffer mh-show-narrow-to-cc mh-narrow-to-cc) | |
861 (mh-defun-show-buffer mh-show-narrow-to-range mh-narrow-to-range) | |
862 (mh-defun-show-buffer mh-show-narrow-to-to mh-narrow-to-to) | |
798 (mh-defun-show-buffer mh-show-store-msg mh-store-msg) | 863 (mh-defun-show-buffer mh-show-store-msg mh-store-msg) |
799 (mh-defun-show-buffer mh-show-page-digest mh-page-digest) | 864 (mh-defun-show-buffer mh-show-page-digest mh-page-digest) |
800 (mh-defun-show-buffer mh-show-page-digest-backwards | 865 (mh-defun-show-buffer mh-show-page-digest-backwards |
801 mh-page-digest-backwards) | 866 mh-page-digest-backwards) |
802 (mh-defun-show-buffer mh-show-burst-digest mh-burst-digest) | 867 (mh-defun-show-buffer mh-show-burst-digest mh-burst-digest) |
817 (mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor) | 882 (mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor) |
818 (mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling) | 883 (mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling) |
819 (mh-defun-show-buffer mh-show-thread-previous-sibling | 884 (mh-defun-show-buffer mh-show-thread-previous-sibling |
820 mh-thread-previous-sibling) | 885 mh-thread-previous-sibling) |
821 (mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t) | 886 (mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t) |
822 | 887 (mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick) |
823 ;;; Populate mh-show-mode-map | 888 (mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick) |
889 (mh-defun-show-buffer mh-show-junk-blacklist mh-junk-blacklist) | |
890 (mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist) | |
891 (mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages) | |
892 (mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages) | |
893 (mh-defun-show-buffer mh-show-index-sequenced-messages | |
894 mh-index-sequenced-messages) | |
895 (mh-defun-show-buffer mh-show-catchup mh-catchup) | |
896 (mh-defun-show-buffer mh-show-ps-print-toggle-color mh-ps-print-toggle-color) | |
897 (mh-defun-show-buffer mh-show-ps-print-toggle-faces mh-ps-print-toggle-faces) | |
898 (mh-defun-show-buffer mh-show-ps-print-msg-file mh-ps-print-msg-file) | |
899 (mh-defun-show-buffer mh-show-ps-print-msg mh-ps-print-msg) | |
900 (mh-defun-show-buffer mh-show-toggle-mime-buttons mh-toggle-mime-buttons) | |
901 (mh-defun-show-buffer mh-show-display-with-external-viewer | |
902 mh-display-with-external-viewer) | |
903 | |
904 | |
905 | |
906 ;;; Build mh-show-mode keymaps | |
907 | |
824 (gnus-define-keys mh-show-mode-map | 908 (gnus-define-keys mh-show-mode-map |
825 " " mh-show-page-msg | 909 " " mh-show-page-msg |
826 "!" mh-show-refile-or-write-again | 910 "!" mh-show-refile-or-write-again |
911 "'" mh-show-toggle-tick | |
827 "," mh-show-header-display | 912 "," mh-show-header-display |
828 "." mh-show-show | 913 "." mh-show-show |
829 ">" mh-show-write-message-to-file | 914 ">" mh-show-write-message-to-file |
830 "?" mh-help | 915 "?" mh-help |
831 "E" mh-show-extract-rejected-mail | 916 "E" mh-show-extract-rejected-mail |
842 "e" mh-show-edit-again | 927 "e" mh-show-edit-again |
843 "f" mh-show-forward | 928 "f" mh-show-forward |
844 "g" mh-show-goto-msg | 929 "g" mh-show-goto-msg |
845 "i" mh-show-inc-folder | 930 "i" mh-show-inc-folder |
846 "k" mh-show-delete-subject-or-thread | 931 "k" mh-show-delete-subject-or-thread |
847 "l" mh-show-print-msg | |
848 "m" mh-show-send | 932 "m" mh-show-send |
849 "n" mh-show-next-undeleted-msg | 933 "n" mh-show-next-undeleted-msg |
850 "\M-n" mh-show-next-unread-msg | 934 "\M-n" mh-show-next-unread-msg |
851 "o" mh-show-refile-msg | 935 "o" mh-show-refile-msg |
852 "p" mh-show-previous-undeleted-msg | 936 "p" mh-show-previous-undeleted-msg |
860 "v" mh-show-index-visit-folder | 944 "v" mh-show-index-visit-folder |
861 "|" mh-show-pipe-msg) | 945 "|" mh-show-pipe-msg) |
862 | 946 |
863 (gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) | 947 (gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) |
864 "?" mh-prefix-help | 948 "?" mh-prefix-help |
949 "'" mh-index-ticked-messages | |
865 "S" mh-show-sort-folder | 950 "S" mh-show-sort-folder |
951 "c" mh-show-catchup | |
866 "f" mh-show-visit-folder | 952 "f" mh-show-visit-folder |
867 "i" mh-index-search | |
868 "k" mh-show-kill-folder | 953 "k" mh-show-kill-folder |
869 "l" mh-show-list-folders | 954 "l" mh-show-list-folders |
955 "n" mh-index-new-messages | |
870 "o" mh-show-visit-folder | 956 "o" mh-show-visit-folder |
957 "q" mh-show-index-sequenced-messages | |
871 "r" mh-show-rescan-folder | 958 "r" mh-show-rescan-folder |
872 "s" mh-show-search-folder | 959 "s" mh-search |
873 "t" mh-show-toggle-threads | 960 "t" mh-show-toggle-threads |
874 "u" mh-show-undo-folder | 961 "u" mh-show-undo-folder |
875 "v" mh-show-visit-folder) | 962 "v" mh-show-visit-folder) |
876 | 963 |
877 (gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map) | 964 (gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map) |
965 "'" mh-show-narrow-to-tick | |
878 "?" mh-prefix-help | 966 "?" mh-prefix-help |
879 "d" mh-show-delete-msg-from-seq | 967 "d" mh-show-delete-msg-from-seq |
880 "k" mh-show-delete-seq | 968 "k" mh-show-delete-seq |
881 "l" mh-show-list-sequences | 969 "l" mh-show-list-sequences |
882 "n" mh-show-narrow-to-seq | 970 "n" mh-show-narrow-to-seq |
883 "p" mh-show-put-msg-in-seq | 971 "p" mh-show-put-msg-in-seq |
884 "s" mh-show-msg-is-in-seq | 972 "s" mh-show-msg-is-in-seq |
885 "w" mh-show-widen) | 973 "w" mh-show-widen) |
886 | 974 |
975 (define-key mh-show-mode-map "I" mh-inc-spool-map) | |
976 | |
977 (gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map) | |
978 "?" mh-prefix-help | |
979 "b" mh-show-junk-blacklist | |
980 "w" mh-show-junk-whitelist) | |
981 | |
982 (gnus-define-keys (mh-show-ps-print-map "P" mh-show-mode-map) | |
983 "?" mh-prefix-help | |
984 "C" mh-show-ps-print-toggle-color | |
985 "F" mh-show-ps-print-toggle-faces | |
986 "f" mh-show-ps-print-msg-file | |
987 "l" mh-show-print-msg | |
988 "p" mh-show-ps-print-msg) | |
989 | |
887 (gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) | 990 (gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) |
888 "?" mh-prefix-help | 991 "?" mh-prefix-help |
889 "u" mh-show-thread-ancestor | 992 "u" mh-show-thread-ancestor |
890 "p" mh-show-thread-previous-sibling | 993 "p" mh-show-thread-previous-sibling |
891 "n" mh-show-thread-next-sibling | 994 "n" mh-show-thread-next-sibling |
892 "t" mh-show-toggle-threads | 995 "t" mh-show-toggle-threads |
893 "d" mh-show-thread-delete | 996 "d" mh-show-thread-delete |
894 "o" mh-show-thread-refile) | 997 "o" mh-show-thread-refile) |
895 | 998 |
896 (gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) | 999 (gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) |
1000 "'" mh-show-narrow-to-tick | |
897 "?" mh-prefix-help | 1001 "?" mh-prefix-help |
1002 "c" mh-show-narrow-to-cc | |
1003 "f" mh-show-narrow-to-from | |
1004 "r" mh-show-narrow-to-range | |
898 "s" mh-show-narrow-to-subject | 1005 "s" mh-show-narrow-to-subject |
1006 "t" mh-show-narrow-to-to | |
899 "w" mh-show-widen) | 1007 "w" mh-show-widen) |
900 | 1008 |
901 (gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) | 1009 (gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) |
902 "?" mh-prefix-help | 1010 "?" mh-prefix-help |
903 "s" mh-show-store-msg | 1011 "s" mh-show-store-msg |
911 "b" mh-show-burst-digest) | 1019 "b" mh-show-burst-digest) |
912 | 1020 |
913 (gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) | 1021 (gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) |
914 "?" mh-prefix-help | 1022 "?" mh-prefix-help |
915 "a" mh-mime-save-parts | 1023 "a" mh-mime-save-parts |
1024 "e" mh-show-display-with-external-viewer | |
916 "v" mh-show-toggle-mime-part | 1025 "v" mh-show-toggle-mime-part |
917 "o" mh-show-save-mime-part | 1026 "o" mh-show-save-mime-part |
918 "i" mh-show-inline-mime-part | 1027 "i" mh-show-inline-mime-part |
1028 "t" mh-show-toggle-mime-buttons | |
919 "\t" mh-show-next-button | 1029 "\t" mh-show-next-button |
920 [backtab] mh-show-prev-button | 1030 [backtab] mh-show-prev-button |
921 "\M-\t" mh-show-prev-button) | 1031 "\M-\t" mh-show-prev-button) |
922 | 1032 |
923 (easy-menu-define | 1033 (easy-menu-define |
930 ["Delete Sequence..." mh-show-delete-seq t] | 1040 ["Delete Sequence..." mh-show-delete-seq t] |
931 ["Narrow to Sequence..." mh-show-narrow-to-seq t] | 1041 ["Narrow to Sequence..." mh-show-narrow-to-seq t] |
932 ["Widen from Sequence" mh-show-widen t] | 1042 ["Widen from Sequence" mh-show-widen t] |
933 "--" | 1043 "--" |
934 ["Narrow to Subject Sequence" mh-show-narrow-to-subject t] | 1044 ["Narrow to Subject Sequence" mh-show-narrow-to-subject t] |
1045 ["Narrow to Tick Sequence" mh-show-narrow-to-tick | |
1046 (save-excursion | |
1047 (set-buffer mh-show-folder-buffer) | |
1048 (and mh-tick-seq (mh-seq-msgs (mh-find-seq mh-tick-seq))))] | |
935 ["Delete Rest of Same Subject" mh-show-delete-subject t] | 1049 ["Delete Rest of Same Subject" mh-show-delete-subject t] |
1050 ["Toggle Tick Mark" mh-show-toggle-tick t] | |
936 "--" | 1051 "--" |
937 ["Push State Out to MH" mh-show-update-sequences t])) | 1052 ["Push State Out to MH" mh-show-update-sequences t])) |
938 | 1053 |
939 (easy-menu-define | 1054 (easy-menu-define |
940 mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message." | 1055 mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message." |
977 ["Pack Folder" mh-show-pack-folder t] | 1092 ["Pack Folder" mh-show-pack-folder t] |
978 ["Sort Folder" mh-show-sort-folder t] | 1093 ["Sort Folder" mh-show-sort-folder t] |
979 "--" | 1094 "--" |
980 ["List Folders" mh-show-list-folders t] | 1095 ["List Folders" mh-show-list-folders t] |
981 ["Visit a Folder..." mh-show-visit-folder t] | 1096 ["Visit a Folder..." mh-show-visit-folder t] |
982 ["Search a Folder..." mh-show-search-folder t] | 1097 ["View New Messages" mh-show-index-new-messages t] |
983 ["Indexed Search..." mh-index-search t] | 1098 ["Search..." mh-search t] |
984 "--" | 1099 "--" |
985 ["Quit MH-E" mh-quit t])) | 1100 ["Quit MH-E" mh-quit t])) |
986 | 1101 |
987 | 1102 ;; Ensure new buffers won't get this mode if default-major-mode is nil. |
988 ;;; Ensure new buffers won't get this mode if default-major-mode is nil. | |
989 (put 'mh-show-mode 'mode-class 'special) | 1103 (put 'mh-show-mode 'mode-class 'special) |
1104 | |
1105 ;; Shush compiler. | |
1106 (eval-when-compile (defvar font-lock-auto-fontify)) | |
990 | 1107 |
991 (define-derived-mode mh-show-mode text-mode "MH-Show" | 1108 (define-derived-mode mh-show-mode text-mode "MH-Show" |
992 "Major mode for showing messages in MH-E.\\<mh-show-mode-map> | 1109 "Major mode for showing messages in MH-E.\\<mh-show-mode-map> |
993 The value of `mh-show-mode-hook' is a list of functions to | 1110 |
994 be called, with no arguments, upon entry to this mode." | 1111 The hook `mh-show-mode-hook' is called upon entry to this mode. |
1112 | |
1113 See also `mh-folder-mode'. | |
1114 | |
1115 \\{mh-show-mode-map}" | |
995 (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) | 1116 (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) |
996 (setq paragraph-start (default-value 'paragraph-start)) | 1117 (setq paragraph-start (default-value 'paragraph-start)) |
997 (mh-show-unquote-From) | 1118 (mh-show-unquote-From) |
998 (mh-show-xface) | 1119 (mh-show-xface) |
999 (mh-show-addr) | 1120 (mh-show-addr) |
1121 (setq buffer-invisibility-spec '((vanish . t) t)) | |
1122 (set (make-local-variable 'line-move-ignore-invisible) t) | |
1000 (make-local-variable 'font-lock-defaults) | 1123 (make-local-variable 'font-lock-defaults) |
1001 ;;(set (make-local-variable 'font-lock-support-mode) nil) | 1124 ;;(set (make-local-variable 'font-lock-support-mode) nil) |
1002 (cond | 1125 (cond |
1003 ((equal mh-highlight-citation-p 'font-lock) | 1126 ((equal mh-highlight-citation-style 'font-lock) |
1004 (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) | 1127 (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) |
1005 ((equal mh-highlight-citation-p 'gnus) | 1128 ((equal mh-highlight-citation-style 'gnus) |
1006 (setq font-lock-defaults '((mh-show-font-lock-keywords) | 1129 (setq font-lock-defaults '((mh-show-font-lock-keywords) |
1007 t nil nil nil | 1130 t nil nil nil |
1008 (font-lock-fontify-region-function | 1131 (font-lock-fontify-region-function |
1009 . mh-show-font-lock-fontify-region))) | 1132 . mh-show-font-lock-fontify-region))) |
1010 (mh-gnus-article-highlight-citation)) | 1133 (mh-gnus-article-highlight-citation)) |
1011 (t | 1134 (t |
1012 (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) | 1135 (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) |
1013 (if (and mh-xemacs-flag | 1136 (if (and mh-xemacs-flag |
1014 font-lock-auto-fontify) | 1137 font-lock-auto-fontify) |
1015 (turn-on-font-lock)) | 1138 (turn-on-font-lock)) |
1016 (if (and (boundp 'tool-bar-mode) tool-bar-mode) | 1139 (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map) |
1017 (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)) | 1140 (mh-funcall-if-exists mh-tool-bar-init :show) |
1018 (when mh-decode-mime-flag | 1141 (when mh-decode-mime-flag |
1142 (mh-make-local-hook 'kill-buffer-hook) | |
1019 (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t)) | 1143 (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t)) |
1020 (easy-menu-add mh-show-sequence-menu) | 1144 (easy-menu-add mh-show-sequence-menu) |
1021 (easy-menu-add mh-show-message-menu) | 1145 (easy-menu-add mh-show-message-menu) |
1022 (easy-menu-add mh-show-folder-menu) | 1146 (easy-menu-add mh-show-folder-menu) |
1023 (make-local-variable 'mh-show-folder-buffer) | 1147 (make-local-variable 'mh-show-folder-buffer) |
1024 (buffer-disable-undo) | 1148 (buffer-disable-undo) |
1025 (setq buffer-read-only t) | 1149 (setq buffer-read-only t) |
1026 (use-local-map mh-show-mode-map) | 1150 (use-local-map mh-show-mode-map)) |
1027 (run-hooks 'mh-show-mode-hook)) | |
1028 | 1151 |
1029 (defun mh-show-addr () | 1152 (defun mh-show-addr () |
1030 "Use `goto-address'." | 1153 "Use `goto-address'." |
1031 (when mh-show-use-goto-addr-flag | 1154 (when mh-show-use-goto-addr-flag |
1032 (if (not (featurep 'goto-addr)) | 1155 (if (not (featurep 'goto-addr)) |
1033 (load "goto-addr" t t)) | 1156 (load "goto-addr" t t)) |
1034 (if (fboundp 'goto-address) | 1157 (if (fboundp 'goto-address) |
1035 (goto-address)))) | 1158 (goto-address)))) |
1036 | 1159 |
1160 | |
1161 | |
1162 ;; X-Face and Face display | |
1037 (defvar mh-show-xface-function | 1163 (defvar mh-show-xface-function |
1038 (cond ((and mh-xemacs-flag (locate-library "x-face")) | 1164 (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface))) |
1039 (load "x-face" t t) | 1165 (load "x-face" t t) |
1040 (if (fboundp 'x-face-xmas-wl-display-x-face) | 1166 #'mh-face-display-function) |
1041 #'x-face-xmas-wl-display-x-face | 1167 ((>= emacs-major-version 21) |
1042 #'ignore)) | 1168 #'mh-face-display-function) |
1043 ((and (not mh-xemacs-flag) (>= emacs-major-version 21)) | |
1044 (load "x-face-e21" t t) | |
1045 (if (fboundp 'x-face-decode-message-header) | |
1046 #'x-face-decode-message-header | |
1047 #'ignore)) | |
1048 (t #'ignore)) | 1169 (t #'ignore)) |
1049 "Determine at run time what function should be called to display X-Face.") | 1170 "Determine at run time what function should be called to display X-Face.") |
1050 | 1171 |
1172 (defvar mh-uncompface-executable | |
1173 (and (fboundp 'executable-find) (executable-find "uncompface"))) | |
1174 | |
1175 (defun mh-face-to-png (data) | |
1176 "Convert base64 encoded DATA to png image." | |
1177 (with-temp-buffer | |
1178 (insert data) | |
1179 (ignore-errors (base64-decode-region (point-min) (point-max))) | |
1180 (buffer-string))) | |
1181 | |
1182 (defun mh-uncompface (data) | |
1183 "Run DATA through `uncompface' to generate bitmap." | |
1184 (with-temp-buffer | |
1185 (insert data) | |
1186 (when (and mh-uncompface-executable | |
1187 (equal (call-process-region (point-min) (point-max) | |
1188 mh-uncompface-executable t '(t nil)) | |
1189 0)) | |
1190 (mh-icontopbm) | |
1191 (buffer-string)))) | |
1192 | |
1193 (defun mh-icontopbm () | |
1194 "Elisp substitute for `icontopbm'." | |
1195 (goto-char (point-min)) | |
1196 (let ((end (point-max))) | |
1197 (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t) | |
1198 (save-excursion | |
1199 (goto-char (point-max)) | |
1200 (insert (string-to-number (match-string 1) 16)) | |
1201 (insert (string-to-number (match-string 2) 16)))) | |
1202 (delete-region (point-min) end) | |
1203 (goto-char (point-min)) | |
1204 (insert "P4\n48 48\n"))) | |
1205 | |
1206 (mh-do-in-xemacs (defvar default-enable-multibyte-characters)) | |
1207 | |
1208 (defmacro mh-face-foreground-compat (face &optional frame inherit) | |
1209 "Return the foreground color name of FACE, or nil if unspecified. | |
1210 See documentation for `face-foreground' for a description of the | |
1211 arguments FACE, FRAME, and INHERIT. | |
1212 | |
1213 Calls `face-foreground' correctly in older environments. Versions | |
1214 of Emacs prior to version 22 lacked an INHERIT argument which | |
1215 when t tells `face-foreground' to consider an inherited value for | |
1216 the foreground if the face does not define one itself." | |
1217 (if (>= emacs-major-version 22) | |
1218 `(face-foreground ,face ,frame ,inherit) | |
1219 `(face-foreground ,face ,frame))) | |
1220 | |
1221 (defmacro mh-face-background-compat (face &optional frame inherit) | |
1222 "Return the background color name of face, or nil if unspecified. | |
1223 See documentation for `back-foreground' for a description of the | |
1224 arguments FACE, FRAME, and INHERIT. | |
1225 | |
1226 Calls `face-background' correctly in older environments. Versions | |
1227 of Emacs prior to version 22 lacked an INHERIT argument which | |
1228 when t tells `face-background' to consider an inherited value for | |
1229 the background if the face does not define one itself." | |
1230 (if (>= emacs-major-version 22) | |
1231 `(face-background ,face ,frame ,inherit) | |
1232 `(face-background ,face ,frame))) | |
1233 | |
1234 (defun mh-face-display-function () | |
1235 "Display a Face, X-Face, or X-Image-URL header field. | |
1236 If more than one of these are present, then the first one found | |
1237 in this order is used." | |
1238 (save-restriction | |
1239 (goto-char (point-min)) | |
1240 (re-search-forward "\n\n" (point-max) t) | |
1241 (narrow-to-region (point-min) (point)) | |
1242 (let* ((case-fold-search t) | |
1243 (default-enable-multibyte-characters nil) | |
1244 (face (message-fetch-field "face" t)) | |
1245 (x-face (message-fetch-field "x-face" t)) | |
1246 (url (message-fetch-field "x-image-url" t)) | |
1247 raw type) | |
1248 (cond (face (setq raw (mh-face-to-png face) | |
1249 type 'png)) | |
1250 (x-face (setq raw (mh-uncompface x-face) | |
1251 type 'pbm)) | |
1252 (url (setq type 'url)) | |
1253 (t (multiple-value-setq (type raw) (mh-picon-get-image)))) | |
1254 (when type | |
1255 (goto-char (point-min)) | |
1256 (when (re-search-forward "^from:" (point-max) t) | |
1257 ;; GNU Emacs | |
1258 (mh-do-in-gnu-emacs | |
1259 (if (eq type 'url) | |
1260 (mh-x-image-url-display url) | |
1261 (mh-funcall-if-exists | |
1262 insert-image (create-image | |
1263 raw type t | |
1264 :foreground | |
1265 (mh-face-foreground-compat 'mh-show-xface nil t) | |
1266 :background | |
1267 (mh-face-background-compat 'mh-show-xface nil t)) | |
1268 " "))) | |
1269 ;; XEmacs | |
1270 (mh-do-in-xemacs | |
1271 (cond | |
1272 ((eq type 'url) | |
1273 (mh-x-image-url-display url)) | |
1274 ((eq type 'png) | |
1275 (when (featurep 'png) | |
1276 (set-extent-begin-glyph | |
1277 (make-extent (point) (point)) | |
1278 (make-glyph (vector 'png ':data (mh-face-to-png face)))))) | |
1279 ;; Try internal xface support if available... | |
1280 ((and (eq type 'pbm) (featurep 'xface)) | |
1281 (set-glyph-face | |
1282 (set-extent-begin-glyph | |
1283 (make-extent (point) (point)) | |
1284 (make-glyph (vector 'xface ':data (concat "X-Face: " x-face)))) | |
1285 'mh-show-xface)) | |
1286 ;; Otherwise try external support with x-face... | |
1287 ((and (eq type 'pbm) | |
1288 (fboundp 'x-face-xmas-wl-display-x-face) | |
1289 (fboundp 'executable-find) (executable-find "uncompface")) | |
1290 (mh-funcall-if-exists x-face-xmas-wl-display-x-face)) | |
1291 ;; Picon display | |
1292 ((and raw (member type '(xpm xbm gif))) | |
1293 (when (featurep type) | |
1294 (set-extent-begin-glyph | |
1295 (make-extent (point) (point)) | |
1296 (make-glyph (vector type ':data raw)))))) | |
1297 (when raw (insert " ")))))))) | |
1298 | |
1051 (defun mh-show-xface () | 1299 (defun mh-show-xface () |
1052 "Display X-Face." | 1300 "Display X-Face." |
1053 (when (and mh-show-use-xface-flag | 1301 (when (and window-system mh-show-use-xface-flag |
1054 (or mh-decode-mime-flag mhl-formfile | 1302 (or mh-decode-mime-flag mh-mhl-format-file |
1055 mh-clean-message-header-flag)) | 1303 mh-clean-message-header-flag)) |
1056 (funcall mh-show-xface-function))) | 1304 (funcall mh-show-xface-function))) |
1305 | |
1306 | |
1307 | |
1308 ;;; Picon display | |
1309 | |
1310 ;; XXX: This should be customizable. As a side-effect of setting this | |
1311 ;; variable, arrange to reset mh-picon-existing-directory-list to 'unset. | |
1312 (defvar mh-picon-directory-list | |
1313 '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news" | |
1314 "~/.picons/domains" "~/.picons/misc" | |
1315 "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix" | |
1316 "/usr/share/picons/news" "/usr/share/picons/domains" | |
1317 "/usr/share/picons/misc") | |
1318 "List of directories where picons reside. | |
1319 The directories are searched for in the order they appear in the list.") | |
1320 | |
1321 (defvar mh-picon-existing-directory-list 'unset | |
1322 "List of directories to search in.") | |
1323 | |
1324 (defvar mh-picon-cache (make-hash-table :test #'equal)) | |
1325 | |
1326 (defvar mh-picon-image-types | |
1327 (loop for type in '(xpm xbm gif) | |
1328 when (or (mh-do-in-gnu-emacs | |
1329 (ignore-errors | |
1330 (mh-funcall-if-exists image-type-available-p type))) | |
1331 (mh-do-in-xemacs (featurep type))) | |
1332 collect type)) | |
1333 | |
1334 (defun mh-picon-set-directory-list () | |
1335 "Update `mh-picon-existing-directory-list' if needed." | |
1336 (when (eq mh-picon-existing-directory-list 'unset) | |
1337 (setq mh-picon-existing-directory-list | |
1338 (loop for x in mh-picon-directory-list | |
1339 when (file-directory-p x) collect x)))) | |
1340 | |
1341 (defun* mh-picon-get-image () | |
1342 "Find the best possible match and return contents." | |
1343 (mh-picon-set-directory-list) | |
1344 (save-restriction | |
1345 (let* ((from-field (ignore-errors (car (message-tokenize-header | |
1346 (mh-get-header-field "from:"))))) | |
1347 (from (car (ignore-errors | |
1348 (mh-funcall-if-exists ietf-drums-parse-address | |
1349 from-field)))) | |
1350 (host (and from | |
1351 (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from) | |
1352 (downcase (match-string 3 from)))) | |
1353 (user (and host (downcase (match-string 1 from)))) | |
1354 (canonical-address (format "%s@%s" user host)) | |
1355 (cached-value (gethash canonical-address mh-picon-cache)) | |
1356 (host-list (and host (delete "" (split-string host "\\.")))) | |
1357 (match nil)) | |
1358 (cond (cached-value (return-from mh-picon-get-image cached-value)) | |
1359 ((not host-list) (return-from mh-picon-get-image nil))) | |
1360 (setq match | |
1361 (block 'loop | |
1362 ;; u@h search | |
1363 (loop for dir in mh-picon-existing-directory-list | |
1364 do (loop for type in mh-picon-image-types | |
1365 ;; [path]user@host | |
1366 for file1 = (format "%s/%s.%s" | |
1367 dir canonical-address type) | |
1368 when (file-exists-p file1) | |
1369 do (return-from 'loop file1) | |
1370 ;; [path]user | |
1371 for file2 = (format "%s/%s.%s" dir user type) | |
1372 when (file-exists-p file2) | |
1373 do (return-from 'loop file2) | |
1374 ;; [path]host | |
1375 for file3 = (format "%s/%s.%s" dir host type) | |
1376 when (file-exists-p file3) | |
1377 do (return-from 'loop file3))) | |
1378 ;; facedb search | |
1379 ;; Search order for user@foo.net: | |
1380 ;; [path]net/foo/user | |
1381 ;; [path]net/foo/user/face | |
1382 ;; [path]net/user | |
1383 ;; [path]net/user/face | |
1384 ;; [path]net/foo/unknown | |
1385 ;; [path]net/foo/unknown/face | |
1386 ;; [path]net/unknown | |
1387 ;; [path]net/unknown/face | |
1388 (loop for u in (list user "unknown") | |
1389 do (loop for dir in mh-picon-existing-directory-list | |
1390 do (loop for x on host-list by #'cdr | |
1391 for y = (mh-picon-generate-path x u dir) | |
1392 do (loop for type in mh-picon-image-types | |
1393 for z1 = (format "%s.%s" y type) | |
1394 when (file-exists-p z1) | |
1395 do (return-from 'loop z1) | |
1396 for z2 = (format "%s/face.%s" | |
1397 y type) | |
1398 when (file-exists-p z2) | |
1399 do (return-from 'loop z2))))))) | |
1400 (setf (gethash canonical-address mh-picon-cache) | |
1401 (mh-picon-file-contents match))))) | |
1402 | |
1403 (defun mh-picon-file-contents (file) | |
1404 "Return details about FILE. | |
1405 A list of consisting of a symbol for the type of the file and the | |
1406 file contents as a string is returned. If FILE is nil, then both | |
1407 elements of the list are nil." | |
1408 (if (stringp file) | |
1409 (with-temp-buffer | |
1410 (let ((type (and (string-match ".*\\.\\(...\\)$" file) | |
1411 (intern (match-string 1 file))))) | |
1412 (insert-file-contents-literally file) | |
1413 (values type (buffer-string)))) | |
1414 (values nil nil))) | |
1415 | |
1416 (defun mh-picon-generate-path (host-list user directory) | |
1417 "Generate the image file path. | |
1418 HOST-LIST is the parsed host address of the email address, USER | |
1419 the username and DIRECTORY is the directory relative to which the | |
1420 path is generated." | |
1421 (loop with acc = "" | |
1422 for elem in host-list | |
1423 do (setq acc (format "%s/%s" elem acc)) | |
1424 finally return (format "%s/%s%s" directory acc user))) | |
1425 | |
1426 | |
1427 | |
1428 ;; X-Image-URL display | |
1429 | |
1430 (defvar mh-x-image-cache-directory nil | |
1431 "Directory where X-Image-URL images are cached.") | |
1432 (defvar mh-x-image-scaling-function | |
1433 (cond ((executable-find "convert") | |
1434 'mh-x-image-scale-with-convert) | |
1435 ((and (executable-find "anytopnm") (executable-find "pnmscale") | |
1436 (executable-find "pnmtopng")) | |
1437 'mh-x-image-scale-with-pnm) | |
1438 (t 'ignore)) | |
1439 "Function to use to scale image to proper size.") | |
1440 (defvar mh-wget-executable nil) | |
1441 (defvar mh-wget-choice | |
1442 (or (and (setq mh-wget-executable (executable-find "wget")) 'wget) | |
1443 (and (setq mh-wget-executable (executable-find "fetch")) 'fetch) | |
1444 (and (setq mh-wget-executable (executable-find "curl")) 'curl))) | |
1445 (defvar mh-wget-option | |
1446 (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O"))))) | |
1447 (defvar mh-x-image-temp-file nil) | |
1448 (defvar mh-x-image-url nil) | |
1449 (defvar mh-x-image-marker nil) | |
1450 (defvar mh-x-image-url-cache-file nil) | |
1451 | |
1452 ;; Functions to scale image to proper size | |
1453 (defun mh-x-image-scale-with-pnm (input output) | |
1454 "Scale image in INPUT file and write to OUTPUT file using pnm tools." | |
1455 (let ((res (shell-command-to-string | |
1456 (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s" | |
1457 input output)))) | |
1458 (unless (equal res "") | |
1459 (delete-file output)))) | |
1460 | |
1461 (defun mh-x-image-scale-with-convert (input output) | |
1462 "Scale image in INPUT file and write to OUTPUT file using ImageMagick." | |
1463 (call-process "convert" nil nil nil "-geometry" "96x48" input output)) | |
1464 | |
1465 ;; Copy of constant from url-util.el in Emacs 22; needed by Emacs 21. | |
1466 (if (not (boundp 'url-unreserved-chars)) | |
1467 (defconst url-unreserved-chars | |
1468 '( | |
1469 ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z | |
1470 ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z | |
1471 ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 | |
1472 ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\)) | |
1473 "A list of characters that are _NOT_ reserved in the URL spec. | |
1474 This is taken from RFC 2396.")) | |
1475 | |
1476 ;; Copy of function from url-util.el in Emacs 22; needed by Emacs 21. | |
1477 (mh-defun-compat url-hexify-string (str) | |
1478 "Escape characters in a string." | |
1479 (mapconcat | |
1480 (lambda (char) | |
1481 ;; Fixme: use a char table instead. | |
1482 (if (not (memq char url-unreserved-chars)) | |
1483 (if (> char 255) | |
1484 (error "Hexifying multibyte character %s" str) | |
1485 (format "%%%02X" char)) | |
1486 (char-to-string char))) | |
1487 str "")) | |
1488 | |
1489 (defun mh-x-image-url-cache-canonicalize (url) | |
1490 "Canonicalize URL. | |
1491 Replace the ?/ character with a ?! character and append .png. | |
1492 Also replaces special characters with `url-hexify-string' since | |
1493 not all characters, such as :, are legal within Windows | |
1494 filenames. See URL `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp'." | |
1495 (format "%s/%s.png" mh-x-image-cache-directory | |
1496 (url-hexify-string | |
1497 (with-temp-buffer | |
1498 (insert url) | |
1499 (mh-replace-string "/" "!") | |
1500 (buffer-string))))) | |
1501 | |
1502 (defun mh-x-image-set-download-state (file data) | |
1503 "Setup a symbolic link from FILE to DATA." | |
1504 (if data | |
1505 (make-symbolic-link (symbol-name data) file t) | |
1506 (delete-file file))) | |
1507 | |
1508 (defun mh-x-image-get-download-state (file) | |
1509 "Check the state of FILE by following any symbolic links." | |
1510 (unless (file-exists-p mh-x-image-cache-directory) | |
1511 (call-process "mkdir" nil nil nil mh-x-image-cache-directory)) | |
1512 (cond ((file-symlink-p file) | |
1513 (intern (file-name-nondirectory (file-chase-links file)))) | |
1514 ((not (file-exists-p file)) nil) | |
1515 (t 'ok))) | |
1516 | |
1517 (defun mh-x-image-url-fetch-image (url cache-file marker sentinel) | |
1518 "Fetch and display the image specified by URL. | |
1519 After the image is fetched, it is stored in CACHE-FILE. It will | |
1520 be displayed in a buffer and position specified by MARKER. The | |
1521 actual display is carried out by the SENTINEL function." | |
1522 (if mh-wget-executable | |
1523 (let ((buffer (get-buffer-create (generate-new-buffer-name | |
1524 mh-temp-fetch-buffer))) | |
1525 (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch") | |
1526 (expand-file-name (make-temp-name "~/mhe-fetch"))))) | |
1527 (save-excursion | |
1528 (set-buffer buffer) | |
1529 (set (make-local-variable 'mh-x-image-url-cache-file) cache-file) | |
1530 (set (make-local-variable 'mh-x-image-marker) marker) | |
1531 (set (make-local-variable 'mh-x-image-temp-file) filename)) | |
1532 (set-process-sentinel | |
1533 (start-process "*mh-x-image-url-fetch*" buffer | |
1534 mh-wget-executable mh-wget-option filename url) | |
1535 sentinel)) | |
1536 ;; Temporary failure | |
1537 (mh-x-image-set-download-state cache-file 'try-again))) | |
1538 | |
1539 (defun mh-x-image-display (image marker) | |
1540 "Display IMAGE at MARKER." | |
1541 (save-excursion | |
1542 (set-buffer (marker-buffer marker)) | |
1543 (let ((buffer-read-only nil) | |
1544 (default-enable-multibyte-characters nil) | |
1545 (buffer-modified-flag (buffer-modified-p))) | |
1546 (unwind-protect | |
1547 (when (and (file-readable-p image) (not (file-symlink-p image)) | |
1548 (eq marker mh-x-image-marker)) | |
1549 (goto-char marker) | |
1550 (mh-do-in-gnu-emacs | |
1551 (mh-funcall-if-exists insert-image (create-image image 'png))) | |
1552 (mh-do-in-xemacs | |
1553 (when (featurep 'png) | |
1554 (set-extent-begin-glyph | |
1555 (make-extent (point) (point)) | |
1556 (make-glyph | |
1557 (vector 'png ':data (with-temp-buffer | |
1558 (insert-file-contents-literally image) | |
1559 (buffer-string)))))))) | |
1560 (set-buffer-modified-p buffer-modified-flag))))) | |
1561 | |
1562 (defun mh-x-image-scale-and-display (process change) | |
1563 "When the wget PROCESS terminates scale and display image. | |
1564 The argument CHANGE is ignored." | |
1565 (when (eq (process-status process) 'exit) | |
1566 (let (marker temp-file cache-filename wget-buffer) | |
1567 (save-excursion | |
1568 (set-buffer (setq wget-buffer (process-buffer process))) | |
1569 (setq marker mh-x-image-marker | |
1570 cache-filename mh-x-image-url-cache-file | |
1571 temp-file mh-x-image-temp-file)) | |
1572 (cond | |
1573 ;; Check if we have `convert' | |
1574 ((eq mh-x-image-scaling-function 'ignore) | |
1575 (message "The \"convert\" program is needed to display X-Image-URL") | |
1576 (mh-x-image-set-download-state cache-filename 'try-again)) | |
1577 ;; Scale fetched image | |
1578 ((and (funcall mh-x-image-scaling-function temp-file cache-filename) | |
1579 nil)) | |
1580 ;; Attempt to display image if we have it | |
1581 ((file-exists-p cache-filename) | |
1582 (mh-x-image-display cache-filename marker)) | |
1583 ;; We didn't find the image. Should we try to display it the next time? | |
1584 (t (mh-x-image-set-download-state cache-filename 'try-again))) | |
1585 (ignore-errors | |
1586 (set-marker marker nil) | |
1587 (delete-process process) | |
1588 (kill-buffer wget-buffer) | |
1589 (delete-file temp-file))))) | |
1590 | |
1591 (defun mh-x-image-url-sane-p (url) | |
1592 "Check if URL is something sensible." | |
1593 (let ((len (length url))) | |
1594 (cond ((< len 5) nil) | |
1595 ((not (equal (substring url 0 5) "http:")) nil) | |
1596 ((> len 100) nil) | |
1597 (t t)))) | |
1598 | |
1599 (defun mh-x-image-url-display (url) | |
1600 "Display image from location URL. | |
1601 If the URL isn't present in the cache then it is fetched with wget." | |
1602 (let* ((cache-filename (mh-x-image-url-cache-canonicalize url)) | |
1603 (state (mh-x-image-get-download-state cache-filename)) | |
1604 (marker (set-marker (make-marker) (point)))) | |
1605 (set (make-local-variable 'mh-x-image-marker) marker) | |
1606 (cond ((not (mh-x-image-url-sane-p url))) | |
1607 ((eq state 'ok) | |
1608 (mh-x-image-display cache-filename marker)) | |
1609 ((or (not mh-wget-executable) | |
1610 (eq mh-x-image-scaling-function 'ignore))) | |
1611 ((eq state 'never)) | |
1612 ((not mh-fetch-x-image-url) | |
1613 (set-marker marker nil)) | |
1614 ((eq state 'try-again) | |
1615 (mh-x-image-set-download-state cache-filename nil) | |
1616 (mh-x-image-url-fetch-image url cache-filename marker | |
1617 'mh-x-image-scale-and-display)) | |
1618 ((and (eq mh-fetch-x-image-url 'ask) | |
1619 (not (y-or-n-p (format "Fetch %s? " url)))) | |
1620 (mh-x-image-set-download-state cache-filename 'never)) | |
1621 ((eq state nil) | |
1622 (mh-x-image-url-fetch-image url cache-filename marker | |
1623 'mh-x-image-scale-and-display))))) | |
1624 | |
1625 | |
1057 | 1626 |
1058 (defun mh-maybe-show (&optional msg) | 1627 (defun mh-maybe-show (&optional msg) |
1059 "Display message at cursor, but only if in show mode. | 1628 "Display message at cursor, but only if in show mode. |
1060 If optional arg MSG is non-nil, display that message instead." | 1629 If optional arg MSG is non-nil, display that message instead." |
1061 (if mh-showing-mode (mh-show msg))) | 1630 (if mh-showing-mode (mh-show msg))) |
1062 | 1631 |
1063 (defun mh-show (&optional message) | 1632 (defun mh-show (&optional message redisplay-flag) |
1064 "Show message at cursor. | 1633 "Display message\\<mh-folder-mode-map>. |
1065 If optional argument MESSAGE is non-nil, display that message instead. | 1634 |
1066 Force a two-window display with the folder window on top (size | 1635 If the message under the cursor is already displayed, this command |
1067 `mh-summary-height') and the show buffer below it. | 1636 scrolls to the beginning of the message. MH-E normally hides a lot of |
1068 If the message is already visible, display the start of the message. | 1637 the superfluous header fields that mailers add to a message, but if |
1069 | 1638 you wish to see all of them, use the command \\[mh-header-display]. |
1070 Display of the message is controlled by setting the variables | 1639 |
1071 `mh-clean-message-header-flag' and `mhl-formfile'. The default behavior is | 1640 Two hooks can be used to control how messages are displayed. The |
1072 to scroll uninteresting headers off the top of the window. | 1641 first hook, `mh-show-mode-hook', is called early on in the |
1073 Type \"\\[mh-header-display]\" to see the message with all its headers." | 1642 process of the message display. It is usually used to perform |
1074 (interactive) | 1643 some action on the message's content. The second hook, |
1075 (and mh-showing-with-headers | 1644 `mh-show-hook', is the last thing called after messages are |
1076 (or mhl-formfile mh-clean-message-header-flag) | 1645 displayed. It's used to affect the behavior of MH-E in general or |
1077 (mh-invalidate-show-buffer)) | 1646 when `mh-show-mode-hook' is too early. |
1647 | |
1648 From a program, optional argument MESSAGE can be used to display an | |
1649 alternative message. The optional argument REDISPLAY-FLAG forces the | |
1650 redisplay of the message even if the show buffer was already | |
1651 displaying the correct message. | |
1652 | |
1653 See the \"mh-show\" customization group for a litany of options that | |
1654 control what displayed messages look like." | |
1655 (interactive (list nil t)) | |
1656 (when (or redisplay-flag | |
1657 (and mh-showing-with-headers | |
1658 (or mh-mhl-format-file mh-clean-message-header-flag))) | |
1659 (mh-invalidate-show-buffer)) | |
1078 (mh-show-msg message)) | 1660 (mh-show-msg message)) |
1079 | 1661 |
1080 (defun mh-show-mouse (EVENT) | 1662 (defun mh-show-mouse (event) |
1081 "Move point to mouse EVENT and show message." | 1663 "Move point to mouse EVENT and show message." |
1082 (interactive "e") | 1664 (interactive "e") |
1083 (mouse-set-point EVENT) | 1665 (mouse-set-point event) |
1084 (mh-show)) | 1666 (mh-show)) |
1667 | |
1668 (defun mh-summary-height () | |
1669 "Return ideal value for the variable `mh-summary-height'. | |
1670 The current frame height is taken into consideration." | |
1671 (or (and (fboundp 'frame-height) | |
1672 (> (frame-height) 24) | |
1673 (min 10 (/ (frame-height) 6))) | |
1674 4)) | |
1085 | 1675 |
1086 (defun mh-show-msg (msg) | 1676 (defun mh-show-msg (msg) |
1087 "Show MSG. | 1677 "Show MSG. |
1088 The value of `mh-show-hook' is a list of functions to be called, with no | 1678 |
1089 arguments, after the message has been displayed." | 1679 The hook `mh-show-hook' is called after the message has been |
1680 displayed." | |
1090 (if (not msg) | 1681 (if (not msg) |
1091 (setq msg (mh-get-msg-num t))) | 1682 (setq msg (mh-get-msg-num t))) |
1092 (mh-showing-mode t) | 1683 (mh-showing-mode t) |
1093 (setq mh-page-to-next-msg-flag nil) | 1684 (setq mh-page-to-next-msg-flag nil) |
1094 (let ((folder mh-current-folder) | 1685 (let ((folder mh-current-folder) |
1686 (folders (list mh-current-folder)) | |
1095 (clean-message-header mh-clean-message-header-flag) | 1687 (clean-message-header mh-clean-message-header-flag) |
1096 (show-window (get-buffer-window mh-show-buffer))) | 1688 (show-window (get-buffer-window mh-show-buffer)) |
1689 (display-mime-buttons-flag mh-display-buttons-for-inline-parts-flag)) | |
1097 (if (not (eq (next-window (minibuffer-window)) (selected-window))) | 1690 (if (not (eq (next-window (minibuffer-window)) (selected-window))) |
1098 (delete-other-windows)) ; force ourself to the top window | 1691 (delete-other-windows)) ; force ourself to the top window |
1099 (mh-in-show-buffer (mh-show-buffer) | 1692 (mh-in-show-buffer (mh-show-buffer) |
1693 (setq mh-display-buttons-for-inline-parts-flag display-mime-buttons-flag) | |
1100 (if (and show-window | 1694 (if (and show-window |
1101 (equal (mh-msg-filename msg folder) buffer-file-name)) | 1695 (equal (mh-msg-filename msg folder) buffer-file-name)) |
1102 (progn ;just back up to start | 1696 (progn ;just back up to start |
1103 (goto-char (point-min)) | 1697 (goto-char (point-min)) |
1104 (if (not clean-message-header) | 1698 (if (not clean-message-header) |
1105 (mh-start-of-uncleaned-message))) | 1699 (mh-start-of-uncleaned-message))) |
1106 (mh-display-msg msg folder)))) | 1700 (mh-display-msg msg folder))) |
1107 (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split | 1701 (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split |
1108 (shrink-window (- (window-height) mh-summary-height))) | 1702 (shrink-window (- (window-height) (or mh-summary-height |
1109 (mh-recenter nil) | 1703 (mh-summary-height))))) |
1110 (if (not (memq msg mh-seen-list)) | 1704 (mh-recenter nil) |
1111 (setq mh-seen-list (cons msg mh-seen-list))) | 1705 ;; The following line is a nop which forces update of the scan line so |
1112 (when mh-update-sequences-after-mh-show-flag | 1706 ;; that font-lock will update it (if needed)... |
1113 (mh-update-sequences)) | 1707 (mh-notate nil nil mh-cmd-note) |
1114 (run-hooks 'mh-show-hook)) | 1708 (if (not (memq msg mh-seen-list)) |
1709 (setq mh-seen-list (cons msg mh-seen-list))) | |
1710 (when mh-update-sequences-after-mh-show-flag | |
1711 (mh-update-sequences) | |
1712 (when mh-index-data | |
1713 (setq folders | |
1714 (append (mh-index-delete-from-sequence mh-unseen-seq (list msg)) | |
1715 folders))) | |
1716 (when (mh-speed-flists-active-p) | |
1717 (apply #'mh-speed-flists t folders))) | |
1718 (run-hooks 'mh-show-hook))) | |
1115 | 1719 |
1116 (defun mh-modify (&optional message) | 1720 (defun mh-modify (&optional message) |
1117 "Edit message at cursor. | 1721 "Edit message. |
1118 If optional argument MESSAGE is non-nil, edit that message instead. | 1722 |
1119 Force a two-window display with the folder window on top (size | 1723 There are times when you need to edit a message. For example, you |
1120 `mh-summary-height') and the message editing buffer below it. | 1724 may need to fix a broken Content-Type header field. You can do |
1121 | 1725 this with this command. It displays the raw message in an |
1122 The message is displayed in raw form." | 1726 editable buffer. When you are done editing, save and kill the |
1727 buffer as you would any other. | |
1728 | |
1729 From a program, edit MESSAGE; nil means edit current message." | |
1123 (interactive) | 1730 (interactive) |
1124 (let* ((message (or message (mh-get-msg-num t))) | 1731 (let* ((message (or message (mh-get-msg-num t))) |
1125 (msg-filename (mh-msg-filename message)) | 1732 (msg-filename (mh-msg-filename message)) |
1126 edit-buffer) | 1733 edit-buffer) |
1127 (when (not (file-exists-p msg-filename)) | 1734 (when (not (file-exists-p msg-filename)) |
1145 | 1752 |
1146 ;; Just show the edit buffer... | 1753 ;; Just show the edit buffer... |
1147 (delete-other-windows) | 1754 (delete-other-windows) |
1148 (switch-to-buffer edit-buffer))) | 1755 (switch-to-buffer edit-buffer))) |
1149 | 1756 |
1150 (defun mh-decode-content-transfer-encoded-message () | |
1151 "Run mimencode on message body, if needed." | |
1152 (let ((case-fold-search t) | |
1153 (header-end (mail-header-end))) | |
1154 (goto-char (point-min)) | |
1155 (when (re-search-forward "^content-transfer-encoding: " header-end t) | |
1156 (let ((enc (buffer-substring-no-properties (point) (line-end-position))) | |
1157 cmdline) | |
1158 (setq cmdline | |
1159 (cond ((string-match "base64" enc) (list "-u" "-b" "-p")) | |
1160 ((string-match "quoted-printable" enc) (list "-u" "-q")) | |
1161 (t nil))) | |
1162 (when cmdline | |
1163 (beginning-of-line) | |
1164 (insert "Removed-") | |
1165 (setq header-end (mail-header-end)) | |
1166 (goto-char (1+ header-end)) | |
1167 (apply #'call-process-region (1+ header-end) (point-max) "mimencode" | |
1168 t t nil cmdline)))))) | |
1169 | |
1170 (defun mh-show-unquote-From () | 1757 (defun mh-show-unquote-From () |
1171 "Decode >From at beginning of lines for `mh-show-mode'." | 1758 "Decode >From at beginning of lines for `mh-show-mode'." |
1172 (save-excursion | 1759 (save-excursion |
1173 (let ((modified (buffer-modified-p)) | 1760 (let ((modified (buffer-modified-p)) |
1174 (case-fold-search nil)) | 1761 (case-fold-search nil) |
1175 (goto-char (mail-header-end)) | 1762 (buffer-read-only nil)) |
1763 (goto-char (mh-mail-header-end)) | |
1176 (while (re-search-forward "^>From" nil t) | 1764 (while (re-search-forward "^>From" nil t) |
1177 (replace-match "From")) | 1765 (replace-match "From")) |
1178 (set-buffer-modified-p modified)))) | 1766 (set-buffer-modified-p modified)))) |
1179 | 1767 |
1180 (defun mh-msg-folder (folder-name) | 1768 (defun mh-msg-folder (folder-name) |
1191 ;; would be nicer if there are weak pointers in emacs lisp, then we could | 1779 ;; would be nicer if there are weak pointers in emacs lisp, then we could |
1192 ;; get the garbage collector to do this for us. | 1780 ;; get the garbage collector to do this for us. |
1193 (unless (mh-buffer-data) | 1781 (unless (mh-buffer-data) |
1194 (setf (mh-buffer-data) (mh-make-buffer-data))) | 1782 (setf (mh-buffer-data) (mh-make-buffer-data))) |
1195 ;; Bind variables in folder buffer in case they are local | 1783 ;; Bind variables in folder buffer in case they are local |
1196 (let ((formfile mhl-formfile) | 1784 (let ((formfile mh-mhl-format-file) |
1197 (clean-message-header mh-clean-message-header-flag) | 1785 (clean-message-header mh-clean-message-header-flag) |
1198 (invisible-headers mh-invisible-headers) | 1786 (invisible-headers mh-invisible-header-fields-compiled) |
1199 (visible-headers mh-visible-headers) | 1787 (visible-headers nil) |
1200 (msg-filename (mh-msg-filename msg-num folder-name)) | 1788 (msg-filename (mh-msg-filename msg-num folder-name)) |
1201 (show-buffer mh-show-buffer) | 1789 (show-buffer mh-show-buffer) |
1202 (mm-inline-media-tests mh-mm-inline-media-tests)) | 1790 (mm-inline-media-tests mh-mm-inline-media-tests)) |
1203 (if (not (file-exists-p msg-filename)) | 1791 (if (not (file-exists-p msg-filename)) |
1204 (error "Message %d does not exist" msg-num)) | 1792 (error "Message %d does not exist" msg-num)) |
1213 (error "Message %d not displayed" msg-num)) | 1801 (error "Message %d not displayed" msg-num)) |
1214 (set-buffer show-buffer) | 1802 (set-buffer show-buffer) |
1215 (cond ((not (equal msg-filename buffer-file-name)) | 1803 (cond ((not (equal msg-filename buffer-file-name)) |
1216 (mh-unvisit-file) | 1804 (mh-unvisit-file) |
1217 (setq buffer-read-only nil) | 1805 (setq buffer-read-only nil) |
1806 ;; Cleanup old mime handles | |
1807 (mh-mime-cleanup) | |
1218 (erase-buffer) | 1808 (erase-buffer) |
1219 ;; Changing contents, so this hook needs to be reinitialized. | 1809 ;; Changing contents, so this hook needs to be reinitialized. |
1220 ;; pgp.el uses this. | 1810 ;; pgp.el uses this. |
1221 (if (boundp 'write-contents-hooks) ;Emacs 19 | 1811 (if (boundp 'write-contents-hooks) ;Emacs 19 |
1222 (kill-local-variable 'write-contents-hooks)) | 1812 (kill-local-variable 'write-contents-hooks)) |
1224 (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" | 1814 (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" |
1225 (if (stringp formfile) | 1815 (if (stringp formfile) |
1226 (list "-form" formfile)) | 1816 (list "-form" formfile)) |
1227 msg-filename) | 1817 msg-filename) |
1228 (insert-file-contents-literally msg-filename)) | 1818 (insert-file-contents-literally msg-filename)) |
1229 (if mh-decode-content-transfer-encoded-message-flag | |
1230 (mh-decode-content-transfer-encoded-message)) | |
1231 ;; Cleanup old mime handles | |
1232 (mh-mime-cleanup) | |
1233 ;; Use mm to display buffer | 1819 ;; Use mm to display buffer |
1234 (when (and mh-decode-mime-flag (not formfile)) | 1820 (when (and mh-decode-mime-flag (not formfile)) |
1235 (mh-add-missing-mime-version-header) | 1821 (mh-add-missing-mime-version-header) |
1236 (setf (mh-buffer-data) (mh-make-buffer-data)) | 1822 (setf (mh-buffer-data) (mh-make-buffer-data)) |
1237 (mh-mime-display)) | 1823 (mh-mime-display)) |
1824 (mh-show-mode) | |
1238 ;; Header cleanup | 1825 ;; Header cleanup |
1239 (goto-char (point-min)) | 1826 (goto-char (point-min)) |
1240 (cond (clean-message-header | 1827 (cond (clean-message-header |
1241 (mh-clean-msg-header (point-min) | 1828 (mh-clean-msg-header (point-min) |
1242 invisible-headers | 1829 invisible-headers |
1243 visible-headers) | 1830 visible-headers) |
1244 (goto-char (point-min))) | 1831 (goto-char (point-min))) |
1245 (t | 1832 (t |
1246 (mh-start-of-uncleaned-message))) | 1833 (mh-start-of-uncleaned-message))) |
1834 (mh-decode-message-header) | |
1247 ;; the parts of visiting we want to do (no locking) | 1835 ;; the parts of visiting we want to do (no locking) |
1248 (or (eq buffer-undo-list t) ;don't save undo info for prev msgs | 1836 (or (eq buffer-undo-list t) ;don't save undo info for prev msgs |
1249 (setq buffer-undo-list nil)) | 1837 (setq buffer-undo-list nil)) |
1250 (set-buffer-auto-saved) | 1838 (set-buffer-auto-saved) |
1251 ;; the parts of set-visited-file-name we want to do (no locking) | 1839 ;; the parts of set-visited-file-name we want to do (no locking) |
1252 (setq buffer-file-name msg-filename) | 1840 (setq buffer-file-name msg-filename) |
1253 (setq buffer-backed-up nil) | 1841 (setq buffer-backed-up nil) |
1254 (auto-save-mode 1) | 1842 (auto-save-mode 1) |
1255 (set-mark nil) | 1843 (set-mark nil) |
1256 (mh-show-mode) | |
1257 (unwind-protect | 1844 (unwind-protect |
1258 (when (and mh-decode-mime-flag (not formfile)) | 1845 (when (and mh-decode-mime-flag (not formfile)) |
1259 (setq buffer-read-only nil) | 1846 (setq buffer-read-only nil) |
1260 (mh-display-smileys) | 1847 (mh-display-smileys) |
1261 (mh-display-emphasis)) | 1848 (mh-display-emphasis)) |
1269 (set-buffer folder) | 1856 (set-buffer folder) |
1270 (setq mh-showing-with-headers nil)))))) | 1857 (setq mh-showing-with-headers nil)))))) |
1271 | 1858 |
1272 (defun mh-clean-msg-header (start invisible-headers visible-headers) | 1859 (defun mh-clean-msg-header (start invisible-headers visible-headers) |
1273 "Flush extraneous lines in message header. | 1860 "Flush extraneous lines in message header. |
1861 | |
1274 Header is cleaned from START to the end of the message header. | 1862 Header is cleaned from START to the end of the message header. |
1275 INVISIBLE-HEADERS contains a regular expression specifying lines to delete | 1863 INVISIBLE-HEADERS contains a regular expression specifying lines |
1276 from the header. VISIBLE-HEADERS contains a regular expression specifying the | 1864 to delete from the header. VISIBLE-HEADERS contains a regular |
1277 lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil." | 1865 expression specifying the lines to display. INVISIBLE-HEADERS is |
1866 ignored if VISIBLE-HEADERS is non-nil." | |
1867 ;; XXX Note that MH-E no longer supports the `mh-visible-headers' | |
1868 ;; variable, so this function could be trimmed of this feature too." | |
1278 (let ((case-fold-search t) | 1869 (let ((case-fold-search t) |
1279 (after-change-functions nil)) ;Work around emacs-20 font-lock bug | 1870 (buffer-read-only nil)) |
1280 ;causing an endless loop. | |
1281 (save-restriction | 1871 (save-restriction |
1282 (goto-char start) | 1872 (goto-char start) |
1283 (if (search-forward "\n\n" nil 'move) | 1873 (if (search-forward "\n\n" nil 'move) |
1284 (backward-char 1)) | 1874 (backward-char 1)) |
1285 (narrow-to-region start (point)) | 1875 (narrow-to-region start (point)) |
1295 (mh-delete-line 1))))) | 1885 (mh-delete-line 1))))) |
1296 (while (re-search-forward invisible-headers nil t) | 1886 (while (re-search-forward invisible-headers nil t) |
1297 (beginning-of-line) | 1887 (beginning-of-line) |
1298 (mh-delete-line 1) | 1888 (mh-delete-line 1) |
1299 (while (looking-at "[ \t]") | 1889 (while (looking-at "[ \t]") |
1300 (mh-delete-line 1)))) | 1890 (mh-delete-line 1))))) |
1301 (unlock-buffer)))) | 1891 (let ((mh-compose-skipped-header-fields ())) |
1892 (mh-letter-hide-all-skipped-fields)) | |
1893 (unlock-buffer))) | |
1302 | 1894 |
1303 (defun mh-delete-line (lines) | 1895 (defun mh-delete-line (lines) |
1304 "Delete the next LINES lines." | 1896 "Delete the next LINES lines." |
1305 (delete-region (point) (progn (forward-line lines) (point)))) | 1897 (delete-region (point) (progn (forward-line lines) (point)))) |
1306 | 1898 |
1307 (defun mh-notate (msg notation offset) | 1899 (defun mh-notate (msg notation offset) |
1308 "Mark MSG with the character NOTATION at position OFFSET. | 1900 "Mark MSG with the character NOTATION at position OFFSET. |
1309 Null MSG means the message at cursor." | 1901 Null MSG means the message at cursor. |
1902 If NOTATION is nil then no change in the buffer occurs." | |
1310 (save-excursion | 1903 (save-excursion |
1311 (if (or (null msg) | 1904 (if (or (null msg) |
1312 (mh-goto-msg msg t t)) | 1905 (mh-goto-msg msg t t)) |
1313 (with-mh-folder-updating (t) | 1906 (with-mh-folder-updating (t) |
1314 (beginning-of-line) | 1907 (beginning-of-line) |
1315 (forward-char offset) | 1908 (forward-char offset) |
1316 (delete-char 1) | 1909 (let* ((change-stack-flag |
1317 (insert notation))))) | 1910 (and (equal offset |
1318 | 1911 (+ mh-cmd-note mh-scan-field-destination-offset)) |
1319 (defun mh-find-msg-get-num (step) | 1912 (not (eq notation mh-note-seq)))) |
1320 "Return the message number of the message nearest the cursor. | 1913 (msg (and change-stack-flag (or msg (mh-get-msg-num nil)))) |
1321 Jumps over non-message lines, such as inc errors. | 1914 (stack (and msg (gethash msg mh-sequence-notation-history))) |
1322 If we have to search, STEP tells whether to search forward or backward." | 1915 (notation (or notation (char-after)))) |
1323 (or (mh-get-msg-num nil) | 1916 (if stack |
1324 (let ((msg-num nil) | 1917 ;; The presence of the stack tells us that we don't need to |
1325 (nreverses 0)) | 1918 ;; notate the message, since the notation would be replaced |
1326 (while (and (not msg-num) | 1919 ;; by a sequence notation. So we will just put the notation |
1327 (< nreverses 2)) | 1920 ;; at the bottom of the stack. If the sequence is deleted, |
1328 (cond ((eobp) | 1921 ;; the correct notation will be shown. |
1329 (setq step -1) | 1922 (setf (gethash msg mh-sequence-notation-history) |
1330 (setq nreverses (1+ nreverses))) | 1923 (reverse (cons notation (cdr (reverse stack))))) |
1331 ((bobp) | 1924 ;; Since we don't have any sequence notations in the way, just |
1332 (setq step 1) | 1925 ;; notate the scan line. |
1333 (setq nreverses (1+ nreverses)))) | 1926 (delete-char 1) |
1334 (forward-line step) | 1927 (insert notation)) |
1335 (setq msg-num (mh-get-msg-num nil))) | 1928 (when change-stack-flag |
1336 msg-num))) | 1929 (mh-thread-update-scan-line-map msg notation offset))))))) |
1337 | 1930 |
1338 (defun mh-goto-msg (number &optional no-error-if-no-message dont-show) | 1931 (defun mh-goto-msg (number &optional no-error-if-no-message dont-show) |
1339 "Position the cursor at message NUMBER. | 1932 "Go to a message\\<mh-folder-mode-map>. |
1340 Optional non-nil second argument NO-ERROR-IF-NO-MESSAGE means return nil | 1933 |
1341 instead of signaling an error if message does not exist; in this case, the | 1934 You can enter the message NUMBER either before or after typing |
1342 cursor is positioned near where the message would have been. | 1935 \\[mh-goto-msg]. In the latter case, Emacs prompts you. |
1343 Non-nil third argument DONT-SHOW means not to show the message." | 1936 |
1937 In a program, optional non-nil second argument NO-ERROR-IF-NO-MESSAGE | |
1938 means return nil instead of signaling an error if message does not | |
1939 exist\; in this case, the cursor is positioned near where the message | |
1940 would have been. Non-nil third argument DONT-SHOW means not to show | |
1941 the message." | |
1344 (interactive "NGo to message: ") | 1942 (interactive "NGo to message: ") |
1345 (setq number (prefix-numeric-value number)) | 1943 (setq number (prefix-numeric-value number)) |
1346 (let ((point (point)) | 1944 (let ((point (point)) |
1347 (return-value t)) | 1945 (return-value t)) |
1348 (goto-char (point-min)) | 1946 (goto-char (point-min)) |
1349 (unless (re-search-forward (format "^[ ]*%s[^0-9]+" number) nil t) | 1947 (unless (re-search-forward (format mh-scan-msg-search-regexp number) nil t) |
1350 (goto-char point) | 1948 (goto-char point) |
1351 (unless no-error-if-no-message | 1949 (unless no-error-if-no-message |
1352 (error "No message %d" number)) | 1950 (error "No message %d" number)) |
1353 (setq return-value nil)) | 1951 (setq return-value nil)) |
1354 (beginning-of-line) | 1952 (beginning-of-line) |
1355 (or dont-show (not return-value) (mh-maybe-show number)) | 1953 (or dont-show (not return-value) (mh-maybe-show number)) |
1356 return-value)) | 1954 return-value)) |
1357 | 1955 |
1358 (defun mh-msg-search-pat (n) | |
1359 "Return a search pattern for message N in the scan listing." | |
1360 (format mh-scan-msg-search-regexp n)) | |
1361 | |
1362 (defun mh-get-profile-field (field) | |
1363 "Find and return the value of FIELD in the current buffer. | |
1364 Returns nil if the field is not in the buffer." | |
1365 (let ((case-fold-search t)) | |
1366 (goto-char (point-min)) | |
1367 (cond ((not (re-search-forward (format "^%s" field) nil t)) nil) | |
1368 ((looking-at "[\t ]*$") nil) | |
1369 (t | |
1370 (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t) | |
1371 (let ((start (match-beginning 1))) | |
1372 (end-of-line) | |
1373 (buffer-substring start (point))))))) | |
1374 | |
1375 (defvar mail-user-agent) | |
1376 (defvar read-mail-command) | |
1377 | |
1378 (defvar mh-find-path-run nil | |
1379 "Non-nil if `mh-find-path' has been run already.") | |
1380 | |
1381 (defun mh-find-path () | |
1382 "Set `mh-progs', `mh-lib', and `mh-lib-progs' variables. | |
1383 Set `mh-user-path', `mh-draft-folder', `mh-unseen-seq', `mh-previous-seq', | |
1384 `mh-inbox' from user's MH profile. | |
1385 The value of `mh-find-path-hook' is a list of functions to be called, with no | |
1386 arguments, after these variable have been set." | |
1387 (mh-find-progs) | |
1388 (unless mh-find-path-run | |
1389 (setq mh-find-path-run t) | |
1390 (setq read-mail-command 'mh-rmail) | |
1391 (setq mail-user-agent 'mh-e-user-agent)) | |
1392 (save-excursion | |
1393 ;; Be sure profile is fully expanded before switching buffers | |
1394 (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile")))) | |
1395 (set-buffer (get-buffer-create mh-temp-buffer)) | |
1396 (setq buffer-offer-save nil) ;for people who set default to t | |
1397 (erase-buffer) | |
1398 (condition-case err | |
1399 (insert-file-contents profile) | |
1400 (file-error | |
1401 (mh-install profile err))) | |
1402 (setq mh-user-path (mh-get-profile-field "Path:")) | |
1403 (if (not mh-user-path) | |
1404 (setq mh-user-path "Mail")) | |
1405 (setq mh-user-path | |
1406 (file-name-as-directory | |
1407 (expand-file-name mh-user-path (expand-file-name "~")))) | |
1408 (setq mh-draft-folder (mh-get-profile-field "Draft-Folder:")) | |
1409 (if mh-draft-folder | |
1410 (progn | |
1411 (if (not (mh-folder-name-p mh-draft-folder)) | |
1412 (setq mh-draft-folder (format "+%s" mh-draft-folder))) | |
1413 (if (not (file-exists-p (mh-expand-file-name mh-draft-folder))) | |
1414 (error "Draft folder \"%s\" not found. Create it and try again" | |
1415 (mh-expand-file-name mh-draft-folder))))) | |
1416 (setq mh-inbox (mh-get-profile-field "Inbox:")) | |
1417 (cond ((not mh-inbox) | |
1418 (setq mh-inbox "+inbox")) | |
1419 ((not (mh-folder-name-p mh-inbox)) | |
1420 (setq mh-inbox (format "+%s" mh-inbox)))) | |
1421 (setq mh-unseen-seq (mh-get-profile-field "Unseen-Sequence:")) | |
1422 (if mh-unseen-seq | |
1423 (setq mh-unseen-seq (intern mh-unseen-seq)) | |
1424 (setq mh-unseen-seq 'unseen)) ;old MH default? | |
1425 (setq mh-previous-seq (mh-get-profile-field "Previous-Sequence:")) | |
1426 (if mh-previous-seq | |
1427 (setq mh-previous-seq (intern mh-previous-seq))) | |
1428 (run-hooks 'mh-find-path-hook)))) | |
1429 | |
1430 (defun mh-file-command-p (file) | |
1431 "Return t if file FILE is the name of a executable regular file." | |
1432 (and (file-regular-p file) (file-executable-p file))) | |
1433 | |
1434 (defun mh-find-progs () | |
1435 "Find the directories for the installed MH/nmh binaries and config files. | |
1436 Set the `mh-progs' and `mh-lib', and `mh-lib-progs' variables to the | |
1437 directory names and set `mh-nmh-flag' if we detect nmh instead of MH." | |
1438 (unless (and mh-progs mh-lib mh-lib-progs) | |
1439 (let ((path (or (mh-path-search exec-path "mhparam") | |
1440 (mh-path-search '("/usr/local/nmh/bin" ; nmh default | |
1441 "/usr/local/bin/mh/" | |
1442 "/usr/local/mh/" | |
1443 "/usr/bin/mh/" ;Ultrix 4.2, Linux | |
1444 "/usr/new/mh/" ;Ultrix <4.2 | |
1445 "/usr/contrib/mh/bin/" ;BSDI | |
1446 "/usr/pkg/bin/" ; NetBSD | |
1447 "/usr/local/bin/" | |
1448 ) | |
1449 "mhparam")))) | |
1450 (if (not path) | |
1451 (error "Unable to find the `mhparam' command")) | |
1452 (save-excursion | |
1453 (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) | |
1454 (set-buffer tmp-buffer) | |
1455 (unwind-protect | |
1456 (progn | |
1457 (call-process (expand-file-name "mhparam" path) | |
1458 nil '(t nil) nil "libdir" "etcdir") | |
1459 (goto-char (point-min)) | |
1460 (if (search-forward-regexp "^libdir:\\s-\\(\\S-+\\)\\s-*$" | |
1461 nil t) | |
1462 (setq mh-lib-progs (match-string 1) | |
1463 mh-lib mh-lib-progs | |
1464 mh-progs path)) | |
1465 (goto-char (point-min)) | |
1466 (if (search-forward-regexp "^etcdir:\\s-\\(\\S-+\\)\\s-*$" | |
1467 nil t) | |
1468 (setq mh-lib (match-string 1) | |
1469 mh-nmh-flag t))) | |
1470 (kill-buffer tmp-buffer)))) | |
1471 (unless (and mh-progs mh-lib mh-lib-progs) | |
1472 (error "Unable to determine paths from `mhparam' command"))))) | |
1473 | |
1474 (defun mh-path-search (path file) | |
1475 "Search PATH, a list of directory names, for FILE. | |
1476 Returns the element of PATH that contains FILE, or nil if not found." | |
1477 (while (and path | |
1478 (not (funcall 'mh-file-command-p | |
1479 (expand-file-name file (car path))))) | |
1480 (setq path (cdr path))) | |
1481 (car path)) | |
1482 | |
1483 (defvar mh-no-install nil) ;do not run install-mh | |
1484 | |
1485 (defun mh-install (profile error-val) | |
1486 "Initialize the MH environment. | |
1487 This is called if we fail to read the PROFILE file. ERROR-VAL is the error | |
1488 that made this call necessary." | |
1489 (if (or (getenv "MH") | |
1490 (file-exists-p profile) | |
1491 mh-no-install) | |
1492 (signal (car error-val) | |
1493 (list (format "Cannot read MH profile \"%s\"" profile) | |
1494 (car (cdr (cdr error-val)))))) | |
1495 ;; The "install-mh" command will output a short note which | |
1496 ;; mh-exec-cmd will display to the user. | |
1497 ;; The MH 5 version of install-mh might try prompt the user | |
1498 ;; for information, which would fail here. | |
1499 (mh-exec-cmd (expand-file-name "install-mh" mh-lib-progs) "-auto") | |
1500 ;; now try again to read the profile file | |
1501 (erase-buffer) | |
1502 (condition-case err | |
1503 (insert-file-contents profile) | |
1504 (file-error | |
1505 (signal (car err) ;re-signal with more specific msg | |
1506 (list (format "Cannot read MH profile \"%s\"" profile) | |
1507 (car (cdr (cdr err)))))))) | |
1508 | |
1509 (defun mh-set-folder-modified-p (flag) | 1956 (defun mh-set-folder-modified-p (flag) |
1510 "Mark current folder as modified or unmodified according to FLAG." | 1957 "Mark current folder as modified or unmodified according to FLAG." |
1511 (set-buffer-modified-p flag)) | 1958 (set-buffer-modified-p flag)) |
1512 | 1959 |
1513 (defun mh-find-seq (name) | 1960 (defun mh-find-seq (name) |
1519 (mh-seq-msgs (mh-find-seq seq))) | 1966 (mh-seq-msgs (mh-find-seq seq))) |
1520 | 1967 |
1521 (defun mh-update-scan-format (fmt width) | 1968 (defun mh-update-scan-format (fmt width) |
1522 "Return a scan format with the (msg) width in the FMT replaced with WIDTH. | 1969 "Return a scan format with the (msg) width in the FMT replaced with WIDTH. |
1523 | 1970 |
1524 The message number width portion of the format is discovered using | 1971 The message number width portion of the format is discovered |
1525 `mh-scan-msg-format-regexp'. Its replacement is controlled with | 1972 using `mh-scan-msg-format-regexp'. Its replacement is controlled |
1526 `mh-scan-msg-format-string'." | 1973 with `mh-scan-msg-format-string'." |
1527 (or (and | 1974 (or (and |
1528 (string-match mh-scan-msg-format-regexp fmt) | 1975 (string-match mh-scan-msg-format-regexp fmt) |
1529 (let ((begin (match-beginning 1)) | 1976 (let ((begin (match-beginning 1)) |
1530 (end (match-end 1))) | 1977 (end (match-end 1))) |
1531 (concat (substring fmt 0 begin) | 1978 (concat (substring fmt 0 begin) |
1532 (format mh-scan-msg-format-string width) | 1979 (format mh-scan-msg-format-string width) |
1533 (substring fmt end)))) | 1980 (substring fmt end)))) |
1534 fmt)) | 1981 fmt)) |
1535 | 1982 |
1536 (defun mh-message-number-width (folder) | 1983 (defun mh-msg-num-width (folder) |
1537 "Return the widest message number in this FOLDER." | 1984 "Return the width of the largest message number in this FOLDER." |
1538 (or mh-progs (mh-find-path)) | 1985 (or mh-progs (mh-find-path)) |
1539 (let ((tmp-buffer (get-buffer-create mh-temp-buffer)) | 1986 (let ((tmp-buffer (get-buffer-create mh-temp-buffer)) |
1540 (width 0)) | 1987 (width 0)) |
1541 (save-excursion | 1988 (save-excursion |
1542 (set-buffer tmp-buffer) | 1989 (set-buffer tmp-buffer) |
1543 (erase-buffer) | 1990 (erase-buffer) |
1544 (apply 'call-process | 1991 (apply 'call-process |
1545 (expand-file-name "scan" mh-progs) nil '(t nil) nil | 1992 (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil |
1546 (list folder "last" "-format" "%(msg)")) | 1993 (list folder "last" "-format" "%(msg)")) |
1547 (goto-char (point-min)) | 1994 (goto-char (point-min)) |
1548 (if (re-search-forward mh-scan-msg-number-regexp nil 0 1) | 1995 (if (re-search-forward mh-scan-msg-number-regexp nil 0 1) |
1549 (setq width (length (buffer-substring | 1996 (setq width (length (buffer-substring |
1550 (match-beginning 1) (match-end 1)))))) | 1997 (match-beginning 1) (match-end 1)))))) |
1551 width)) | 1998 width)) |
1552 | 1999 |
1553 (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag) | 2000 (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag) |
1554 "Add MSGS to SEQ. | 2001 "Add MSGS to SEQ. |
1555 Remove duplicates and keep sequence sorted. If optional INTERNAL-FLAG is | 2002 |
1556 non-nil, do not mark the message in the scan listing or inform MH of the | 2003 Remove duplicates and keep sequence sorted. If optional |
1557 addition. | 2004 INTERNAL-FLAG is non-nil, do not mark the message in the scan |
1558 | 2005 listing or inform MH of the addition. |
1559 If DONT-ANNOTATE-FLAG is non-nil then the annotations in the folder buffer are | 2006 |
1560 not updated." | 2007 If DONT-ANNOTATE-FLAG is non-nil then the annotations in the |
1561 (let ((entry (mh-find-seq seq))) | 2008 folder buffer are not updated." |
2009 (let ((entry (mh-find-seq seq)) | |
2010 (internal-seq-flag (mh-internal-seq seq))) | |
1562 (if (and msgs (atom msgs)) (setq msgs (list msgs))) | 2011 (if (and msgs (atom msgs)) (setq msgs (list msgs))) |
1563 (if (null entry) | 2012 (if (null entry) |
1564 (setq mh-seq-list | 2013 (setq mh-seq-list |
1565 (cons (mh-make-seq seq (mh-canonicalize-sequence msgs)) | 2014 (cons (mh-make-seq seq (mh-canonicalize-sequence msgs)) |
1566 mh-seq-list)) | 2015 mh-seq-list)) |
1567 (if msgs (setcdr entry (mh-canonicalize-sequence | 2016 (if msgs (setcdr entry (mh-canonicalize-sequence |
1568 (append msgs (mh-seq-msgs entry)))))) | 2017 (append msgs (mh-seq-msgs entry)))))) |
1569 (cond ((not internal-flag) | 2018 (unless internal-flag |
1570 (mh-add-to-sequence seq msgs) | 2019 (mh-add-to-sequence seq msgs) |
1571 (unless dont-annotate-flag | 2020 (when (not dont-annotate-flag) |
1572 (mh-notate-seq seq mh-note-seq (1+ mh-cmd-note))))))) | 2021 (mh-iterate-on-range msg msgs |
2022 (unless (memq msg (cdr entry)) | |
2023 (mh-add-sequence-notation msg internal-seq-flag))))))) | |
1573 | 2024 |
1574 (defun mh-canonicalize-sequence (msgs) | 2025 (defun mh-canonicalize-sequence (msgs) |
1575 "Sort MSGS in decreasing order and remove duplicates." | 2026 "Sort MSGS in decreasing order and remove duplicates." |
1576 (let* ((sorted-msgs (sort (copy-sequence msgs) '>)) | 2027 (let* ((sorted-msgs (sort (copy-sequence msgs) '>)) |
1577 (head sorted-msgs)) | 2028 (head sorted-msgs)) |
1580 (setcdr head (cddr head)) | 2031 (setcdr head (cddr head)) |
1581 (setq head (cdr head)))) | 2032 (setq head (cdr head)))) |
1582 sorted-msgs)) | 2033 sorted-msgs)) |
1583 | 2034 |
1584 (defvar mh-sub-folders-cache (make-hash-table :test #'equal)) | 2035 (defvar mh-sub-folders-cache (make-hash-table :test #'equal)) |
2036 (defvar mh-current-folder-name nil) | |
2037 (defvar mh-flists-partial-line "") | |
2038 (defvar mh-flists-process nil) | |
2039 | |
2040 ;; Initialize mh-sub-folders-cache... | |
2041 (defun mh-collect-folder-names () | |
2042 "Collect folder names by running \"folders\"." | |
2043 (unless mh-flists-process | |
2044 (setq mh-flists-process | |
2045 (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter | |
2046 "-recurse" "-fast")))) | |
2047 | |
2048 (defun mh-collect-folder-names-filter (process output) | |
2049 "Read folder names. | |
2050 PROCESS is the flists process that was run to collect folder | |
2051 names and the function is called when OUTPUT is available." | |
2052 (let ((position 0) | |
2053 (prevailing-match-data (match-data)) | |
2054 line-end folder) | |
2055 (unwind-protect | |
2056 (while (setq line-end (string-match "\n" output position)) | |
2057 (setq folder (format "+%s%s" | |
2058 mh-flists-partial-line | |
2059 (substring output position line-end))) | |
2060 (setq mh-flists-partial-line "") | |
2061 (unless (equal (aref folder 1) ?.) | |
2062 (mh-populate-sub-folders-cache folder)) | |
2063 (setq position (1+ line-end))) | |
2064 (set-match-data prevailing-match-data)) | |
2065 (setq mh-flists-partial-line (substring output position)))) | |
2066 | |
2067 (defun mh-populate-sub-folders-cache (folder) | |
2068 "Tell `mh-sub-folders-cache' about FOLDER." | |
2069 (let* ((last-slash (mh-search-from-end ?/ folder)) | |
2070 (child1 (substring folder (1+ (or last-slash 0)))) | |
2071 (parent (and last-slash (substring folder 0 last-slash))) | |
2072 (parent-slash (and parent (mh-search-from-end ?/ parent))) | |
2073 (child2 (and parent (substring parent (1+ (or parent-slash 0))))) | |
2074 (grand-parent (and parent-slash (substring parent 0 parent-slash))) | |
2075 (cache-entry (gethash parent mh-sub-folders-cache))) | |
2076 (unless (loop for x in cache-entry when (equal (car x) child1) return t | |
2077 finally return nil) | |
2078 (push (list child1) cache-entry) | |
2079 (setf (gethash parent mh-sub-folders-cache) | |
2080 (sort cache-entry (lambda (x y) (string< (car x) (car y))))) | |
2081 (when parent | |
2082 (loop for x in (gethash grand-parent mh-sub-folders-cache) | |
2083 when (equal (car x) child2) | |
2084 do (progn (setf (cdr x) t) (return))))))) | |
1585 | 2085 |
1586 (defun mh-normalize-folder-name (folder &optional empty-string-okay | 2086 (defun mh-normalize-folder-name (folder &optional empty-string-okay |
1587 dont-remove-trailing-slash) | 2087 dont-remove-trailing-slash) |
1588 "Normalizes FOLDER name. | 2088 "Normalizes FOLDER name. |
1589 Makes sure that two '/' characters never occur next to each other. Also all | 2089 |
1590 occurrences of \"..\" and \".\" are suitably processed. So \"+inbox/../news\" | 2090 Makes sure that two '/' characters never occur next to each |
1591 will be normalized to \"+news\". | 2091 other. Also all occurrences of \"..\" and \".\" are suitably |
1592 | 2092 processed. So \"+inbox/../news\" will be normalized to \"+news\". |
1593 If optional argument EMPTY-STRING-OKAY is nil then a '+' is added at the | 2093 |
1594 front if FOLDER lacks one. If non-nil and FOLDER is the empty string then | 2094 If optional argument EMPTY-STRING-OKAY is nil then a '+' is added |
1595 nothing is added. | 2095 at the front if FOLDER lacks one. If non-nil and FOLDER is the |
1596 | 2096 empty string then nothing is added. |
1597 If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a trailing '/' | 2097 |
1598 if present is retained (if present), otherwise it is removed." | 2098 If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a |
2099 trailing '/' if present is retained (if present), otherwise it is | |
2100 removed." | |
1599 (when (stringp folder) | 2101 (when (stringp folder) |
1600 ;; Replace two or more consecutive '/' characters with a single '/' | 2102 ;; Replace two or more consecutive '/' characters with a single '/' |
1601 (while (string-match "//" folder) | 2103 (while (string-match "//" folder) |
1602 (setq folder (replace-match "/" nil t folder))) | 2104 (setq folder (replace-match "/" nil t folder))) |
1603 (let* ((length (length folder)) | 2105 (let* ((length (length folder)) |
1604 (trailing-slash-present (and (> length 0) | 2106 (trailing-slash-present (and (> length 0) |
1605 (equal (aref folder (1- length)) ?/)))) | 2107 (equal (aref folder (1- length)) ?/))) |
1606 (let ((components (split-string folder "/")) | 2108 (leading-slash-present (and (> length 0) |
2109 (equal (aref folder 0) ?/)))) | |
2110 (when (and (> length 0) (equal (aref folder 0) ?@) | |
2111 (stringp mh-current-folder-name)) | |
2112 (setq folder (format "%s/%s/" mh-current-folder-name | |
2113 (substring folder 1)))) | |
2114 ;; XXX: Purge empty strings from the list that split-string returns. In | |
2115 ;; XEmacs, (split-string "+foo/" "/") returns ("+foo" "") while in GNU | |
2116 ;; Emacs it returns ("+foo"). In the code it is assumed that the | |
2117 ;; components list has no empty strings. | |
2118 (let ((components (delete "" (split-string folder "/"))) | |
1607 (result ())) | 2119 (result ())) |
1608 ;; Remove .. and . from the pathname. | 2120 ;; Remove .. and . from the pathname. |
1609 (dolist (component components) | 2121 (dolist (component components) |
1610 (cond ((and (equal component "..") result) | 2122 (cond ((and (equal component "..") result) |
1611 (pop result)) | 2123 (pop result)) |
1616 (dolist (component result) | 2128 (dolist (component result) |
1617 (setq folder (concat component "/" folder))) | 2129 (setq folder (concat component "/" folder))) |
1618 ;; Remove trailing '/' if needed. | 2130 ;; Remove trailing '/' if needed. |
1619 (unless (and trailing-slash-present dont-remove-trailing-slash) | 2131 (unless (and trailing-slash-present dont-remove-trailing-slash) |
1620 (when (not (equal folder "")) | 2132 (when (not (equal folder "")) |
1621 (setq folder (substring folder 0 (1- (length folder)))))))) | 2133 (setq folder (substring folder 0 (1- (length folder)))))) |
2134 (when leading-slash-present | |
2135 (setq folder (concat "/" folder))))) | |
1622 (cond ((and empty-string-okay (equal folder ""))) | 2136 (cond ((and empty-string-okay (equal folder ""))) |
1623 ((equal folder "") (setq folder "+")) | 2137 ((equal folder "") (setq folder "+")) |
1624 ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder))))) | 2138 ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder))))) |
1625 folder) | 2139 folder) |
1626 | 2140 |
2141 (defmacro mh-children-p (folder) | |
2142 "Return t if FOLDER from sub-folders cache has children. | |
2143 The car of folder is the name, and the cdr is either t or some | |
2144 sort of count that I do not understand. It's too small to be the | |
2145 number of messages in the sub-folders and too large to be the | |
2146 number of sub-folders. XXX" | |
2147 `(if (cdr ,folder) | |
2148 t | |
2149 nil)) | |
2150 | |
2151 (defun mh-folder-list (folder) | |
2152 "Return FOLDER and its descendents. | |
2153 Returns a list of strings. For example, | |
2154 | |
2155 '(\"inbox\" \"lists\" \"lists/mh-e\"). | |
2156 | |
2157 If folder is nil, then all folders are considered. Respects the | |
2158 value of `mh-recursive-folders-flag'. If this flag is nil, and | |
2159 the sub-folders have not been explicitly viewed, then they will | |
2160 not be returned." | |
2161 (let ((folder-list)) | |
2162 ;; Normalize folder. Strip leading +. Add trailing slash. If no | |
2163 ;; folder is specified, ensure it is nil to ensure we get the | |
2164 ;; top-level folders; otherwise mh-sub-folders returns all the | |
2165 ;; files in / if given an empty string or +. | |
2166 (when folder | |
2167 (setq folder (replace-regexp-in-string "^\+" "" folder)) | |
2168 (setq folder (replace-regexp-in-string "/*$" "/" folder)) | |
2169 (if (equal folder "") | |
2170 (setq folder nil))) | |
2171 (loop for f in (mh-sub-folders folder) do | |
2172 (setq folder-list (append folder-list (list (concat folder (car f))))) | |
2173 (if (mh-children-p f) | |
2174 (setq folder-list | |
2175 (append folder-list | |
2176 (mh-folder-list (concat folder (car f))))))) | |
2177 folder-list)) | |
2178 | |
1627 (defun mh-sub-folders (folder &optional add-trailing-slash-flag) | 2179 (defun mh-sub-folders (folder &optional add-trailing-slash-flag) |
1628 "Find the subfolders of FOLDER. | 2180 "Find the subfolders of FOLDER. |
1629 The function avoids running folders unnecessarily by caching the results of | 2181 The function avoids running folders unnecessarily by caching the |
1630 the actual folders call. | 2182 results of the actual folders call. |
1631 | 2183 |
1632 If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a slash is added | 2184 If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a |
1633 to each of the sub-folder names that may have nested folders within them." | 2185 slash is added to each of the sub-folder names that may have |
2186 nested folders within them." | |
1634 (let* ((folder (mh-normalize-folder-name folder)) | 2187 (let* ((folder (mh-normalize-folder-name folder)) |
1635 (match (gethash folder mh-sub-folders-cache 'no-result)) | 2188 (match (gethash folder mh-sub-folders-cache 'no-result)) |
1636 (sub-folders (cond ((eq match 'no-result) | 2189 (sub-folders (cond ((eq match 'no-result) |
1637 (setf (gethash folder mh-sub-folders-cache) | 2190 (setf (gethash folder mh-sub-folders-cache) |
1638 (mh-sub-folders-actual folder))) | 2191 (mh-sub-folders-actual folder))) |
1643 sub-folders) | 2196 sub-folders) |
1644 sub-folders))) | 2197 sub-folders))) |
1645 | 2198 |
1646 (defun mh-sub-folders-actual (folder) | 2199 (defun mh-sub-folders-actual (folder) |
1647 "Execute the command folders to return the sub-folders of FOLDER. | 2200 "Execute the command folders to return the sub-folders of FOLDER. |
1648 Filters out the folder names that start with \".\" so that directories that | 2201 Filters out the folder names that start with \".\" so that |
1649 aren't usually mail folders are hidden." | 2202 directories that aren't usually mail folders are hidden." |
1650 (let ((arg-list `(,(expand-file-name "folders" mh-progs) | 2203 (let ((arg-list `(,(expand-file-name "folders" mh-progs) |
1651 nil (t nil) nil "-noheader" "-norecurse" "-nototal" | 2204 nil (t nil) nil "-noheader" "-norecurse" "-nototal" |
1652 ,@(if (stringp folder) (list folder) ()))) | 2205 ,@(if (stringp folder) (list folder) ()))) |
1653 (results ()) | 2206 (results ()) |
1654 (current-folder (concat | 2207 (current-folder (concat |
1660 (with-temp-buffer | 2213 (with-temp-buffer |
1661 (apply #'call-process arg-list) | 2214 (apply #'call-process arg-list) |
1662 (goto-char (point-min)) | 2215 (goto-char (point-min)) |
1663 (while (not (and (eolp) (bolp))) | 2216 (while (not (and (eolp) (bolp))) |
1664 (goto-char (line-end-position)) | 2217 (goto-char (line-end-position)) |
1665 (let ((has-pos (search-backward " has " (line-beginning-position) t))) | 2218 (let ((start-pos (line-beginning-position)) |
2219 (has-pos (search-backward " has " (line-beginning-position) t))) | |
1666 (when (integerp has-pos) | 2220 (when (integerp has-pos) |
1667 (while (equal (char-after has-pos) ? ) | 2221 (while (equal (char-after has-pos) ? ) |
1668 (decf has-pos)) | 2222 (decf has-pos)) |
1669 (incf has-pos) | 2223 (incf has-pos) |
1670 (let* ((name (buffer-substring (line-beginning-position) has-pos)) | 2224 (while (equal (char-after start-pos) ? ) |
2225 (incf start-pos)) | |
2226 (let* ((name (buffer-substring start-pos has-pos)) | |
1671 (first-char (aref name 0)) | 2227 (first-char (aref name 0)) |
1672 (last-char (aref name (1- (length name))))) | 2228 (last-char (aref name (1- (length name))))) |
1673 (unless (member first-char '(?. ?# ?,)) | 2229 (unless (member first-char '(?. ?# ?,)) |
1674 (when (and (equal last-char ?+) (equal name current-folder)) | 2230 (when (and (equal last-char ?+) (equal name current-folder)) |
1675 (setq name (substring name 0 (1- (length name))))) | 2231 (setq name (substring name 0 (1- (length name))))) |
1688 results)))) | 2244 results)))) |
1689 results)) | 2245 results)) |
1690 | 2246 |
1691 (defun mh-remove-from-sub-folders-cache (folder) | 2247 (defun mh-remove-from-sub-folders-cache (folder) |
1692 "Remove FOLDER and its parent from `mh-sub-folders-cache'. | 2248 "Remove FOLDER and its parent from `mh-sub-folders-cache'. |
1693 FOLDER should be unconditionally removed from the cache. Also the last ancestor | 2249 FOLDER should be unconditionally removed from the cache. Also the |
1694 of FOLDER present in the cache must be removed as well. | 2250 last ancestor of FOLDER present in the cache must be removed as |
1695 | 2251 well. |
1696 To see why this is needed assume we have a folder +foo which has a single | 2252 |
1697 sub-folder qux. Now we create the folder +foo/bar/baz. Here we will need to | 2253 To see why this is needed assume we have a folder +foo which has |
1698 invalidate the cached sub-folders of +foo, otherwise completion on +foo won't | 2254 a single sub-folder qux. Now we create the folder +foo/bar/baz. |
1699 tell us about the option +foo/bar!" | 2255 Here we will need to invalidate the cached sub-folders of +foo, |
2256 otherwise completion on +foo won't tell us about the option | |
2257 +foo/bar!" | |
1700 (remhash folder mh-sub-folders-cache) | 2258 (remhash folder mh-sub-folders-cache) |
1701 (block ancestor-found | 2259 (block ancestor-found |
1702 (let ((parent folder) | 2260 (let ((parent folder) |
1703 (one-ancestor-found nil) | 2261 (one-ancestor-found nil) |
1704 last-slash) | 2262 last-slash) |
1710 (return-from ancestor-found) | 2268 (return-from ancestor-found) |
1711 (setq one-ancestor-found t)))) | 2269 (setq one-ancestor-found t)))) |
1712 (remhash nil mh-sub-folders-cache)))) | 2270 (remhash nil mh-sub-folders-cache)))) |
1713 | 2271 |
1714 (defvar mh-folder-hist nil) | 2272 (defvar mh-folder-hist nil) |
1715 (defvar mh-speed-folder-map) | 2273 |
2274 ;; Shush compiler. | |
2275 (eval-when-compile | |
2276 (defvar mh-speed-folder-map) | |
2277 (defvar mh-speed-flists-cache)) | |
2278 | |
2279 (defvar mh-allow-root-folder-flag nil | |
2280 "Non-nil means \"+\" is an acceptable folder name. | |
2281 This variable is used to communicate with | |
2282 `mh-folder-completion-function'. That function can have exactly | |
2283 three arguments so we bind this variable to t or nil. | |
2284 | |
2285 This variable should never be set.") | |
2286 | |
1716 (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map)) | 2287 (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map)) |
1717 (define-key mh-folder-completion-map " " 'minibuffer-complete) | 2288 (define-key mh-folder-completion-map " " 'minibuffer-complete) ;Why??? |
2289 | |
2290 (defvar mh-speed-flists-inhibit-flag nil) | |
2291 | |
2292 (defun mh-speed-flists-active-p () | |
2293 "Check if speedbar is running with message counts enabled." | |
2294 (and (featurep 'mh-speed) | |
2295 (not mh-speed-flists-inhibit-flag) | |
2296 (> (hash-table-count mh-speed-flists-cache) 0))) | |
1718 | 2297 |
1719 (defun mh-folder-completion-function (name predicate flag) | 2298 (defun mh-folder-completion-function (name predicate flag) |
1720 "Programmable completion for folder names. | 2299 "Programmable completion for folder names. |
1721 NAME is the partial folder name that has been input. PREDICATE if non-nil is a | 2300 NAME is the partial folder name that has been input. PREDICATE if |
1722 function that is used to filter the possible choices and FLAG determines | 2301 non-nil is a function that is used to filter the possible choices |
1723 whether the completion is over." | 2302 and FLAG determines whether the completion is over." |
1724 (let* ((orig-name name) | 2303 (let* ((orig-name name) |
1725 (name (mh-normalize-folder-name name nil t)) | 2304 (name (mh-normalize-folder-name name nil t)) |
1726 (last-slash (mh-search-from-end ?/ name)) | 2305 (last-slash (mh-search-from-end ?/ name)) |
1727 (last-complete (if last-slash (substring name 0 last-slash) nil)) | 2306 (last-complete (if last-slash (substring name 0 last-slash) nil)) |
1728 (remainder (cond (last-complete (substring name (1+ last-slash))) | 2307 (remainder (cond (last-complete (substring name (1+ last-slash))) |
1745 (t try-res)))) | 2324 (t try-res)))) |
1746 ((eq flag t) | 2325 ((eq flag t) |
1747 (all-completions | 2326 (all-completions |
1748 remainder (mh-sub-folders last-complete t) predicate)) | 2327 remainder (mh-sub-folders last-complete t) predicate)) |
1749 ((eq flag 'lambda) | 2328 ((eq flag 'lambda) |
1750 (file-exists-p | 2329 (let ((path (concat mh-user-path |
1751 (concat mh-user-path | 2330 (substring (mh-normalize-folder-name name) 1)))) |
1752 (substring (mh-normalize-folder-name name) 1))))))) | 2331 (cond (mh-allow-root-folder-flag (file-exists-p path)) |
1753 | 2332 ((equal path mh-user-path) nil) |
1754 (defun mh-folder-completing-read (prompt default) | 2333 (t (file-exists-p path)))))))) |
1755 "Read folder name with PROMPT and default result DEFAULT." | 2334 |
2335 (defun mh-folder-completing-read (prompt default allow-root-folder-flag) | |
2336 "Read folder name with PROMPT and default result DEFAULT. | |
2337 If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be | |
2338 a folder name corresponding to `mh-user-path'." | |
1756 (mh-normalize-folder-name | 2339 (mh-normalize-folder-name |
1757 (let ((minibuffer-local-completion-map mh-folder-completion-map)) | 2340 (let ((minibuffer-completing-file-name t) |
2341 (completion-root-regexp "^[+/]") | |
2342 (minibuffer-local-completion-map mh-folder-completion-map) | |
2343 (mh-allow-root-folder-flag allow-root-folder-flag)) | |
1758 (completing-read prompt 'mh-folder-completion-function nil nil nil | 2344 (completing-read prompt 'mh-folder-completion-function nil nil nil |
1759 'mh-folder-hist default)) | 2345 'mh-folder-hist default)) |
1760 t)) | 2346 t)) |
1761 | 2347 |
1762 (defun mh-prompt-for-folder (prompt default can-create | 2348 (defun mh-prompt-for-folder (prompt default can-create |
1763 &optional default-string allow-root-folder-flag) | 2349 &optional default-string allow-root-folder-flag) |
1764 "Prompt for a folder name with PROMPT. | 2350 "Prompt for a folder name with PROMPT. |
1765 Returns the folder's name as a string. DEFAULT is used if the folder exists | 2351 Returns the folder's name as a string. DEFAULT is used if the |
1766 and the user types return. If the CAN-CREATE flag is t, then a folder is | 2352 folder exists and the user types return. If the CAN-CREATE flag |
1767 created if it doesn't already exist. If optional argument DEFAULT-STRING is | 2353 is t, then a folder is created if it doesn't already exist. If |
1768 non-nil, use it in the prompt instead of DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is | 2354 optional argument DEFAULT-STRING is non-nil, use it in the prompt |
1769 non-nil then the function will accept the folder +, which means all folders | 2355 instead of DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is non-nil then the |
1770 when used in searching." | 2356 function will accept the folder +, which means all folders when |
2357 used in searching." | |
1771 (if (null default) | 2358 (if (null default) |
1772 (setq default "")) | 2359 (setq default "")) |
1773 (let* ((default-string (cond (default-string (format " [%s]? " | 2360 (let* ((default-string (cond (default-string (format " (default %s)" default-string)) |
1774 default-string)) | 2361 ((equal "" default) "") |
1775 ((equal "" default) "? ") | 2362 (t (format " (default %s)" default)))) |
1776 (t (format " [%s]? " default)))) | 2363 (prompt (format "%s folder%s: " prompt default-string)) |
1777 (prompt (format "%s folder%s" prompt default-string)) | 2364 (mh-current-folder-name mh-current-folder) |
1778 read-name folder-name) | 2365 read-name folder-name) |
1779 (while (and (setq read-name (mh-folder-completing-read prompt default)) | 2366 (while (and (setq read-name (mh-folder-completing-read |
2367 prompt default allow-root-folder-flag)) | |
1780 (equal read-name "") | 2368 (equal read-name "") |
1781 (equal default ""))) | 2369 (equal default ""))) |
1782 (cond ((or (equal read-name "") | 2370 (cond ((or (equal read-name "") |
1783 (and (equal read-name "+") (not allow-root-folder-flag))) | 2371 (and (equal read-name "+") (not allow-root-folder-flag))) |
1784 (setq read-name default)) | 2372 (setq read-name default)) |
1788 (error "No folder specified")) | 2376 (error "No folder specified")) |
1789 (setq folder-name read-name) | 2377 (setq folder-name read-name) |
1790 (cond ((and (> (length folder-name) 0) | 2378 (cond ((and (> (length folder-name) 0) |
1791 (eq (aref folder-name (1- (length folder-name))) ?/)) | 2379 (eq (aref folder-name (1- (length folder-name))) ?/)) |
1792 (setq folder-name (substring folder-name 0 -1)))) | 2380 (setq folder-name (substring folder-name 0 -1)))) |
2381 (let* ((last-slash (mh-search-from-end ?/ folder-name)) | |
2382 (parent (and last-slash (substring folder-name 0 last-slash))) | |
2383 (child (if last-slash | |
2384 (substring folder-name (1+ last-slash)) | |
2385 (substring folder-name 1)))) | |
2386 (unless (member child | |
2387 (mapcar #'car (gethash parent mh-sub-folders-cache))) | |
2388 (mh-remove-from-sub-folders-cache folder-name))) | |
1793 (let ((new-file-flag | 2389 (let ((new-file-flag |
1794 (not (file-exists-p (mh-expand-file-name folder-name))))) | 2390 (not (file-exists-p (mh-expand-file-name folder-name))))) |
1795 (cond ((and new-file-flag | 2391 (cond ((and new-file-flag |
2392 can-create | |
1796 (y-or-n-p | 2393 (y-or-n-p |
1797 (format "Folder %s does not exist. Create it? " | 2394 (format "Folder %s does not exist. Create it? " |
1798 folder-name))) | 2395 folder-name))) |
1799 (message "Creating %s" folder-name) | 2396 (message "Creating %s" folder-name) |
1800 (mh-exec-cmd-error nil "folder" folder-name) | 2397 (mh-exec-cmd-error nil "folder" folder-name) |
1801 (mh-remove-from-sub-folders-cache folder-name) | 2398 (mh-remove-from-sub-folders-cache folder-name) |
1802 (when (boundp 'mh-speed-folder-map) | 2399 (when (boundp 'mh-speed-folder-map) |
1803 (mh-speed-add-folder folder-name)) | 2400 (mh-speed-add-folder folder-name)) |
1804 (message "Creating %s...done" folder-name)) | 2401 (message "Creating %s...done" folder-name)) |
1805 (new-file-flag | 2402 (new-file-flag |
1806 (error "Folder %s is not created" folder-name)) | 2403 (error "Folder %s does not exist" folder-name)) |
1807 ((not (file-directory-p (mh-expand-file-name folder-name))) | 2404 ((not (file-directory-p (mh-expand-file-name folder-name))) |
1808 (error "\"%s\" is not a directory" | 2405 (error "%s is not a directory" |
1809 (mh-expand-file-name folder-name))))) | 2406 (mh-expand-file-name folder-name))))) |
1810 folder-name)) | 2407 folder-name)) |
1811 | 2408 |
1812 ;;; Issue commands to MH. | 2409 |
1813 | 2410 |
1814 (defun mh-exec-cmd (command &rest args) | 2411 ;;; List and string manipulation |
1815 "Execute mh-command COMMAND with ARGS. | |
1816 The side effects are what is desired. | |
1817 Any output is assumed to be an error and is shown to the user. | |
1818 The output is not read or parsed by MH-E." | |
1819 (save-excursion | |
1820 (set-buffer (get-buffer-create mh-log-buffer)) | |
1821 (erase-buffer) | |
1822 (apply 'call-process | |
1823 (expand-file-name command mh-progs) nil t nil | |
1824 (mh-list-to-string args)) | |
1825 (if (> (buffer-size) 0) | |
1826 (save-window-excursion | |
1827 (switch-to-buffer-other-window mh-log-buffer) | |
1828 (sit-for 5))))) | |
1829 | |
1830 (defun mh-exec-cmd-error (env command &rest args) | |
1831 "In environment ENV, execute mh-command COMMAND with ARGS. | |
1832 ENV is nil or a string of space-separated \"var=value\" elements. | |
1833 Signals an error if process does not complete successfully." | |
1834 (save-excursion | |
1835 (set-buffer (get-buffer-create mh-temp-buffer)) | |
1836 (erase-buffer) | |
1837 (let ((status | |
1838 (if env | |
1839 ;; the shell hacks necessary here shows just how broken Unix is | |
1840 (apply 'call-process "/bin/sh" nil t nil "-c" | |
1841 (format "%s %s ${1+\"$@\"}" | |
1842 env | |
1843 (expand-file-name command mh-progs)) | |
1844 command | |
1845 (mh-list-to-string args)) | |
1846 (apply 'call-process | |
1847 (expand-file-name command mh-progs) nil t nil | |
1848 (mh-list-to-string args))))) | |
1849 (mh-handle-process-error command status)))) | |
1850 | |
1851 (defun mh-exec-cmd-daemon (command filter &rest args) | |
1852 "Execute MH command COMMAND in the background. | |
1853 | |
1854 If FILTER is non-nil then it is used to process the output otherwise the | |
1855 default filter `mh-process-daemon' is used. See `set-process-filter' for more | |
1856 details of FILTER. | |
1857 | |
1858 ARGS are passed to COMMAND as command line arguments." | |
1859 (save-excursion | |
1860 (set-buffer (get-buffer-create mh-log-buffer)) | |
1861 (erase-buffer)) | |
1862 (let* ((process-connection-type nil) | |
1863 (process (apply 'start-process | |
1864 command nil | |
1865 (expand-file-name command mh-progs) | |
1866 (mh-list-to-string args)))) | |
1867 (set-process-filter process (or filter 'mh-process-daemon)))) | |
1868 | |
1869 (defun mh-process-daemon (process output) | |
1870 "PROCESS daemon that puts OUTPUT into a temporary buffer. | |
1871 Any output from the process is displayed in an asynchronous pop-up window." | |
1872 (set-buffer (get-buffer-create mh-log-buffer)) | |
1873 (insert-before-markers output) | |
1874 (display-buffer mh-log-buffer)) | |
1875 | |
1876 (defun mh-exec-cmd-quiet (raise-error command &rest args) | |
1877 "Signal RAISE-ERROR if COMMAND with ARGS fails. | |
1878 Execute MH command COMMAND with ARGS. ARGS is a list of strings. | |
1879 Return at start of mh-temp buffer, where output can be parsed and used. | |
1880 Returns value of `call-process', which is 0 for success, unless RAISE-ERROR is | |
1881 non-nil, in which case an error is signaled if `call-process' returns non-0." | |
1882 (set-buffer (get-buffer-create mh-temp-buffer)) | |
1883 (erase-buffer) | |
1884 (let ((value | |
1885 (apply 'call-process | |
1886 (expand-file-name command mh-progs) nil t nil | |
1887 args))) | |
1888 (goto-char (point-min)) | |
1889 (if raise-error | |
1890 (mh-handle-process-error command value) | |
1891 value))) | |
1892 | |
1893 (defun mh-profile-component (component) | |
1894 "Return COMPONENT value from mhparam, or nil if unset." | |
1895 (save-excursion | |
1896 (mh-exec-cmd-quiet nil "mhparam" "-components" component) | |
1897 (mh-get-profile-field (concat component ":")))) | |
1898 | |
1899 (defun mh-exchange-point-and-mark-preserving-active-mark () | |
1900 "Put the mark where point is now, and point where the mark is now. | |
1901 This command works even when the mark is not active, and preserves whether the | |
1902 mark is active or not." | |
1903 (interactive nil) | |
1904 (let ((is-active (and (boundp 'mark-active) mark-active))) | |
1905 (let ((omark (mark t))) | |
1906 (if (null omark) | |
1907 (error "No mark set in this buffer")) | |
1908 (set-mark (point)) | |
1909 (goto-char omark) | |
1910 (if (boundp 'mark-active) | |
1911 (setq mark-active is-active)) | |
1912 nil))) | |
1913 | |
1914 (defun mh-exec-cmd-output (command display &rest args) | |
1915 "Execute MH command COMMAND with DISPLAY flag and ARGS. | |
1916 Put the output into buffer after point. Set mark after inserted text. | |
1917 Output is expected to be shown to user, not parsed by MH-E." | |
1918 (push-mark (point) t) | |
1919 (apply 'call-process | |
1920 (expand-file-name command mh-progs) nil t display | |
1921 (mh-list-to-string args)) | |
1922 | |
1923 ;; The following is used instead of 'exchange-point-and-mark because the | |
1924 ;; latter activates the current region (between point and mark), which | |
1925 ;; turns on highlighting. So prior to this bug fix, doing "inc" would | |
1926 ;; highlight a region containing the new messages, which is undesirable. | |
1927 ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4. | |
1928 (mh-exchange-point-and-mark-preserving-active-mark)) | |
1929 | |
1930 (defun mh-exec-lib-cmd-output (command &rest args) | |
1931 "Execute MH library command COMMAND with ARGS. | |
1932 Put the output into buffer after point. Set mark after inserted text." | |
1933 (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args)) | |
1934 | |
1935 (defun mh-handle-process-error (command status) | |
1936 "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS. | |
1937 STATUS is return value from `call-process'. | |
1938 Program output is in current buffer. | |
1939 If output is too long to include in error message, display the buffer." | |
1940 (cond ((eq status 0) ;success | |
1941 status) | |
1942 ((stringp status) ;kill string | |
1943 (error "%s: %s" command status)) | |
1944 (t ;exit code | |
1945 (cond | |
1946 ((= (buffer-size) 0) ;program produced no error message | |
1947 (error "%s: exit code %d" command status)) | |
1948 (t | |
1949 ;; will error message fit on one line? | |
1950 (goto-line 2) | |
1951 (if (and (< (buffer-size) (frame-width)) | |
1952 (eobp)) | |
1953 (error "%s" | |
1954 (buffer-substring 1 (progn (goto-char 1) | |
1955 (end-of-line) | |
1956 (point)))) | |
1957 (display-buffer (current-buffer)) | |
1958 (error "%s failed with status %d. See error message in other window" | |
1959 command status))))))) | |
1960 | 2412 |
1961 (defun mh-list-to-string (l) | 2413 (defun mh-list-to-string (l) |
1962 "Flatten the list L and make every element of the new list into a string." | 2414 "Flatten the list L and make every element of the new list into a string." |
1963 (nreverse (mh-list-to-string-1 l))) | 2415 (nreverse (mh-list-to-string-1 l))) |
1964 | 2416 |
1974 ((equal (car l) "")) | 2426 ((equal (car l) "")) |
1975 ((stringp (car l)) (setq new-list (cons (car l) new-list))) | 2427 ((stringp (car l)) (setq new-list (cons (car l) new-list))) |
1976 ((listp (car l)) | 2428 ((listp (car l)) |
1977 (setq new-list (nconc (mh-list-to-string-1 (car l)) | 2429 (setq new-list (nconc (mh-list-to-string-1 (car l)) |
1978 new-list))) | 2430 new-list))) |
1979 (t (error "Bad element in mh-list-to-string: %s" (car l)))) | 2431 (t (error "Bad element in `mh-list-to-string': %s" (car l)))) |
1980 (setq l (cdr l))) | 2432 (setq l (cdr l))) |
1981 new-list)) | 2433 new-list)) |
1982 | 2434 |
2435 (defun mh-replace-string (old new) | |
2436 "Replace all occurrences of OLD with NEW in the current buffer. | |
2437 Ignores case when searching for OLD." | |
2438 (goto-char (point-min)) | |
2439 (let ((case-fold-search t)) | |
2440 (while (search-forward old nil t) | |
2441 (replace-match new t t)))) | |
2442 | |
1983 (provide 'mh-utils) | 2443 (provide 'mh-utils) |
1984 | 2444 |
1985 ;;; Local Variables: | 2445 ;; Local Variables: |
1986 ;;; indent-tabs-mode: nil | 2446 ;; indent-tabs-mode: nil |
1987 ;;; sentence-end-double-space: nil | 2447 ;; sentence-end-double-space: nil |
1988 ;;; End: | 2448 ;; End: |
1989 | 2449 |
2450 ;; arch-tag: 1af39fdf-f66f-4b06-9b48-18a7656c8e36 | |
1990 ;;; mh-utils.el ends here | 2451 ;;; mh-utils.el ends here |