Commit | Line | Data |
---|---|---|
dda00b2c | 1 | ;;; mh-utils.el --- MH-E general utilities |
c26cf6c8 | 2 | |
95df8112 | 3 | ;; Copyright (C) 1993, 1995, 1997, 2000-2011 Free Software Foundation, Inc. |
a1b4049d BW |
4 | |
5 | ;; Author: Bill Wohler <wohler@newt.com> | |
6 | ;; Maintainer: Bill Wohler <wohler@newt.com> | |
7 | ;; Keywords: mail | |
8 | ;; See: mh-e.el | |
c26cf6c8 | 9 | |
60370d40 | 10 | ;; This file is part of GNU Emacs. |
c26cf6c8 | 11 | |
5e809f55 | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
c26cf6c8 | 13 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
c26cf6c8 | 16 | |
9b7bc076 | 17 | ;; GNU Emacs is distributed in the hope that it will be useful, |
c26cf6c8 RS |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
c26cf6c8 RS |
24 | |
25 | ;;; Commentary: | |
26 | ||
a1b4049d BW |
27 | ;;; Change Log: |
28 | ||
c26cf6c8 RS |
29 | ;;; Code: |
30 | ||
dda00b2c | 31 | (require 'mh-e) |
a66894d8 | 32 | (mh-require-cl) |
7094eefe | 33 | |
c3d9274a | 34 | (require 'font-lock) |
cee9f5c6 | 35 | |
c3d9274a | 36 | ;;; CL Replacements |
cee9f5c6 | 37 | |
dda00b2c | 38 | ;;;###mh-autoload |
c3d9274a BW |
39 | (defun mh-search-from-end (char string) |
40 | "Return the position of last occurrence of CHAR in STRING. | |
2dcf34f9 BW |
41 | If CHAR is not present in STRING then return nil. The function is |
42 | used in lieu of `search' in the CL package." | |
c3d9274a BW |
43 | (loop for index from (1- (length string)) downto 0 |
44 | when (equal (aref string index) char) return index | |
45 | finally return nil)) | |
46 | ||
cee9f5c6 BW |
47 | \f |
48 | ||
dda00b2c | 49 | ;;; General Utilities |
c26cf6c8 | 50 | |
dda00b2c BW |
51 | ;;;###mh-autoload |
52 | (defun mh-beginning-of-word (&optional n) | |
53 | "Return position of the N th word backwards." | |
54 | (unless n (setq n 1)) | |
55 | (let ((syntax-table (syntax-table))) | |
56 | (unwind-protect | |
57 | (save-excursion | |
06e7028b | 58 | (mh-mail-abbrev-make-syntax-table) |
dda00b2c BW |
59 | (set-syntax-table mail-abbrev-syntax-table) |
60 | (backward-word n) | |
61 | (point)) | |
62 | (set-syntax-table syntax-table)))) | |
63 | ||
64 | ;;;###mh-autoload | |
65 | (defun mh-colors-available-p () | |
66 | "Check if colors are available in the Emacs being used." | |
a3269bc4 | 67 | (or (featurep 'xemacs) |
d5dc8c56 | 68 | (let ((color-cells (mh-display-color-cells))) |
dda00b2c BW |
69 | (and (numberp color-cells) (>= color-cells 8))))) |
70 | ||
71 | ;;;###mh-autoload | |
72 | (defun mh-colors-in-use-p () | |
73 | "Check if colors are being used in the folder buffer." | |
74 | (and mh-colors-available-flag font-lock-mode)) | |
75 | ||
76 | ;;;###mh-autoload | |
77 | (defun mh-delete-line (lines) | |
78 | "Delete the next LINES lines." | |
79 | (delete-region (point) (progn (forward-line lines) (point)))) | |
a1b4049d | 80 | |
dda00b2c BW |
81 | ;;;###mh-autoload |
82 | (defun mh-make-local-vars (&rest pairs) | |
83 | "Initialize local variables according to the variable-value PAIRS." | |
84 | (while pairs | |
85 | (set (make-local-variable (car pairs)) (car (cdr pairs))) | |
86 | (setq pairs (cdr (cdr pairs))))) | |
87 | ||
88 | ;;;###mh-autoload | |
89 | (defun mh-mapc (function list) | |
90 | "Apply FUNCTION to each element of LIST for side effects only." | |
91 | (while list | |
92 | (funcall function (car list)) | |
93 | (setq list (cdr list)))) | |
94 | ||
052df334 BW |
95 | (defvar mh-pick-regexp-chars ".*$[" |
96 | "List of special characters in pick regular expressions.") | |
97 | ||
98 | ;;;###mh-autoload | |
99 | (defun mh-quote-pick-expr (pick-expr) | |
100 | "Quote `mh-pick-regexp-chars' in PICK-EXPR. | |
101 | PICK-EXPR is a list of strings. Return nil if PICK-EXPR is nil." | |
102 | (let ((quoted-pick-expr)) | |
103 | (dolist (string pick-expr) | |
104 | (when (and string | |
105 | (not (string-equal string ""))) | |
106 | (loop for i from 0 to (1- (length mh-pick-regexp-chars)) do | |
107 | (let ((s (string ?\\ (aref mh-pick-regexp-chars i)))) | |
108 | (setq string (mh-replace-regexp-in-string s s string t t)))) | |
109 | (setq quoted-pick-expr (append quoted-pick-expr (list string))))) | |
110 | quoted-pick-expr)) | |
111 | ||
dda00b2c BW |
112 | ;;;###mh-autoload |
113 | (defun mh-replace-string (old new) | |
114 | "Replace all occurrences of OLD with NEW in the current buffer. | |
115 | Ignores case when searching for OLD." | |
116 | (goto-char (point-min)) | |
117 | (let ((case-fold-search t)) | |
118 | (while (search-forward old nil t) | |
119 | (replace-match new t t)))) | |
c26cf6c8 | 120 | |
cee9f5c6 BW |
121 | \f |
122 | ||
dda00b2c | 123 | ;;; Logo Display |
bdcfe844 | 124 | |
3d7ca223 BW |
125 | (defvar mh-logo-cache nil) |
126 | ||
f875b154 BW |
127 | ;; Shush compiler. |
128 | (defvar image-load-path) | |
129 | ||
dda00b2c | 130 | ;;;###mh-autoload |
3d7ca223 BW |
131 | (defun mh-logo-display () |
132 | "Modify mode line to display MH-E logo." | |
924df208 | 133 | (mh-do-in-gnu-emacs |
44e3f440 | 134 | (let* ((load-path (mh-image-load-path-for-library "mh-e" "mh-logo.xpm")) |
f875b154 BW |
135 | (image-load-path (cons (car load-path) |
136 | (when (boundp 'image-load-path) | |
137 | image-load-path)))) | |
efc27af6 BW |
138 | (add-text-properties |
139 | 0 2 | |
140 | `(display ,(or mh-logo-cache | |
141 | (setq mh-logo-cache | |
142 | (mh-funcall-if-exists | |
143 | find-image '((:type xpm :ascent center | |
144 | :file "mh-logo.xpm")))))) | |
145 | (car mode-line-buffer-identification)))) | |
924df208 | 146 | (mh-do-in-xemacs |
efc27af6 BW |
147 | (setq modeline-buffer-identification |
148 | (list | |
149 | (if mh-modeline-glyph | |
150 | (cons modeline-buffer-id-left-extent mh-modeline-glyph) | |
151 | (cons modeline-buffer-id-left-extent "XEmacs%N:")) | |
152 | (cons modeline-buffer-id-right-extent " %17b"))))) | |
924df208 | 153 | |
dda00b2c | 154 | \f |
d1699462 | 155 | |
dda00b2c BW |
156 | ;;; Read MH Profile |
157 | ||
158 | (defvar mh-find-path-run nil | |
159 | "Non-nil if `mh-find-path' has been run already. | |
160 | Do not access this variable; `mh-find-path' already uses it to | |
161 | avoid running more than once.") | |
162 | ||
163 | ;;;###mh-autoload | |
164 | (defun mh-find-path () | |
165 | "Set variables from user's MH profile. | |
166 | ||
167 | This function sets `mh-user-path' from your \"Path:\" MH profile | |
168 | component (but defaults to \"Mail\" if one isn't present), | |
169 | `mh-draft-folder' from \"Draft-Folder:\", `mh-unseen-seq' from | |
170 | \"Unseen-Sequence:\", `mh-previous-seq' from | |
171 | \"Previous-Sequence:\", and `mh-inbox' from \"Inbox:\" (defaults | |
172 | to \"+inbox\"). | |
173 | ||
174 | The hook `mh-find-path-hook' is run after these variables have | |
175 | been set. This hook can be used the change the value of these | |
176 | variables if you need to run with different values between MH and | |
177 | MH-E." | |
178 | (unless mh-find-path-run | |
179 | ;; Sanity checks. | |
180 | (if (and (getenv "MH") | |
181 | (not (file-readable-p (getenv "MH")))) | |
182 | (error "MH environment variable contains unreadable file %s" | |
183 | (getenv "MH"))) | |
184 | (if (null (mh-variants)) | |
185 | (error "Install MH and run install-mh before running MH-E")) | |
b78a11dc BW |
186 | (if (not (or (getenv "MH") (file-readable-p "~/.mh_profile"))) |
187 | (error "Run install-mh before running MH-E")) | |
dda00b2c BW |
188 | ;; Read MH profile. |
189 | (setq mh-user-path (mh-profile-component "Path")) | |
190 | (if (not mh-user-path) | |
191 | (setq mh-user-path "Mail")) | |
192 | (setq mh-user-path | |
193 | (file-name-as-directory | |
194 | (expand-file-name mh-user-path (expand-file-name "~")))) | |
195 | (mh-set-x-image-cache-directory (expand-file-name ".mhe-x-image-cache" | |
196 | mh-user-path)) | |
197 | (setq mh-draft-folder (mh-profile-component "Draft-Folder")) | |
198 | (if mh-draft-folder | |
199 | (progn | |
200 | (if (not (mh-folder-name-p mh-draft-folder)) | |
201 | (setq mh-draft-folder (format "+%s" mh-draft-folder))) | |
202 | (if (not (file-exists-p (mh-expand-file-name mh-draft-folder))) | |
203 | (error | |
204 | "Draft folder \"%s\" not found; create it and try again" | |
205 | (mh-expand-file-name mh-draft-folder))))) | |
206 | (setq mh-inbox (mh-profile-component "Inbox")) | |
207 | (cond ((not mh-inbox) | |
208 | (setq mh-inbox "+inbox")) | |
209 | ((not (mh-folder-name-p mh-inbox)) | |
210 | (setq mh-inbox (format "+%s" mh-inbox)))) | |
211 | (setq mh-unseen-seq (mh-profile-component "Unseen-Sequence")) | |
212 | (if mh-unseen-seq | |
213 | (setq mh-unseen-seq (intern mh-unseen-seq)) | |
214 | (setq mh-unseen-seq 'unseen)) ;old MH default? | |
215 | (setq mh-previous-seq (mh-profile-component "Previous-Sequence")) | |
216 | (if mh-previous-seq | |
217 | (setq mh-previous-seq (intern mh-previous-seq))) | |
218 | (run-hooks 'mh-find-path-hook) | |
219 | (mh-collect-folder-names) | |
220 | (setq mh-find-path-run t))) | |
b6d4ab05 | 221 | |
dda00b2c | 222 | \f |
b6d4ab05 | 223 | |
dda00b2c | 224 | ;;; Help Functions |
b6d4ab05 | 225 | |
dda00b2c BW |
226 | ;;;###mh-autoload |
227 | (defun mh-ephem-message (string) | |
228 | "Display STRING in the minibuffer momentarily." | |
229 | (message "%s" string) | |
230 | (sit-for 5) | |
231 | (message "")) | |
c26cf6c8 | 232 | |
dda00b2c BW |
233 | (defvar mh-help-default nil |
234 | "Mode to use if messages are not present for the current mode.") | |
cee9f5c6 | 235 | |
dda00b2c BW |
236 | (defvar mh-help-messages nil |
237 | "Help messages for all modes. | |
238 | This is an alist of alists. The primary key is a symbol | |
239 | representing the mode; the value is described in `mh-set-help'.") | |
240 | ||
241 | ;;;###mh-autoload | |
242 | (defun mh-set-help (messages &optional default) | |
243 | "Set help messages. | |
244 | ||
245 | The MESSAGES are assumed to be an associative array. It is used | |
246 | to show help for the most common commands in the current mode. | |
247 | The key is a prefix char. The value is one or more strings which | |
248 | are concatenated together and displayed in a help buffer if ? is | |
249 | pressed after the prefix character. The special key nil is used | |
250 | to display the non-prefixed commands. | |
251 | ||
252 | The substitutions described in `substitute-command-keys' are performed as | |
253 | well. | |
254 | ||
255 | If optional argument DEFAULT is non-nil, then these messages will | |
256 | be used if help is asked for an unknown mode." | |
257 | (add-to-list 'mh-help-messages (cons major-mode messages)) | |
258 | (if default | |
259 | (setq mh-help-default major-mode))) | |
260 | ||
261 | ;;;###mh-autoload | |
262 | (defun mh-help (&optional help-messages) | |
263 | "Display cheat sheet for the MH-E commands. | |
264 | See `mh-set-help' for setting the help messages. | |
265 | HELP-MESSAGES are used instead if given. | |
266 | This is a list of one or more strings which are concatenated together | |
267 | and displayed in a help buffer." | |
268 | (interactive) | |
269 | (let* ((help (or help-messages | |
270 | (cdr (assoc nil (assoc major-mode mh-help-messages))))) | |
271 | (text (substitute-command-keys (mapconcat 'identity help "")))) | |
272 | (with-electric-help | |
273 | (function | |
274 | (lambda () | |
275 | (insert text))) | |
276 | mh-help-buffer))) | |
277 | ||
278 | ;;;###mh-autoload | |
279 | (defun mh-prefix-help () | |
280 | "Display cheat sheet for the commands of the current prefix in minibuffer." | |
281 | (interactive) | |
282 | ;; We got here because the user pressed a "?", but he pressed a prefix key | |
b4dc7d98 | 283 | ;; before that. Since the key vector starts at index 0, the index of the |
dda00b2c BW |
284 | ;; last keystroke is length-1 and thus the second to last keystroke is at |
285 | ;; length-2. We use that information to obtain a suitable prefix character | |
286 | ;; from the recent keys. | |
287 | (let* ((keys (recent-keys)) | |
288 | (prefix-char (elt keys (- (length keys) 2))) | |
289 | (help (cdr (assoc prefix-char (assoc major-mode mh-help-messages))))) | |
290 | (mh-help help))) | |
a1506d29 | 291 | |
dda00b2c BW |
292 | \f |
293 | ||
294 | ;;; Message Number Utilities | |
295 | ||
296 | ;;;###mh-autoload | |
297 | (defun mh-coalesce-msg-list (messages) | |
298 | "Given a list of MESSAGES, return a list of message number ranges. | |
299 | This is the inverse of `mh-read-msg-list', which expands ranges. | |
300 | Message lists passed to MH programs should be processed by this | |
301 | function to avoid exceeding system command line argument limits." | |
302 | (let ((msgs (sort (copy-sequence messages) 'mh-greaterp)) | |
303 | (range-high nil) | |
304 | (prev -1) | |
305 | (ranges nil)) | |
306 | (while prev | |
307 | (if range-high | |
308 | (if (or (not (numberp prev)) | |
309 | (not (equal (car msgs) (1- prev)))) | |
310 | (progn ;non-sequential, flush old range | |
311 | (if (eq prev range-high) | |
312 | (setq ranges (cons range-high ranges)) | |
313 | (setq ranges (cons (format "%s-%s" prev range-high) ranges))) | |
314 | (setq range-high nil)))) | |
315 | (or range-high | |
316 | (setq range-high (car msgs))) ;start new or first range | |
317 | (setq prev (car msgs)) | |
318 | (setq msgs (cdr msgs))) | |
319 | ranges)) | |
320 | ||
321 | (defun mh-greaterp (msg1 msg2) | |
322 | "Return the greater of two message indicators MSG1 and MSG2. | |
323 | Strings are \"smaller\" than numbers. | |
324 | Valid values are things like \"cur\", \"last\", 1, and 1820." | |
325 | (if (numberp msg1) | |
326 | (if (numberp msg2) | |
327 | (> msg1 msg2) | |
328 | t) | |
329 | (if (numberp msg2) | |
330 | nil | |
331 | (string-lessp msg2 msg1)))) | |
332 | ||
333 | ;;;###mh-autoload | |
334 | (defun mh-lessp (msg1 msg2) | |
335 | "Return the lesser of two message indicators MSG1 and MSG2. | |
336 | Strings are \"smaller\" than numbers. | |
337 | Valid values are things like \"cur\", \"last\", 1, and 1820." | |
338 | (not (mh-greaterp msg1 msg2))) | |
339 | ||
340 | ;;;###mh-autoload | |
bdcfe844 BW |
341 | (defun mh-get-msg-num (error-if-no-message) |
342 | "Return the message number of the displayed message. | |
2dcf34f9 BW |
343 | If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if |
344 | the cursor is not pointing to a message." | |
bdcfe844 BW |
345 | (save-excursion |
346 | (beginning-of-line) | |
dda00b2c | 347 | (cond ((looking-at (mh-scan-msg-number-regexp)) |
e495eaec BW |
348 | (string-to-number (buffer-substring (match-beginning 1) |
349 | (match-end 1)))) | |
c3d9274a BW |
350 | (error-if-no-message |
351 | (error "Cursor not pointing to message")) | |
352 | (t nil)))) | |
bdcfe844 | 353 | |
dda00b2c | 354 | (add-to-list 'debug-ignored-errors "^Cursor not pointing to message$") |
924df208 BW |
355 | |
356 | \f | |
357 | ||
dda00b2c | 358 | ;;; Folder Cache and Access |
c26cf6c8 | 359 | |
3d7ca223 | 360 | (defvar mh-sub-folders-cache (make-hash-table :test #'equal)) |
924df208 | 361 | (defvar mh-current-folder-name nil) |
a66894d8 BW |
362 | (defvar mh-flists-partial-line "") |
363 | (defvar mh-flists-process nil) | |
364 | ||
dda00b2c BW |
365 | ;;;###mh-autoload |
366 | (defun mh-clear-sub-folders-cache () | |
367 | "Clear `mh-sub-folders-cache'." | |
368 | (clrhash mh-sub-folders-cache)) | |
369 | ||
a66894d8 BW |
370 | ;; Initialize mh-sub-folders-cache... |
371 | (defun mh-collect-folder-names () | |
11db987f | 372 | "Collect folder names by running \"folders\"." |
a66894d8 BW |
373 | (unless mh-flists-process |
374 | (setq mh-flists-process | |
375 | (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter | |
376 | "-recurse" "-fast")))) | |
377 | ||
378 | (defun mh-collect-folder-names-filter (process output) | |
379 | "Read folder names. | |
2dcf34f9 BW |
380 | PROCESS is the flists process that was run to collect folder |
381 | names and the function is called when OUTPUT is available." | |
a66894d8 | 382 | (let ((position 0) |
dda00b2c BW |
383 | (prevailing-match-data (match-data)) |
384 | line-end folder) | |
a66894d8 | 385 | (unwind-protect |
dda00b2c BW |
386 | (while (setq line-end (string-match "\n" output position)) |
387 | (setq folder (format "+%s%s" | |
a66894d8 BW |
388 | mh-flists-partial-line |
389 | (substring output position line-end))) | |
dda00b2c | 390 | (setq mh-flists-partial-line "") |
a66894d8 BW |
391 | (unless (equal (aref folder 1) ?.) |
392 | (mh-populate-sub-folders-cache folder)) | |
dda00b2c | 393 | (setq position (1+ line-end))) |
a66894d8 BW |
394 | (set-match-data prevailing-match-data)) |
395 | (setq mh-flists-partial-line (substring output position)))) | |
396 | ||
397 | (defun mh-populate-sub-folders-cache (folder) | |
398 | "Tell `mh-sub-folders-cache' about FOLDER." | |
399 | (let* ((last-slash (mh-search-from-end ?/ folder)) | |
400 | (child1 (substring folder (1+ (or last-slash 0)))) | |
401 | (parent (and last-slash (substring folder 0 last-slash))) | |
402 | (parent-slash (and parent (mh-search-from-end ?/ parent))) | |
403 | (child2 (and parent (substring parent (1+ (or parent-slash 0))))) | |
404 | (grand-parent (and parent-slash (substring parent 0 parent-slash))) | |
405 | (cache-entry (gethash parent mh-sub-folders-cache))) | |
406 | (unless (loop for x in cache-entry when (equal (car x) child1) return t | |
407 | finally return nil) | |
408 | (push (list child1) cache-entry) | |
409 | (setf (gethash parent mh-sub-folders-cache) | |
410 | (sort cache-entry (lambda (x y) (string< (car x) (car y))))) | |
411 | (when parent | |
412 | (loop for x in (gethash grand-parent mh-sub-folders-cache) | |
413 | when (equal (car x) child2) | |
414 | do (progn (setf (cdr x) t) (return))))))) | |
3d7ca223 BW |
415 | |
416 | (defun mh-normalize-folder-name (folder &optional empty-string-okay | |
c80658b7 BW |
417 | dont-remove-trailing-slash |
418 | return-nil-if-folder-empty) | |
3d7ca223 | 419 | "Normalizes FOLDER name. |
3d7ca223 | 420 | |
2dcf34f9 BW |
421 | Makes sure that two '/' characters never occur next to each |
422 | other. Also all occurrences of \"..\" and \".\" are suitably | |
423 | processed. So \"+inbox/../news\" will be normalized to \"+news\". | |
3d7ca223 | 424 | |
2dcf34f9 BW |
425 | If optional argument EMPTY-STRING-OKAY is nil then a '+' is added |
426 | at the front if FOLDER lacks one. If non-nil and FOLDER is the | |
427 | empty string then nothing is added. | |
428 | ||
429 | If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a | |
430 | trailing '/' if present is retained (if present), otherwise it is | |
c80658b7 BW |
431 | removed. |
432 | ||
433 | If optional argument RETURN-NIL-IF-FOLDER-EMPTY is non-nil, then | |
434 | return nil if FOLDER is \"\" or \"+\". This is useful when | |
435 | normalizing the folder for the \"folders\" command which displays | |
436 | the directories in / if passed \"+\". This is usually not | |
437 | desired. If this argument is non-nil, then EMPTY-STRING-OKAY has | |
438 | no effect." | |
439 | (cond | |
440 | ((if (and (or (equal folder "+") (equal folder "")) | |
441 | return-nil-if-folder-empty) | |
442 | (setq folder nil))) | |
443 | ((stringp folder) | |
3d7ca223 BW |
444 | ;; Replace two or more consecutive '/' characters with a single '/' |
445 | (while (string-match "//" folder) | |
446 | (setq folder (replace-match "/" nil t folder))) | |
447 | (let* ((length (length folder)) | |
448 | (trailing-slash-present (and (> length 0) | |
924df208 BW |
449 | (equal (aref folder (1- length)) ?/))) |
450 | (leading-slash-present (and (> length 0) | |
451 | (equal (aref folder 0) ?/)))) | |
452 | (when (and (> length 0) (equal (aref folder 0) ?@) | |
453 | (stringp mh-current-folder-name)) | |
454 | (setq folder (format "%s/%s/" mh-current-folder-name | |
455 | (substring folder 1)))) | |
c80658b7 BW |
456 | ;; XXX: Purge empty strings from the list that split-string |
457 | ;; returns. In XEmacs, (split-string "+foo/" "/") returns | |
458 | ;; ("+foo" "") while in GNU Emacs it returns ("+foo"). In the | |
459 | ;; code it is assumed that the components list has no empty | |
460 | ;; strings. | |
924df208 | 461 | (let ((components (delete "" (split-string folder "/"))) |
3d7ca223 BW |
462 | (result ())) |
463 | ;; Remove .. and . from the pathname. | |
464 | (dolist (component components) | |
465 | (cond ((and (equal component "..") result) | |
466 | (pop result)) | |
467 | ((equal component "..")) | |
468 | ((equal component ".")) | |
469 | (t (push component result)))) | |
470 | (setq folder "") | |
471 | (dolist (component result) | |
472 | (setq folder (concat component "/" folder))) | |
473 | ;; Remove trailing '/' if needed. | |
474 | (unless (and trailing-slash-present dont-remove-trailing-slash) | |
475 | (when (not (equal folder "")) | |
924df208 BW |
476 | (setq folder (substring folder 0 (1- (length folder)))))) |
477 | (when leading-slash-present | |
478 | (setq folder (concat "/" folder))))) | |
3d7ca223 | 479 | (cond ((and empty-string-okay (equal folder ""))) |
c80658b7 BW |
480 | ((equal folder "") |
481 | (setq folder "+")) | |
482 | ((not (equal (aref folder 0) ?+)) | |
483 | (setq folder (concat "+" folder)))))) | |
3d7ca223 BW |
484 | folder) |
485 | ||
11db987f BW |
486 | (defmacro mh-children-p (folder) |
487 | "Return t if FOLDER from sub-folders cache has children. | |
488 | The car of folder is the name, and the cdr is either t or some | |
489 | sort of count that I do not understand. It's too small to be the | |
490 | number of messages in the sub-folders and too large to be the | |
491 | number of sub-folders. XXX" | |
492 | `(if (cdr ,folder) | |
493 | t | |
494 | nil)) | |
495 | ||
dda00b2c | 496 | ;;;###mh-autoload |
11db987f BW |
497 | (defun mh-folder-list (folder) |
498 | "Return FOLDER and its descendents. | |
898dda92 BW |
499 | FOLDER may have a + prefix. Returns a list of strings without the |
500 | + prefix. If FOLDER is nil, then all folders are considered. For | |
501 | example, if your Mail directory only contains the folders +inbox, | |
502 | +outbox, +lists, and +lists/mh-e, then | |
503 | ||
504 | (mh-folder-list nil) | |
505 | => (\"inbox\" \"lists\" \"lists/mh-e\" \"outbox\") | |
506 | (mh-folder-list \"+lists\") | |
2044e8f1 | 507 | => (\"lists\" \"lists/mh-e\") |
898dda92 BW |
508 | |
509 | Respects the value of `mh-recursive-folders-flag'. If this flag | |
510 | is nil, and the sub-folders have not been explicitly viewed, then | |
511 | they will not be returned." | |
11db987f | 512 | (let ((folder-list)) |
c80658b7 BW |
513 | ;; Normalize folder. Strip leading + and trailing slash(es). If no |
514 | ;; folder is specified, ensure it is nil to avoid adding the | |
515 | ;; folder to the folder-list and adding a slash to it. | |
11db987f | 516 | (when folder |
d5dc8c56 | 517 | (setq folder (mh-replace-regexp-in-string "^\+" "" folder)) |
c80658b7 BW |
518 | (setq folder (mh-replace-regexp-in-string "/+$" "" folder)) |
519 | (if (equal folder "") | |
520 | (setq folder nil))) | |
898dda92 | 521 | ;; Add provided folder to list, unless all folders are asked for. |
c80658b7 | 522 | ;; Then append slash to separate sub-folders. |
898dda92 | 523 | (unless (null folder) |
c80658b7 BW |
524 | (setq folder-list (list folder)) |
525 | (setq folder (concat folder "/"))) | |
11db987f | 526 | (loop for f in (mh-sub-folders folder) do |
898dda92 BW |
527 | (setq folder-list |
528 | (append folder-list | |
529 | (if (mh-children-p f) | |
c80658b7 BW |
530 | (mh-folder-list (concat folder (car f))) |
531 | (list (concat folder (car f))))))) | |
11db987f BW |
532 | folder-list)) |
533 | ||
dda00b2c | 534 | ;;;###mh-autoload |
3d7ca223 BW |
535 | (defun mh-sub-folders (folder &optional add-trailing-slash-flag) |
536 | "Find the subfolders of FOLDER. | |
2dcf34f9 BW |
537 | The function avoids running folders unnecessarily by caching the |
538 | results of the actual folders call. | |
3d7ca223 | 539 | |
2dcf34f9 BW |
540 | If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a |
541 | slash is added to each of the sub-folder names that may have | |
542 | nested folders within them." | |
c80658b7 | 543 | (let* ((folder (mh-normalize-folder-name folder nil nil t)) |
3d7ca223 BW |
544 | (match (gethash folder mh-sub-folders-cache 'no-result)) |
545 | (sub-folders (cond ((eq match 'no-result) | |
546 | (setf (gethash folder mh-sub-folders-cache) | |
547 | (mh-sub-folders-actual folder))) | |
548 | (t match)))) | |
549 | (if add-trailing-slash-flag | |
550 | (mapcar #'(lambda (x) | |
551 | (if (cdr x) (cons (concat (car x) "/") (cdr x)) x)) | |
552 | sub-folders) | |
553 | sub-folders))) | |
554 | ||
cd35b20a BW |
555 | ;; FIXME: This function does not do well if FOLDER does not exist. It |
556 | ;; then changes the context to that folder which causes problems down | |
557 | ;; the line. Since a folder in the cache could later be deleted, it | |
558 | ;; would be good for mh-sub-folders-actual to return nil in this case | |
559 | ;; so that mh-sub-folders could delete it from the cache. This | |
560 | ;; function could protect itself by using a temporary context. | |
3d7ca223 BW |
561 | (defun mh-sub-folders-actual (folder) |
562 | "Execute the command folders to return the sub-folders of FOLDER. | |
2dcf34f9 | 563 | Filters out the folder names that start with \".\" so that |
cd35b20a BW |
564 | directories that aren't usually mail folders are hidden. |
565 | Expects FOLDER to have already been normalized with | |
566 | (mh-normalize-folder-name folder nil nil t)" | |
3d7ca223 BW |
567 | (let ((arg-list `(,(expand-file-name "folders" mh-progs) |
568 | nil (t nil) nil "-noheader" "-norecurse" "-nototal" | |
569 | ,@(if (stringp folder) (list folder) ()))) | |
570 | (results ()) | |
571 | (current-folder (concat | |
572 | (with-temp-buffer | |
573 | (call-process (expand-file-name "folder" mh-progs) | |
574 | nil '(t nil) nil "-fast") | |
575 | (buffer-substring (point-min) (1- (point-max)))) | |
576 | "+"))) | |
577 | (with-temp-buffer | |
578 | (apply #'call-process arg-list) | |
579 | (goto-char (point-min)) | |
580 | (while (not (and (eolp) (bolp))) | |
d5dc8c56 BW |
581 | (goto-char (mh-line-end-position)) |
582 | (let ((start-pos (mh-line-beginning-position)) | |
583 | (has-pos (search-backward " has " | |
584 | (mh-line-beginning-position) t))) | |
3d7ca223 BW |
585 | (when (integerp has-pos) |
586 | (while (equal (char-after has-pos) ? ) | |
587 | (decf has-pos)) | |
588 | (incf has-pos) | |
f0d73c14 BW |
589 | (while (equal (char-after start-pos) ? ) |
590 | (incf start-pos)) | |
591 | (let* ((name (buffer-substring start-pos has-pos)) | |
3d7ca223 BW |
592 | (first-char (aref name 0)) |
593 | (last-char (aref name (1- (length name))))) | |
594 | (unless (member first-char '(?. ?# ?,)) | |
595 | (when (and (equal last-char ?+) (equal name current-folder)) | |
596 | (setq name (substring name 0 (1- (length name))))) | |
597 | (push | |
598 | (cons name | |
d5dc8c56 | 599 | (search-forward "(others)" (mh-line-end-position) t)) |
3d7ca223 BW |
600 | results)))) |
601 | (forward-line 1)))) | |
602 | (setq results (nreverse results)) | |
603 | (when (stringp folder) | |
604 | (setq results (cdr results)) | |
605 | (let ((folder-name-len (length (format "%s/" (substring folder 1))))) | |
606 | (setq results (mapcar (lambda (f) | |
607 | (cons (substring (car f) folder-name-len) | |
608 | (cdr f))) | |
609 | results)))) | |
610 | results)) | |
611 | ||
dda00b2c | 612 | ;;;###mh-autoload |
3d7ca223 BW |
613 | (defun mh-remove-from-sub-folders-cache (folder) |
614 | "Remove FOLDER and its parent from `mh-sub-folders-cache'. | |
2dcf34f9 BW |
615 | FOLDER should be unconditionally removed from the cache. Also the |
616 | last ancestor of FOLDER present in the cache must be removed as | |
617 | well. | |
618 | ||
619 | To see why this is needed assume we have a folder +foo which has | |
620 | a single sub-folder qux. Now we create the folder +foo/bar/baz. | |
621 | Here we will need to invalidate the cached sub-folders of +foo, | |
622 | otherwise completion on +foo won't tell us about the option | |
623 | +foo/bar!" | |
3d7ca223 BW |
624 | (remhash folder mh-sub-folders-cache) |
625 | (block ancestor-found | |
626 | (let ((parent folder) | |
627 | (one-ancestor-found nil) | |
628 | last-slash) | |
629 | (while (setq last-slash (mh-search-from-end ?/ parent)) | |
630 | (setq parent (substring parent 0 last-slash)) | |
631 | (unless (eq (gethash parent mh-sub-folders-cache 'none) 'none) | |
632 | (remhash parent mh-sub-folders-cache) | |
633 | (if one-ancestor-found | |
634 | (return-from ancestor-found) | |
635 | (setq one-ancestor-found t)))) | |
636 | (remhash nil mh-sub-folders-cache)))) | |
637 | ||
dda00b2c BW |
638 | \f |
639 | ||
640 | ;;; Folder Utilities | |
641 | ||
642 | ;;;###mh-autoload | |
643 | (defun mh-folder-name-p (name) | |
644 | "Return non-nil if NAME is the name of a folder. | |
645 | A name (a string or symbol) can be a folder name if it begins | |
646 | with \"+\"." | |
647 | (if (symbolp name) | |
648 | (eq (aref (symbol-name name) 0) ?+) | |
649 | (and (> (length name) 0) | |
650 | (eq (aref name 0) ?+)))) | |
651 | ||
652 | ;;;###mh-autoload | |
653 | (defun mh-expand-file-name (filename &optional default) | |
654 | "Expand FILENAME like `expand-file-name', but also handle MH folder names. | |
655 | Any filename that starts with '+' is treated as a folder name. | |
656 | See `expand-file-name' for description of DEFAULT." | |
657 | (if (mh-folder-name-p filename) | |
658 | (expand-file-name (substring filename 1) mh-user-path) | |
659 | (expand-file-name filename default))) | |
660 | ||
bdcfe844 | 661 | (defvar mh-folder-hist nil) |
7094eefe BW |
662 | |
663 | ;; Shush compiler. | |
73e6d1af | 664 | (defvar mh-speed-flists-cache) |
924df208 BW |
665 | |
666 | (defvar mh-allow-root-folder-flag nil | |
667 | "Non-nil means \"+\" is an acceptable folder name. | |
2dcf34f9 BW |
668 | This variable is used to communicate with |
669 | `mh-folder-completion-function'. That function can have exactly | |
670 | three arguments so we bind this variable to t or nil. | |
924df208 BW |
671 | |
672 | This variable should never be set.") | |
673 | ||
3d7ca223 | 674 | (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map)) |
2bd87afb | 675 | (define-key mh-folder-completion-map " " 'minibuffer-complete) ;Why??? |
3d7ca223 | 676 | |
a66894d8 BW |
677 | (defvar mh-speed-flists-inhibit-flag nil) |
678 | ||
dda00b2c | 679 | ;;;###mh-autoload |
924df208 BW |
680 | (defun mh-speed-flists-active-p () |
681 | "Check if speedbar is running with message counts enabled." | |
682 | (and (featurep 'mh-speed) | |
a66894d8 | 683 | (not mh-speed-flists-inhibit-flag) |
924df208 BW |
684 | (> (hash-table-count mh-speed-flists-cache) 0))) |
685 | ||
dda00b2c | 686 | ;;;###mh-autoload |
3d7ca223 BW |
687 | (defun mh-folder-completion-function (name predicate flag) |
688 | "Programmable completion for folder names. | |
2dcf34f9 | 689 | NAME is the partial folder name that has been input. PREDICATE if |
cd35b20a BW |
690 | non-nil is a function that is used to filter the possible |
691 | choices. FLAG is nil to indicate `try-completion', t for | |
692 | `all-completions', or the symbol lambda for `test-completion'. | |
693 | See Info node `(elisp) Programmed Completion' for details." | |
3d7ca223 | 694 | (let* ((orig-name name) |
cd35b20a BW |
695 | ;; After normalization, name is nil, +, or +something. If a |
696 | ;; trailing slash is present, it is preserved. | |
3d7ca223 BW |
697 | (name (mh-normalize-folder-name name nil t)) |
698 | (last-slash (mh-search-from-end ?/ name)) | |
cd35b20a BW |
699 | ;; nil if + or +folder; +folder/ if slash present. |
700 | (last-complete (if last-slash (substring name 0 (1+ last-slash)) nil)) | |
701 | ;; Either +folder/remainder, +remainder, or "". | |
3d7ca223 | 702 | (remainder (cond (last-complete (substring name (1+ last-slash))) |
cd35b20a | 703 | (name (substring name 1)) |
3d7ca223 BW |
704 | (t "")))) |
705 | (cond ((eq flag nil) | |
cd35b20a BW |
706 | (let ((try-res |
707 | (try-completion | |
708 | name | |
709 | (mapcar (lambda (x) | |
710 | (cons (concat (or last-complete "+") (car x)) | |
711 | (cdr x))) | |
712 | (mh-sub-folders last-complete t)) | |
713 | predicate))) | |
3d7ca223 BW |
714 | (cond ((eq try-res nil) nil) |
715 | ((and (eq try-res t) (equal name orig-name)) t) | |
716 | ((eq try-res t) name) | |
717 | (t try-res)))) | |
718 | ((eq flag t) | |
cd35b20a BW |
719 | (mapcar (lambda (x) |
720 | (concat (or last-complete "+") x)) | |
721 | (all-completions | |
722 | remainder (mh-sub-folders last-complete t) predicate))) | |
3d7ca223 | 723 | ((eq flag 'lambda) |
cd35b20a BW |
724 | (let ((path (concat (unless (and (> (length name) 1) |
725 | (eq (aref name 1) ?/)) | |
726 | mh-user-path) | |
727 | (substring name 1)))) | |
924df208 BW |
728 | (cond (mh-allow-root-folder-flag (file-exists-p path)) |
729 | ((equal path mh-user-path) nil) | |
730 | (t (file-exists-p path)))))))) | |
731 | ||
dda00b2c | 732 | ;; Shush compiler. |
42f8c37f BW |
733 | (defvar completion-root-regexp) ; XEmacs |
734 | (defvar minibuffer-completing-file-name) ; XEmacs | |
dda00b2c | 735 | |
924df208 BW |
736 | (defun mh-folder-completing-read (prompt default allow-root-folder-flag) |
737 | "Read folder name with PROMPT and default result DEFAULT. | |
2dcf34f9 BW |
738 | If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be |
739 | a folder name corresponding to `mh-user-path'." | |
3d7ca223 | 740 | (mh-normalize-folder-name |
cd35b20a | 741 | (let ((completion-root-regexp "^[+/]") |
f0d73c14 | 742 | (minibuffer-local-completion-map mh-folder-completion-map) |
924df208 | 743 | (mh-allow-root-folder-flag allow-root-folder-flag)) |
3d7ca223 BW |
744 | (completing-read prompt 'mh-folder-completion-function nil nil nil |
745 | 'mh-folder-hist default)) | |
746 | t)) | |
bdcfe844 | 747 | |
dda00b2c | 748 | ;;;###mh-autoload |
bdcfe844 | 749 | (defun mh-prompt-for-folder (prompt default can-create |
3d7ca223 | 750 | &optional default-string allow-root-folder-flag) |
bdcfe844 | 751 | "Prompt for a folder name with PROMPT. |
2dcf34f9 BW |
752 | Returns the folder's name as a string. DEFAULT is used if the |
753 | folder exists and the user types return. If the CAN-CREATE flag | |
754 | is t, then a folder is created if it doesn't already exist. If | |
755 | optional argument DEFAULT-STRING is non-nil, use it in the prompt | |
756 | instead of DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is non-nil then the | |
757 | function will accept the folder +, which means all folders when | |
758 | used in searching." | |
c26cf6c8 RS |
759 | (if (null default) |
760 | (setq default "")) | |
d88a70a0 | 761 | (let* ((default-string (cond (default-string (format " (default %s)" default-string)) |
f0d73c14 | 762 | ((equal "" default) "") |
d88a70a0 RF |
763 | (t (format " (default %s)" default)))) |
764 | (prompt (format "%s folder%s: " prompt default-string)) | |
924df208 | 765 | (mh-current-folder-name mh-current-folder) |
c3d9274a | 766 | read-name folder-name) |
924df208 BW |
767 | (while (and (setq read-name (mh-folder-completing-read |
768 | prompt default allow-root-folder-flag)) | |
c3d9274a BW |
769 | (equal read-name "") |
770 | (equal default ""))) | |
3d7ca223 BW |
771 | (cond ((or (equal read-name "") |
772 | (and (equal read-name "+") (not allow-root-folder-flag))) | |
c3d9274a BW |
773 | (setq read-name default)) |
774 | ((not (mh-folder-name-p read-name)) | |
775 | (setq read-name (format "+%s" read-name)))) | |
a1b4049d BW |
776 | (if (or (not read-name) (equal "" read-name)) |
777 | (error "No folder specified")) | |
c26cf6c8 RS |
778 | (setq folder-name read-name) |
779 | (cond ((and (> (length folder-name) 0) | |
c3d9274a BW |
780 | (eq (aref folder-name (1- (length folder-name))) ?/)) |
781 | (setq folder-name (substring folder-name 0 -1)))) | |
924df208 BW |
782 | (let* ((last-slash (mh-search-from-end ?/ folder-name)) |
783 | (parent (and last-slash (substring folder-name 0 last-slash))) | |
784 | (child (if last-slash | |
785 | (substring folder-name (1+ last-slash)) | |
786 | (substring folder-name 1)))) | |
787 | (unless (member child | |
788 | (mapcar #'car (gethash parent mh-sub-folders-cache))) | |
789 | (mh-remove-from-sub-folders-cache folder-name))) | |
bdcfe844 | 790 | (let ((new-file-flag |
c3d9274a | 791 | (not (file-exists-p (mh-expand-file-name folder-name))))) |
bdcfe844 | 792 | (cond ((and new-file-flag |
13fe29bd | 793 | can-create |
c3d9274a BW |
794 | (y-or-n-p |
795 | (format "Folder %s does not exist. Create it? " | |
796 | folder-name))) | |
797 | (message "Creating %s" folder-name) | |
bdcfe844 | 798 | (mh-exec-cmd-error nil "folder" folder-name) |
3d7ca223 | 799 | (mh-remove-from-sub-folders-cache folder-name) |
bdcfe844 BW |
800 | (when (boundp 'mh-speed-folder-map) |
801 | (mh-speed-add-folder folder-name)) | |
3d7ca223 | 802 | (message "Creating %s...done" folder-name)) |
c3d9274a | 803 | (new-file-flag |
13fe29bd | 804 | (error "Folder %s does not exist" folder-name)) |
c3d9274a | 805 | ((not (file-directory-p (mh-expand-file-name folder-name))) |
f9c53c97 | 806 | (error "%s is not a directory" |
3d7ca223 | 807 | (mh-expand-file-name folder-name))))) |
c26cf6c8 RS |
808 | folder-name)) |
809 | ||
cee9f5c6 BW |
810 | \f |
811 | ||
dda00b2c | 812 | ;;; Message Utilities |
c26cf6c8 | 813 | |
dda00b2c BW |
814 | ;; Functions that would ordinarily be in mh-letter.el that are needed |
815 | ;; by mh-show.el are found here in order to prevent the loading of | |
816 | ;; mh-letter.el until a message is actually composed. | |
817 | ||
818 | ;;;###mh-autoload | |
819 | (defun mh-in-header-p () | |
820 | "Return non-nil if the point is in the header of a draft message." | |
821 | (< (point) (mh-mail-header-end))) | |
822 | ||
823 | ;;;###mh-autoload | |
824 | (defun mh-extract-from-header-value () | |
825 | "Extract From: string from header." | |
826 | (save-excursion | |
827 | (if (not (mh-goto-header-field "From:")) | |
828 | nil | |
829 | (skip-chars-forward " \t") | |
830 | (buffer-substring-no-properties | |
831 | (point) (progn (mh-header-field-end)(point)))))) | |
832 | ||
a55f450f BW |
833 | ;;;###mh-autoload |
834 | (defun mh-get-header-field (field) | |
835 | "Find and return the body of FIELD in the mail header. | |
836 | Returns the empty string if the field is not in the header of the | |
837 | current buffer." | |
838 | (if (mh-goto-header-field field) | |
839 | (progn | |
840 | (skip-chars-forward " \t") ;strip leading white space in body | |
841 | (let ((start (point))) | |
842 | (mh-header-field-end) | |
843 | (buffer-substring-no-properties start (point)))) | |
844 | "")) | |
845 | ||
dda00b2c BW |
846 | ;;;###mh-autoload |
847 | (defun mh-goto-header-field (field) | |
848 | "Move to FIELD in the message header. | |
849 | Move to the end of the FIELD name, which should end in a colon. | |
850 | Returns t if found, nil if not." | |
f0d73c14 | 851 | (goto-char (point-min)) |
dda00b2c BW |
852 | (let ((case-fold-search t) |
853 | (headers-end (save-excursion | |
854 | (mh-goto-header-end 0) | |
855 | (point)))) | |
856 | (re-search-forward (format "^%s" field) headers-end t))) | |
857 | ||
858 | ;;;###mh-autoload | |
859 | (defun mh-goto-header-end (arg) | |
860 | "Move the cursor ARG lines after the header." | |
c932f02a BW |
861 | (if (re-search-forward (concat "^\\(" (regexp-quote mh-mail-header-separator) |
862 | "\\)?$") nil nil) | |
dda00b2c BW |
863 | (forward-line arg))) |
864 | ||
865 | ;;;###mh-autoload | |
866 | (defun mh-mail-header-end () | |
867 | "Substitute for `mail-header-end' that doesn't widen the buffer. | |
868 | ||
869 | In MH-E we frequently need to find the end of headers in nested | |
870 | messages, where the buffer has been narrowed. This function works | |
871 | in this situation." | |
872 | (save-excursion | |
873 | ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally, | |
874 | ;; mail headers that MH-E has to read contains lines of the form: | |
875 | ;; From xxx@yyy Mon May 10 11:48:07 2004 | |
876 | ;; In this situation, rfc822-goto-eoh doesn't go to the end of the | |
877 | ;; header. The replacement allows From_ lines in the mail header. | |
878 | (goto-char (point-min)) | |
879 | (loop for p = (re-search-forward | |
880 | "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) | |
881 | do (cond ((null p) (return)) | |
882 | (t (goto-char (match-beginning 0)) | |
883 | (unless (looking-at "From ") (return)) | |
884 | (goto-char p)))) | |
885 | (point))) | |
886 | ||
887 | ;;;###mh-autoload | |
888 | (defun mh-header-field-beginning () | |
889 | "Move to the beginning of the current header field. | |
890 | Handles RFC 822 continuation lines." | |
891 | (beginning-of-line) | |
892 | (while (looking-at "^[ \t]") | |
893 | (forward-line -1))) | |
894 | ||
895 | ;;;###mh-autoload | |
896 | (defun mh-header-field-end () | |
897 | "Move to the end of the current header field. | |
898 | Handles RFC 822 continuation lines." | |
899 | (forward-line 1) | |
900 | (while (looking-at "^[ \t]") | |
901 | (forward-line 1)) | |
902 | (backward-char 1)) ;to end of previous line | |
903 | ||
a55f450f BW |
904 | ;;;###mh-autoload |
905 | (defun mh-letter-hide-all-skipped-fields () | |
906 | "Hide all skipped fields." | |
907 | (save-excursion | |
908 | (goto-char (point-min)) | |
909 | (save-restriction | |
910 | (narrow-to-region (point) (mh-mail-header-end)) | |
911 | (while (re-search-forward mh-letter-header-field-regexp nil t) | |
912 | (if (mh-letter-skipped-header-field-p (match-string 1)) | |
913 | (mh-letter-toggle-header-field-display -1) | |
914 | (mh-letter-toggle-header-field-display 'long)) | |
915 | (beginning-of-line 2))))) | |
916 | ||
917 | ;;;###mh-autoload | |
918 | (defun mh-letter-skipped-header-field-p (field) | |
919 | "Check if FIELD is to be skipped." | |
920 | (let ((field (downcase field))) | |
921 | (loop for x in mh-compose-skipped-header-fields | |
922 | when (equal (downcase x) field) return t | |
923 | finally return nil))) | |
924 | ||
925 | (defvar mh-hidden-header-keymap | |
926 | (let ((map (make-sparse-keymap))) | |
927 | (mh-do-in-gnu-emacs | |
928 | (define-key map [mouse-2] 'mh-letter-toggle-header-field-display-button)) | |
929 | (mh-do-in-xemacs | |
930 | (define-key map '(button2) | |
931 | 'mh-letter-toggle-header-field-display-button)) | |
932 | map)) | |
933 | ||
934 | ;;;###mh-autoload | |
935 | (defun mh-letter-toggle-header-field-display (arg) | |
936 | "Toggle display of header field at point. | |
937 | ||
938 | Use this command to display truncated header fields. This command | |
939 | is a toggle so entering it again will hide the field. This | |
940 | command takes a prefix argument ARG: if negative then the field | |
941 | is hidden, if positive then the field is displayed." | |
942 | (interactive (list nil)) | |
943 | (when (and (mh-in-header-p) | |
944 | (progn | |
945 | (end-of-line) | |
946 | (re-search-backward mh-letter-header-field-regexp nil t))) | |
947 | (let ((buffer-read-only nil) | |
948 | (modified-flag (buffer-modified-p)) | |
949 | (begin (point)) | |
950 | end) | |
951 | (end-of-line) | |
952 | (setq end (1- (if (re-search-forward "^[^ \t]" nil t) | |
953 | (match-beginning 0) | |
954 | (point-max)))) | |
955 | (goto-char begin) | |
956 | ;; Make it clickable... | |
957 | (add-text-properties begin end `(keymap ,mh-hidden-header-keymap | |
958 | mouse-face highlight)) | |
959 | (unwind-protect | |
960 | (cond ((or (and (not arg) | |
961 | (text-property-any begin end 'invisible 'vanish)) | |
d5dc8c56 BW |
962 | (and (numberp arg) |
963 | (>= arg 0)) | |
964 | (and (eq arg 'long) | |
965 | (> (mh-line-beginning-position 5) end))) | |
a55f450f | 966 | (remove-text-properties begin end '(invisible nil)) |
d5dc8c56 | 967 | (search-forward ":" (mh-line-end-position) t) |
a55f450f BW |
968 | (mh-letter-skip-leading-whitespace-in-header-field)) |
969 | ;; XXX Redesign to make usable by user. Perhaps use a positive | |
970 | ;; numeric prefix to make that many lines visible. | |
971 | ((eq arg 'long) | |
972 | (end-of-line 4) | |
973 | (mh-letter-truncate-header-field end) | |
974 | (beginning-of-line)) | |
975 | (t (end-of-line) | |
976 | (mh-letter-truncate-header-field end) | |
977 | (beginning-of-line))) | |
978 | (set-buffer-modified-p modified-flag))))) | |
979 | ||
980 | ;;;###mh-autoload | |
981 | (defun mh-letter-skip-leading-whitespace-in-header-field () | |
982 | "Skip leading whitespace in a header field. | |
983 | If the header field doesn't have at least one space after the | |
984 | colon then a space character is added." | |
985 | (let ((need-space t)) | |
986 | (while (memq (char-after) '(?\t ?\ )) | |
987 | (forward-char) | |
988 | (setq need-space nil)) | |
989 | (when need-space (insert " ")))) | |
990 | ||
991 | (defun mh-letter-truncate-header-field (end) | |
992 | "Replace text from current line till END with an ellipsis. | |
993 | If the current line is too long truncate a part of it as well." | |
994 | (let ((max-len (min (window-width) 62))) | |
995 | (when (> (+ (current-column) 4) max-len) | |
996 | (backward-char (- (+ (current-column) 5) max-len))) | |
997 | (when (> end (point)) | |
998 | (add-text-properties (point) end '(invisible vanish))))) | |
999 | ||
dda00b2c BW |
1000 | ;;;###mh-autoload |
1001 | (defun mh-signature-separator-p () | |
1002 | "Return non-nil if buffer includes \"^-- $\"." | |
1003 | (save-excursion | |
1004 | (goto-char (point-min)) | |
1005 | (re-search-forward mh-signature-separator-regexp nil t))) | |
f0d73c14 | 1006 | |
c26cf6c8 RS |
1007 | (provide 'mh-utils) |
1008 | ||
cee9f5c6 BW |
1009 | ;; Local Variables: |
1010 | ;; indent-tabs-mode: nil | |
1011 | ;; sentence-end-double-space: nil | |
1012 | ;; End: | |
bdcfe844 | 1013 | |
c26cf6c8 | 1014 | ;;; mh-utils.el ends here |