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