1;;; mh-utils.el --- MH-E general utilities
2
3;; Copyright (C) 1993, 1995, 1997,
4;;  2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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.
44If CHAR is not present in STRING then return nil. The function is
45used 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
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.
104PICK-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.
118Ignores 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
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
158
159;;; Read MH Profile
160
161(defvar mh-find-path-run nil
162  "Non-nil if `mh-find-path' has been run already.
163Do not access this variable; `mh-find-path' already uses it to
164avoid running more than once.")
165
166;;;###mh-autoload
167(defun mh-find-path ()
168  "Set variables from user's MH profile.
169
170This function sets `mh-user-path' from your \"Path:\" MH profile
171component (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
175to \"+inbox\").
176
177The hook `mh-find-path-hook' is run after these variables have
178been set. This hook can be used the change the value of these
179variables if you need to run with different values between MH and
180MH-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
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.
242This is an alist of alists. The primary key is a symbol
243representing 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
249The MESSAGES are assumed to be an associative array. It is used
250to show help for the most common commands in the current mode.
251The key is a prefix char. The value is one or more strings which
252are concatenated together and displayed in a help buffer if ? is
253pressed after the prefix character. The special key nil is used
254to display the non-prefixed commands.
255
256The substitutions described in `substitute-command-keys' are performed as
257well.
258
259If optional argument DEFAULT is non-nil, then these messages will
260be 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.
268See `mh-set-help' for setting the help messages.
269HELP-MESSAGES are used instead if given.
270This is a list of one or more strings which are concatenated together
271and 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
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.
303This is the inverse of `mh-read-msg-list', which expands ranges.
304Message lists passed to MH programs should be processed by this
305function 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.
327Strings are \"smaller\" than numbers.
328Valid 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.
340Strings are \"smaller\" than numbers.
341Valid 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.
347If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if
348the 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
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.
384PROCESS is the flists process that was run to collect folder
385names 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
425Makes sure that two '/' characters never occur next to each
426other. Also all occurrences of \"..\" and \".\" are suitably
427processed. So \"+inbox/../news\" will be normalized to \"+news\".
428
429If optional argument EMPTY-STRING-OKAY is nil then a '+' is added
430at the front if FOLDER lacks one. If non-nil and FOLDER is the
431empty string then nothing is added.
432
433If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a
434trailing '/' if present is retained (if present), otherwise it is
435removed.
436
437If optional argument RETURN-NIL-IF-FOLDER-EMPTY is non-nil, then
438return nil if FOLDER is \"\" or \"+\". This is useful when
439normalizing the folder for the \"folders\" command which displays
440the directories in / if passed \"+\". This is usually not
441desired. If this argument is non-nil, then EMPTY-STRING-OKAY has
442no 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.
492The car of folder is the name, and the cdr is either t or some
493sort of count that I do not understand. It's too small to be the
494number of messages in the sub-folders and too large to be the
495number 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.
503FOLDER may have a + prefix. Returns a list of strings without the
504+ prefix. If FOLDER is nil, then all folders are considered. For
505example, 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
513Respects the value of `mh-recursive-folders-flag'. If this flag
514is nil, and the sub-folders have not been explicitly viewed, then
515they 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.
541The function avoids running folders unnecessarily by caching the
542results of the actual folders call.
543
544If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a
545slash is added to each of the sub-folder names that may have
546nested 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;; FIXME: This function does not do well if FOLDER does not exist. It
560;; then changes the context to that folder which causes problems down
561;; the line. Since a folder in the cache could later be deleted, it
562;; would be good for mh-sub-folders-actual to return nil in this case
563;; so that mh-sub-folders could delete it from the cache. This
564;; function could protect itself by using a temporary context.
565(defun mh-sub-folders-actual (folder)
566  "Execute the command folders to return the sub-folders of FOLDER.
567Filters out the folder names that start with \".\" so that
568directories that aren't usually mail folders are hidden.
569Expects FOLDER to have already been normalized with
570  (mh-normalize-folder-name folder nil nil t)"
571  (let ((arg-list `(,(expand-file-name "folders" mh-progs)
572                    nil (t nil) nil "-noheader" "-norecurse" "-nototal"
573                    ,@(if (stringp folder) (list folder) ())))
574        (results ())
575        (current-folder (concat
576                         (with-temp-buffer
577                           (call-process (expand-file-name "folder" mh-progs)
578                                         nil '(t nil) nil "-fast")
579                           (buffer-substring (point-min) (1- (point-max))))
580                         "+")))
581    (with-temp-buffer
582      (apply #'call-process arg-list)
583      (goto-char (point-min))
584      (while (not (and (eolp) (bolp)))
585        (goto-char (mh-line-end-position))
586        (let ((start-pos (mh-line-beginning-position))
587              (has-pos (search-backward " has "
588                                        (mh-line-beginning-position) t)))
589          (when (integerp has-pos)
590            (while (equal (char-after has-pos) ? )
591              (decf has-pos))
592            (incf has-pos)
593            (while (equal (char-after start-pos) ? )
594              (incf start-pos))
595            (let* ((name (buffer-substring start-pos has-pos))
596                   (first-char (aref name 0))
597                   (last-char (aref name (1- (length name)))))
598              (unless (member first-char '(?. ?# ?,))
599                (when (and (equal last-char ?+) (equal name current-folder))
600                  (setq name (substring name 0 (1- (length name)))))
601                (push
602                 (cons name
603                       (search-forward "(others)" (mh-line-end-position) t))
604                 results))))
605          (forward-line 1))))
606    (setq results (nreverse results))
607    (when (stringp folder)
608      (setq results (cdr results))
609      (let ((folder-name-len (length (format "%s/" (substring folder 1)))))
610        (setq results (mapcar (lambda (f)
611                                (cons (substring (car f) folder-name-len)
612                                      (cdr f)))
613                              results))))
614    results))
615
616;;;###mh-autoload
617(defun mh-remove-from-sub-folders-cache (folder)
618  "Remove FOLDER and its parent from `mh-sub-folders-cache'.
619FOLDER should be unconditionally removed from the cache. Also the
620last ancestor of FOLDER present in the cache must be removed as
621well.
622
623To see why this is needed assume we have a folder +foo which has
624a single sub-folder qux. Now we create the folder +foo/bar/baz.
625Here we will need to invalidate the cached sub-folders of +foo,
626otherwise completion on +foo won't tell us about the option
627+foo/bar!"
628  (remhash folder mh-sub-folders-cache)
629  (block ancestor-found
630    (let ((parent folder)
631          (one-ancestor-found nil)
632          last-slash)
633      (while (setq last-slash (mh-search-from-end ?/ parent))
634        (setq parent (substring parent 0 last-slash))
635        (unless (eq (gethash parent  mh-sub-folders-cache 'none) 'none)
636          (remhash parent mh-sub-folders-cache)
637          (if one-ancestor-found
638              (return-from ancestor-found)
639            (setq one-ancestor-found t))))
640      (remhash nil mh-sub-folders-cache))))
641
642
643
644;;; Folder Utilities
645
646;;;###mh-autoload
647(defun mh-folder-name-p (name)
648  "Return non-nil if NAME is the name of a folder.
649A name (a string or symbol) can be a folder name if it begins
650with \"+\"."
651  (if (symbolp name)
652      (eq (aref (symbol-name name) 0) ?+)
653    (and (> (length name) 0)
654         (eq (aref name 0) ?+))))
655
656;;;###mh-autoload
657(defun mh-expand-file-name (filename &optional default)
658  "Expand FILENAME like `expand-file-name', but also handle MH folder names.
659Any filename that starts with '+' is treated as a folder name.
660See `expand-file-name' for description of DEFAULT."
661  (if (mh-folder-name-p filename)
662      (expand-file-name (substring filename 1) mh-user-path)
663    (expand-file-name filename default)))
664
665(defvar mh-folder-hist nil)
666
667;; Shush compiler.
668(defvar mh-speed-flists-cache)
669
670(defvar mh-allow-root-folder-flag nil
671  "Non-nil means \"+\" is an acceptable folder name.
672This variable is used to communicate with
673`mh-folder-completion-function'. That function can have exactly
674three arguments so we bind this variable to t or nil.
675
676This variable should never be set.")
677
678(defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map))
679(define-key mh-folder-completion-map " " 'minibuffer-complete)  ;Why???
680
681(defvar mh-speed-flists-inhibit-flag nil)
682
683;;;###mh-autoload
684(defun mh-speed-flists-active-p ()
685  "Check if speedbar is running with message counts enabled."
686  (and (featurep 'mh-speed)
687       (not mh-speed-flists-inhibit-flag)
688       (> (hash-table-count mh-speed-flists-cache) 0)))
689
690;;;###mh-autoload
691(defun mh-folder-completion-function (name predicate flag)
692  "Programmable completion for folder names.
693NAME is the partial folder name that has been input. PREDICATE if
694non-nil is a function that is used to filter the possible
695choices. FLAG is nil to indicate `try-completion', t for
696`all-completions', or the symbol lambda for `test-completion'.
697See Info node `(elisp) Programmed Completion' for details."
698  (let* ((orig-name name)
699         ;; After normalization, name is nil, +, or +something. If a
700         ;; trailing slash is present, it is preserved.
701         (name (mh-normalize-folder-name name nil t))
702         (last-slash (mh-search-from-end ?/ name))
703         ;; nil if + or +folder; +folder/ if slash present.
704         (last-complete (if last-slash (substring name 0 (1+ last-slash)) nil))
705         ;; Either +folder/remainder, +remainder, or "".
706         (remainder (cond (last-complete (substring name (1+ last-slash)))
707                          (name (substring name 1))
708                          (t ""))))
709    (cond ((eq flag nil)
710           (let ((try-res
711                  (try-completion
712                   name
713                   (mapcar (lambda (x)
714                             (cons (concat (or last-complete "+") (car x))
715                                   (cdr x)))
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 try-res))))
722          ((eq flag t)
723           (mapcar (lambda (x)
724                     (concat (or last-complete "+") x))
725                   (all-completions
726                    remainder (mh-sub-folders last-complete t) predicate)))
727          ((eq flag 'lambda)
728           (let ((path (concat (unless (and (> (length name) 1)
729                                            (eq (aref name 1) ?/))
730                                 mh-user-path)
731                               (substring name 1))))
732             (cond (mh-allow-root-folder-flag (file-exists-p path))
733                   ((equal path mh-user-path) nil)
734                   (t (file-exists-p path))))))))
735
736;; Shush compiler.
737(defvar completion-root-regexp)          ; XEmacs
738(defvar minibuffer-completing-file-name) ; XEmacs
739
740(defun mh-folder-completing-read (prompt default allow-root-folder-flag)
741  "Read folder name with PROMPT and default result DEFAULT.
742If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be
743a folder name corresponding to `mh-user-path'."
744  (mh-normalize-folder-name
745   (let ((completion-root-regexp "^[+/]")
746         (minibuffer-local-completion-map mh-folder-completion-map)
747         (mh-allow-root-folder-flag allow-root-folder-flag))
748     (completing-read prompt 'mh-folder-completion-function nil nil nil
749                      'mh-folder-hist default))
750   t))
751
752;;;###mh-autoload
753(defun mh-prompt-for-folder (prompt default can-create
754                             &optional default-string allow-root-folder-flag)
755  "Prompt for a folder name with PROMPT.
756Returns the folder's name as a string. DEFAULT is used if the
757folder exists and the user types return. If the CAN-CREATE flag
758is t, then a folder is created if it doesn't already exist. If
759optional argument DEFAULT-STRING is non-nil, use it in the prompt
760instead of DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is non-nil then the
761function will accept the folder +, which means all folders when
762used in searching."
763  (if (null default)
764      (setq default ""))
765  (let* ((default-string (cond (default-string (format " (default %s)" default-string))
766                               ((equal "" default) "")
767                               (t (format " (default %s)" default))))
768         (prompt (format "%s folder%s: " prompt default-string))
769         (mh-current-folder-name mh-current-folder)
770         read-name folder-name)
771    (while (and (setq read-name (mh-folder-completing-read
772                                 prompt default allow-root-folder-flag))
773                (equal read-name "")
774                (equal default "")))
775    (cond ((or (equal read-name "")
776               (and (equal read-name "+") (not allow-root-folder-flag)))
777           (setq read-name default))
778          ((not (mh-folder-name-p read-name))
779           (setq read-name (format "+%s" read-name))))
780    (if (or (not read-name) (equal "" read-name))
781        (error "No folder specified"))
782    (setq folder-name read-name)
783    (cond ((and (> (length folder-name) 0)
784                (eq (aref folder-name (1- (length folder-name))) ?/))
785           (setq folder-name (substring folder-name 0 -1))))
786    (let* ((last-slash (mh-search-from-end ?/ folder-name))
787           (parent (and last-slash (substring folder-name 0 last-slash)))
788           (child (if last-slash
789                      (substring folder-name (1+ last-slash))
790                    (substring folder-name 1))))
791      (unless (member child
792                      (mapcar #'car (gethash parent mh-sub-folders-cache)))
793        (mh-remove-from-sub-folders-cache folder-name)))
794    (let ((new-file-flag
795           (not (file-exists-p (mh-expand-file-name folder-name)))))
796      (cond ((and new-file-flag
797                  can-create
798                  (y-or-n-p
799                   (format "Folder %s does not exist.  Create it? "
800                           folder-name)))
801             (message "Creating %s" folder-name)
802             (mh-exec-cmd-error nil "folder" folder-name)
803             (mh-remove-from-sub-folders-cache folder-name)
804             (when (boundp 'mh-speed-folder-map)
805               (mh-speed-add-folder folder-name))
806             (message "Creating %s...done" folder-name))
807            (new-file-flag
808             (error "Folder %s does not exist" folder-name))
809            ((not (file-directory-p (mh-expand-file-name folder-name)))
810             (error "%s is not a directory"
811                    (mh-expand-file-name folder-name)))))
812    folder-name))
813
814
815
816;;; Message Utilities
817
818;; Functions that would ordinarily be in mh-letter.el that are needed
819;; by mh-show.el are found here in order to prevent the loading of
820;; mh-letter.el until a message is actually composed.
821
822;;;###mh-autoload
823(defun mh-in-header-p ()
824  "Return non-nil if the point is in the header of a draft message."
825  (< (point) (mh-mail-header-end)))
826
827;;;###mh-autoload
828(defun mh-extract-from-header-value ()
829  "Extract From: string from header."
830  (save-excursion
831    (if (not (mh-goto-header-field "From:"))
832        nil
833      (skip-chars-forward " \t")
834      (buffer-substring-no-properties
835       (point) (progn (mh-header-field-end)(point))))))
836
837;;;###mh-autoload
838(defun mh-get-header-field (field)
839  "Find and return the body of FIELD in the mail header.
840Returns the empty string if the field is not in the header of the
841current buffer."
842  (if (mh-goto-header-field field)
843      (progn
844        (skip-chars-forward " \t")      ;strip leading white space in body
845        (let ((start (point)))
846          (mh-header-field-end)
847          (buffer-substring-no-properties start (point))))
848    ""))
849
850;;;###mh-autoload
851(defun mh-goto-header-field (field)
852  "Move to FIELD in the message header.
853Move to the end of the FIELD name, which should end in a colon.
854Returns t if found, nil if not."
855  (goto-char (point-min))
856  (let ((case-fold-search t)
857        (headers-end (save-excursion
858                       (mh-goto-header-end 0)
859                       (point))))
860    (re-search-forward (format "^%s" field) headers-end t)))
861
862;;;###mh-autoload
863(defun mh-goto-header-end (arg)
864  "Move the cursor ARG lines after the header."
865  (if (re-search-forward "^-*$" nil nil)
866      (forward-line arg)))
867
868;;;###mh-autoload
869(defun mh-mail-header-end ()
870  "Substitute for `mail-header-end' that doesn't widen the buffer.
871
872In MH-E we frequently need to find the end of headers in nested
873messages, where the buffer has been narrowed. This function works
874in this situation."
875  (save-excursion
876    ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally,
877    ;; mail headers that MH-E has to read contains lines of the form:
878    ;;    From xxx@yyy Mon May 10 11:48:07 2004
879    ;; In this situation, rfc822-goto-eoh doesn't go to the end of the
880    ;; header. The replacement allows From_ lines in the mail header.
881    (goto-char (point-min))
882    (loop for p = (re-search-forward
883                   "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move)
884          do (cond ((null p) (return))
885                   (t (goto-char (match-beginning 0))
886                      (unless (looking-at "From ") (return))
887                      (goto-char p))))
888    (point)))
889
890;;;###mh-autoload
891(defun mh-header-field-beginning ()
892  "Move to the beginning of the current header field.
893Handles RFC 822 continuation lines."
894  (beginning-of-line)
895  (while (looking-at "^[ \t]")
896    (forward-line -1)))
897
898;;;###mh-autoload
899(defun mh-header-field-end ()
900  "Move to the end of the current header field.
901Handles RFC 822 continuation lines."
902  (forward-line 1)
903  (while (looking-at "^[ \t]")
904    (forward-line 1))
905  (backward-char 1))                    ;to end of previous line
906
907;;;###mh-autoload
908(defun mh-letter-hide-all-skipped-fields ()
909  "Hide all skipped fields."
910  (save-excursion
911    (goto-char (point-min))
912    (save-restriction
913      (narrow-to-region (point) (mh-mail-header-end))
914      (while (re-search-forward mh-letter-header-field-regexp nil t)
915        (if (mh-letter-skipped-header-field-p (match-string 1))
916            (mh-letter-toggle-header-field-display -1)
917          (mh-letter-toggle-header-field-display 'long))
918        (beginning-of-line 2)))))
919
920;;;###mh-autoload
921(defun mh-letter-skipped-header-field-p (field)
922  "Check if FIELD is to be skipped."
923  (let ((field (downcase field)))
924    (loop for x in mh-compose-skipped-header-fields
925          when (equal (downcase x) field) return t
926          finally return nil)))
927
928(defvar mh-hidden-header-keymap
929  (let ((map (make-sparse-keymap)))
930    (mh-do-in-gnu-emacs
931      (define-key map [mouse-2] 'mh-letter-toggle-header-field-display-button))
932    (mh-do-in-xemacs
933      (define-key map '(button2)
934        'mh-letter-toggle-header-field-display-button))
935    map))
936
937;;;###mh-autoload
938(defun mh-letter-toggle-header-field-display (arg)
939  "Toggle display of header field at point.
940
941Use this command to display truncated header fields. This command
942is a toggle so entering it again will hide the field. This
943command takes a prefix argument ARG: if negative then the field
944is hidden, if positive then the field is displayed."
945  (interactive (list nil))
946  (when (and (mh-in-header-p)
947             (progn
948               (end-of-line)
949               (re-search-backward mh-letter-header-field-regexp nil t)))
950    (let ((buffer-read-only nil)
951          (modified-flag (buffer-modified-p))
952          (begin (point))
953          end)
954      (end-of-line)
955      (setq end (1- (if (re-search-forward "^[^ \t]" nil t)
956                        (match-beginning 0)
957                      (point-max))))
958      (goto-char begin)
959      ;; Make it clickable...
960      (add-text-properties begin end `(keymap ,mh-hidden-header-keymap
961                                       mouse-face highlight))
962      (unwind-protect
963          (cond ((or (and (not arg)
964                          (text-property-any begin end 'invisible 'vanish))
965                     (and (numberp arg)
966                          (>= arg 0))
967                     (and (eq arg 'long)
968                          (> (mh-line-beginning-position 5) end)))
969                 (remove-text-properties begin end '(invisible nil))
970                 (search-forward ":" (mh-line-end-position) t)
971                 (mh-letter-skip-leading-whitespace-in-header-field))
972                ;; XXX Redesign to make usable by user. Perhaps use a positive
973                ;; numeric prefix to make that many lines visible.
974                ((eq arg 'long)
975                 (end-of-line 4)
976                 (mh-letter-truncate-header-field end)
977                 (beginning-of-line))
978                (t (end-of-line)
979                   (mh-letter-truncate-header-field end)
980                   (beginning-of-line)))
981        (set-buffer-modified-p modified-flag)))))
982
983;;;###mh-autoload
984(defun mh-letter-skip-leading-whitespace-in-header-field ()
985  "Skip leading whitespace in a header field.
986If the header field doesn't have at least one space after the
987colon then a space character is added."
988  (let ((need-space t))
989    (while (memq (char-after) '(?\t ?\ ))
990      (forward-char)
991      (setq need-space nil))
992    (when need-space (insert " "))))
993
994(defun mh-letter-truncate-header-field (end)
995  "Replace text from current line till END with an ellipsis.
996If the current line is too long truncate a part of it as well."
997  (let ((max-len (min (window-width) 62)))
998    (when (> (+ (current-column) 4) max-len)
999      (backward-char (- (+ (current-column) 5) max-len)))
1000    (when (> end (point))
1001      (add-text-properties (point) end '(invisible vanish)))))
1002
1003;;;###mh-autoload
1004(defun mh-signature-separator-p ()
1005  "Return non-nil if buffer includes \"^-- $\"."
1006  (save-excursion
1007    (goto-char (point-min))
1008    (re-search-forward mh-signature-separator-regexp nil t)))
1009
1010(provide 'mh-utils)
1011
1012;; Local Variables:
1013;; indent-tabs-mode: nil
1014;; sentence-end-double-space: nil
1015;; End:
1016
1017;; arch-tag: 1af39fdf-f66f-4b06-9b48-18a7656c8e36
1018;;; mh-utils.el ends here
1019