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