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