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