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