1 ;;; mh-utils.el --- MH-E general utilities
3 ;; Copyright (C) 1993, 1995, 1997,
4 ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Bill Wohler <wohler@newt.com>
7 ;; Maintainer: Bill Wohler <wohler@newt.com>
11 ;; This file is part of GNU Emacs.
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)
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.
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.
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
55 (defun mh-beginning-of-word (&optional n)
56 "Return position of the N th word backwards."
58 (let ((syntax-table (syntax-table)))
61 (mh-mail-abbrev-make-syntax-table)
62 (set-syntax-table mail-abbrev-syntax-table)
65 (set-syntax-table syntax-table))))
68 (defun mh-colors-available-p ()
69 "Check if colors are available in the Emacs being used."
71 (let ((color-cells (mh-display-color-cells)))
72 (and (numberp color-cells) (>= color-cells 8)))))
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))
80 (defun mh-delete-line (lines)
81 "Delete the next LINES lines."
82 (delete-region (point) (progn (forward-line lines) (point))))
84 (defvar mh-image-load-path nil
85 "Directory where images for MH-E are found.
86 If nil, then the function `mh-image-load-path' will search for
87 the images in \"../../etc/images\" relative to the files in
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.")
95 (defun mh-image-load-path ()
96 "Ensure that the MH-E images are accessible by `find-image'.
98 Images for MH-E are found in \"../../etc/images\" relative to the
99 files in \"lisp/mh-e\". This function saves the actual location
100 found in the variable `mh-image-load-path'. If the images on your
101 system are actually located elsewhere, then set the variable
102 `mh-image-load-path' before starting MH-E.
104 If `image-load-path' exists (since Emacs 22), then the contents
105 of the variable `mh-image-load-path' is added to it if isn't
106 already there. Otherwise, the contents of the variable
107 `mh-image-load-path' is added to the `load-path' if it isn't
110 See also variable `mh-image-load-path-called-flag'."
111 (unless mh-image-load-path-called-flag
112 (if (or (not mh-image-load-path)
113 (not (file-exists-p mh-image-load-path)))
114 (let (mh-library-name)
115 ;; First, find mh-e in the load-path.
116 (setq mh-library-name (locate-library "mh-e"))
117 (if (not mh-library-name)
118 (error "Can not find MH-E in load-path"))
119 (setq mh-image-load-path
120 (expand-file-name (concat (file-name-directory mh-library-name)
121 "../../etc/images")))))
122 (if (not (file-exists-p mh-image-load-path))
123 (error "Can not find image directory %s" mh-image-load-path))
124 (if (boundp 'image-load-path)
125 (add-to-list 'image-load-path mh-image-load-path)
126 (add-to-list 'load-path mh-image-load-path))
127 (setq mh-image-load-path-called-flag t)))
130 (defun mh-make-local-vars (&rest pairs)
131 "Initialize local variables according to the variable-value PAIRS."
133 (set (make-local-variable (car pairs)) (car (cdr pairs)))
134 (setq pairs (cdr (cdr pairs)))))
137 (defun mh-mapc (function list)
138 "Apply FUNCTION to each element of LIST for side effects only."
140 (funcall function (car list))
141 (setq list (cdr list))))
144 (defun mh-replace-string (old new)
145 "Replace all occurrences of OLD with NEW in the current buffer.
146 Ignores case when searching for OLD."
147 (goto-char (point-min))
148 (let ((case-fold-search t))
149 (while (search-forward old nil t)
150 (replace-match new t t))))
156 (defvar mh-logo-cache nil)
159 (defun mh-logo-display ()
160 "Modify mode line to display MH-E logo."
165 `(display ,(or mh-logo-cache
167 (mh-funcall-if-exists
168 find-image '((:type xpm :ascent center
169 :file "mh-logo.xpm"))))))
170 (car mode-line-buffer-identification)))
172 (setq modeline-buffer-identification
174 (if mh-modeline-glyph
175 (cons modeline-buffer-id-left-extent mh-modeline-glyph)
176 (cons modeline-buffer-id-left-extent "XEmacs%N:"))
177 (cons modeline-buffer-id-right-extent " %17b")))))
183 (defvar mh-find-path-run nil
184 "Non-nil if `mh-find-path' has been run already.
185 Do not access this variable; `mh-find-path' already uses it to
186 avoid running more than once.")
189 (defun mh-find-path ()
190 "Set variables from user's MH profile.
192 This function sets `mh-user-path' from your \"Path:\" MH profile
193 component (but defaults to \"Mail\" if one isn't present),
194 `mh-draft-folder' from \"Draft-Folder:\", `mh-unseen-seq' from
195 \"Unseen-Sequence:\", `mh-previous-seq' from
196 \"Previous-Sequence:\", and `mh-inbox' from \"Inbox:\" (defaults
199 The hook `mh-find-path-hook' is run after these variables have
200 been set. This hook can be used the change the value of these
201 variables if you need to run with different values between MH and
203 (unless mh-find-path-run
205 (if (and (getenv "MH")
206 (not (file-readable-p (getenv "MH"))))
207 (error "MH environment variable contains unreadable file %s"
209 (if (null (mh-variants))
210 (error "Install MH and run install-mh before running MH-E"))
211 (let ((profile "~/.mh_profile"))
212 (if (not (file-readable-p profile))
213 (error "Run install-mh before running MH-E")))
215 (setq mh-user-path (mh-profile-component "Path"))
216 (if (not mh-user-path)
217 (setq mh-user-path "Mail"))
219 (file-name-as-directory
220 (expand-file-name mh-user-path (expand-file-name "~"))))
221 (mh-set-x-image-cache-directory (expand-file-name ".mhe-x-image-cache"
223 (setq mh-draft-folder (mh-profile-component "Draft-Folder"))
226 (if (not (mh-folder-name-p mh-draft-folder))
227 (setq mh-draft-folder (format "+%s" mh-draft-folder)))
228 (if (not (file-exists-p (mh-expand-file-name mh-draft-folder)))
230 "Draft folder \"%s\" not found; create it and try again"
231 (mh-expand-file-name mh-draft-folder)))))
232 (setq mh-inbox (mh-profile-component "Inbox"))
233 (cond ((not mh-inbox)
234 (setq mh-inbox "+inbox"))
235 ((not (mh-folder-name-p mh-inbox))
236 (setq mh-inbox (format "+%s" mh-inbox))))
237 (setq mh-unseen-seq (mh-profile-component "Unseen-Sequence"))
239 (setq mh-unseen-seq (intern mh-unseen-seq))
240 (setq mh-unseen-seq 'unseen)) ;old MH default?
241 (setq mh-previous-seq (mh-profile-component "Previous-Sequence"))
243 (setq mh-previous-seq (intern mh-previous-seq)))
244 (run-hooks 'mh-find-path-hook)
245 (mh-collect-folder-names)
246 (setq mh-find-path-run t)))
253 (defun mh-ephem-message (string)
254 "Display STRING in the minibuffer momentarily."
255 (message "%s" string)
259 (defvar mh-help-default nil
260 "Mode to use if messages are not present for the current mode.")
262 (defvar mh-help-messages nil
263 "Help messages for all modes.
264 This is an alist of alists. The primary key is a symbol
265 representing the mode; the value is described in `mh-set-help'.")
268 (defun mh-set-help (messages &optional default)
271 The MESSAGES are assumed to be an associative array. It is used
272 to show help for the most common commands in the current mode.
273 The key is a prefix char. The value is one or more strings which
274 are concatenated together and displayed in a help buffer if ? is
275 pressed after the prefix character. The special key nil is used
276 to display the non-prefixed commands.
278 The substitutions described in `substitute-command-keys' are performed as
281 If optional argument DEFAULT is non-nil, then these messages will
282 be used if help is asked for an unknown mode."
283 (add-to-list 'mh-help-messages (cons major-mode messages))
285 (setq mh-help-default major-mode)))
288 (defun mh-help (&optional help-messages)
289 "Display cheat sheet for the MH-E commands.
290 See `mh-set-help' for setting the help messages.
291 HELP-MESSAGES are used instead if given.
292 This is a list of one or more strings which are concatenated together
293 and displayed in a help buffer."
295 (let* ((help (or help-messages
296 (cdr (assoc nil (assoc major-mode mh-help-messages)))))
297 (text (substitute-command-keys (mapconcat 'identity help ""))))
305 (defun mh-prefix-help ()
306 "Display cheat sheet for the commands of the current prefix in minibuffer."
308 ;; We got here because the user pressed a "?", but he pressed a prefix key
309 ;; before that. Since the the key vector starts at index 0, the index of the
310 ;; last keystroke is length-1 and thus the second to last keystroke is at
311 ;; length-2. We use that information to obtain a suitable prefix character
312 ;; from the recent keys.
313 (let* ((keys (recent-keys))
314 (prefix-char (elt keys (- (length keys) 2)))
315 (help (cdr (assoc prefix-char (assoc major-mode mh-help-messages)))))
320 ;;; Message Number Utilities
323 (defun mh-coalesce-msg-list (messages)
324 "Given a list of MESSAGES, return a list of message number ranges.
325 This is the inverse of `mh-read-msg-list', which expands ranges.
326 Message lists passed to MH programs should be processed by this
327 function to avoid exceeding system command line argument limits."
328 (let ((msgs (sort (copy-sequence messages) 'mh-greaterp))
334 (if (or (not (numberp prev))
335 (not (equal (car msgs) (1- prev))))
336 (progn ;non-sequential, flush old range
337 (if (eq prev range-high)
338 (setq ranges (cons range-high ranges))
339 (setq ranges (cons (format "%s-%s" prev range-high) ranges)))
340 (setq range-high nil))))
342 (setq range-high (car msgs))) ;start new or first range
343 (setq prev (car msgs))
344 (setq msgs (cdr msgs)))
347 (defun mh-greaterp (msg1 msg2)
348 "Return the greater of two message indicators MSG1 and MSG2.
349 Strings are \"smaller\" than numbers.
350 Valid values are things like \"cur\", \"last\", 1, and 1820."
357 (string-lessp msg2 msg1))))
360 (defun mh-lessp (msg1 msg2)
361 "Return the lesser of two message indicators MSG1 and MSG2.
362 Strings are \"smaller\" than numbers.
363 Valid values are things like \"cur\", \"last\", 1, and 1820."
364 (not (mh-greaterp msg1 msg2)))
367 (defun mh-get-msg-num (error-if-no-message)
368 "Return the message number of the displayed message.
369 If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if
370 the cursor is not pointing to a message."
373 (cond ((looking-at (mh-scan-msg-number-regexp))
374 (string-to-number (buffer-substring (match-beginning 1)
377 (error "Cursor not pointing to message"))
380 (add-to-list 'debug-ignored-errors "^Cursor not pointing to message$")
384 ;;; Folder Cache and Access
386 (defvar mh-sub-folders-cache (make-hash-table :test #'equal))
387 (defvar mh-current-folder-name nil)
388 (defvar mh-flists-partial-line "")
389 (defvar mh-flists-process nil)
392 (defun mh-clear-sub-folders-cache ()
393 "Clear `mh-sub-folders-cache'."
394 (clrhash mh-sub-folders-cache))
396 ;; Initialize mh-sub-folders-cache...
397 (defun mh-collect-folder-names ()
398 "Collect folder names by running \"folders\"."
399 (unless mh-flists-process
400 (setq mh-flists-process
401 (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter
402 "-recurse" "-fast"))))
404 (defun mh-collect-folder-names-filter (process output)
406 PROCESS is the flists process that was run to collect folder
407 names and the function is called when OUTPUT is available."
409 (prevailing-match-data (match-data))
412 (while (setq line-end (string-match "\n" output position))
413 (setq folder (format "+%s%s"
414 mh-flists-partial-line
415 (substring output position line-end)))
416 (setq mh-flists-partial-line "")
417 (unless (equal (aref folder 1) ?.)
418 (mh-populate-sub-folders-cache folder))
419 (setq position (1+ line-end)))
420 (set-match-data prevailing-match-data))
421 (setq mh-flists-partial-line (substring output position))))
423 (defun mh-populate-sub-folders-cache (folder)
424 "Tell `mh-sub-folders-cache' about FOLDER."
425 (let* ((last-slash (mh-search-from-end ?/ folder))
426 (child1 (substring folder (1+ (or last-slash 0))))
427 (parent (and last-slash (substring folder 0 last-slash)))
428 (parent-slash (and parent (mh-search-from-end ?/ parent)))
429 (child2 (and parent (substring parent (1+ (or parent-slash 0)))))
430 (grand-parent (and parent-slash (substring parent 0 parent-slash)))
431 (cache-entry (gethash parent mh-sub-folders-cache)))
432 (unless (loop for x in cache-entry when (equal (car x) child1) return t
434 (push (list child1) cache-entry)
435 (setf (gethash parent mh-sub-folders-cache)
436 (sort cache-entry (lambda (x y) (string< (car x) (car y)))))
438 (loop for x in (gethash grand-parent mh-sub-folders-cache)
439 when (equal (car x) child2)
440 do (progn (setf (cdr x) t) (return)))))))
442 (defun mh-normalize-folder-name (folder &optional empty-string-okay
443 dont-remove-trailing-slash)
444 "Normalizes FOLDER name.
446 Makes sure that two '/' characters never occur next to each
447 other. Also all occurrences of \"..\" and \".\" are suitably
448 processed. So \"+inbox/../news\" will be normalized to \"+news\".
450 If optional argument EMPTY-STRING-OKAY is nil then a '+' is added
451 at the front if FOLDER lacks one. If non-nil and FOLDER is the
452 empty string then nothing is added.
454 If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a
455 trailing '/' if present is retained (if present), otherwise it is
457 (when (stringp folder)
458 ;; Replace two or more consecutive '/' characters with a single '/'
459 (while (string-match "//" folder)
460 (setq folder (replace-match "/" nil t folder)))
461 (let* ((length (length folder))
462 (trailing-slash-present (and (> length 0)
463 (equal (aref folder (1- length)) ?/)))
464 (leading-slash-present (and (> length 0)
465 (equal (aref folder 0) ?/))))
466 (when (and (> length 0) (equal (aref folder 0) ?@)
467 (stringp mh-current-folder-name))
468 (setq folder (format "%s/%s/" mh-current-folder-name
469 (substring folder 1))))
470 ;; XXX: Purge empty strings from the list that split-string returns. In
471 ;; XEmacs, (split-string "+foo/" "/") returns ("+foo" "") while in GNU
472 ;; Emacs it returns ("+foo"). In the code it is assumed that the
473 ;; components list has no empty strings.
474 (let ((components (delete "" (split-string folder "/")))
476 ;; Remove .. and . from the pathname.
477 (dolist (component components)
478 (cond ((and (equal component "..") result)
480 ((equal component ".."))
481 ((equal component "."))
482 (t (push component result))))
484 (dolist (component result)
485 (setq folder (concat component "/" folder)))
486 ;; Remove trailing '/' if needed.
487 (unless (and trailing-slash-present dont-remove-trailing-slash)
488 (when (not (equal folder ""))
489 (setq folder (substring folder 0 (1- (length folder))))))
490 (when leading-slash-present
491 (setq folder (concat "/" folder)))))
492 (cond ((and empty-string-okay (equal folder "")))
493 ((equal folder "") (setq folder "+"))
494 ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder)))))
497 (defmacro mh-children-p (folder)
498 "Return t if FOLDER from sub-folders cache has children.
499 The car of folder is the name, and the cdr is either t or some
500 sort of count that I do not understand. It's too small to be the
501 number of messages in the sub-folders and too large to be the
502 number of sub-folders. XXX"
508 (defun mh-folder-list (folder)
509 "Return FOLDER and its descendents.
510 Returns a list of strings. For example,
512 '(\"inbox\" \"lists\" \"lists/mh-e\").
514 If folder is nil, then all folders are considered. Respects the
515 value of `mh-recursive-folders-flag'. If this flag is nil, and
516 the sub-folders have not been explicitly viewed, then they will
519 ;; Normalize folder. Strip leading +. Add trailing slash (done in
520 ;; two steps to avoid infinite loops when replacing "/*$" with "/"
521 ;; in XEmacs). If no folder is specified, ensure it is nil to
522 ;; ensure we get the top-level folders; otherwise mh-sub-folders
523 ;; returns all the files in / if given an empty string or +.
525 (setq folder (mh-replace-regexp-in-string "^\+" "" folder))
526 (setq folder (mh-replace-regexp-in-string "/+$" "" folder))
527 (setq folder (concat folder "/"))
528 (if (equal folder "")
530 (loop for f in (mh-sub-folders folder) do
531 (setq folder-list (append folder-list (list (concat folder (car f)))))
532 (if (mh-children-p f)
535 (mh-folder-list (concat folder (car f)))))))
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.
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))
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)))
553 (if add-trailing-slash-flag
554 (mapcar #'(lambda (x)
555 (if (cdr x) (cons (concat (car x) "/") (cdr x)) x))
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) ())))
567 (current-folder (concat
569 (call-process (expand-file-name "folder" mh-progs)
570 nil '(t nil) nil "-fast")
571 (buffer-substring (point-min) (1- (point-max))))
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) ? )
585 (while (equal (char-after 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)))))
595 (search-forward "(others)" (mh-line-end-position) t))
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)
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
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
620 (remhash folder mh-sub-folders-cache)
621 (block ancestor-found
622 (let ((parent folder)
623 (one-ancestor-found nil)
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))))
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
644 (eq (aref (symbol-name name) 0) ?+)
645 (and (> (length name) 0)
646 (eq (aref name 0) ?+))))
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)))
657 (defvar mh-folder-hist nil)
660 (eval-when-compile (defvar mh-speed-flists-cache))
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.
668 This variable should never be set.")
670 (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map))
671 (define-key mh-folder-completion-map " " 'minibuffer-complete) ;Why???
673 (defvar mh-speed-flists-inhibit-flag nil)
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)))
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) ?+))
697 (let ((try-res (try-completion
700 (cons (if (not last-complete)
702 (concat last-complete "/" (car x)))
704 (mh-sub-folders last-complete t))
706 (cond ((eq try-res nil) nil)
707 ((and (eq try-res t) (equal name orig-name)) t)
708 ((eq try-res t) name)
712 remainder (mh-sub-folders last-complete t) predicate))
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))))))))
723 (defvar completion-root-regexp)
724 (defvar minibuffer-completing-file-name)))
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))
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
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))
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)))
782 (not (file-exists-p (mh-expand-file-name folder-name)))))
783 (cond ((and new-file-flag
786 (format "Folder %s does not exist. Create it? "
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))
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)))))
803 ;;; Message Utilities
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.
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)))
815 (defun mh-extract-from-header-value ()
816 "Extract From: string from header."
818 (if (not (mh-goto-header-field "From:"))
820 (skip-chars-forward " \t")
821 (buffer-substring-no-properties
822 (point) (progn (mh-header-field-end)(point))))))
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
829 (if (mh-goto-header-field field)
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))))
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)
847 (re-search-forward (format "^%s" field) headers-end t)))
850 (defun mh-goto-header-end (arg)
851 "Move the cursor ARG lines after the header."
852 (if (re-search-forward "^-*$" nil nil)
856 (defun mh-mail-header-end ()
857 "Substitute for `mail-header-end' that doesn't widen the buffer.
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
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))
878 (defun mh-header-field-beginning ()
879 "Move to the beginning of the current header field.
880 Handles RFC 822 continuation lines."
882 (while (looking-at "^[ \t]")
886 (defun mh-header-field-end ()
887 "Move to the end of the current header field.
888 Handles RFC 822 continuation lines."
890 (while (looking-at "^[ \t]")
892 (backward-char 1)) ;to end of previous line
895 (defun mh-letter-hide-all-skipped-fields ()
896 "Hide all skipped fields."
898 (goto-char (point-min))
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)))))
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)))
915 (defvar mh-hidden-header-keymap
916 (let ((map (make-sparse-keymap)))
918 (define-key map [mouse-2] 'mh-letter-toggle-header-field-display-button))
920 (define-key map '(button2)
921 'mh-letter-toggle-header-field-display-button))
925 (defun mh-letter-toggle-header-field-display (arg)
926 "Toggle display of header field at point.
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)
936 (re-search-backward mh-letter-header-field-regexp nil t)))
937 (let ((buffer-read-only nil)
938 (modified-flag (buffer-modified-p))
942 (setq end (1- (if (re-search-forward "^[^ \t]" nil t)
946 ;; Make it clickable...
947 (add-text-properties begin end `(keymap ,mh-hidden-header-keymap
948 mouse-face highlight))
950 (cond ((or (and (not arg)
951 (text-property-any begin end 'invisible 'vanish))
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.
963 (mh-letter-truncate-header-field end)
966 (mh-letter-truncate-header-field end)
967 (beginning-of-line)))
968 (set-buffer-modified-p modified-flag)))))
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 ?\ ))
978 (setq need-space nil))
979 (when need-space (insert " "))))
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)))))
991 (defun mh-signature-separator-p ()
992 "Return non-nil if buffer includes \"^-- $\"."
994 (goto-char (point-min))
995 (re-search-forward mh-signature-separator-regexp nil t)))
1000 ;; indent-tabs-mode: nil
1001 ;; sentence-end-double-space: nil
1004 ;; arch-tag: 1af39fdf-f66f-4b06-9b48-18a7656c8e36
1005 ;;; mh-utils.el ends here