lisp/mh-e/mh-utils.el

   1 ;;; mh-utils.el --- MH-E general utilities
   2
   3 ;; Copyright (C) 1993, 1995, 1997,
   4 ;;   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
   5 ;;   Free Software Foundation, Inc.
   6
   7 ;; Author: Bill Wohler <wohler@newt.com>
   8 ;; Maintainer: Bill Wohler <wohler@newt.com>
   9 ;; Keywords: mail
  10 ;; See: mh-e.el
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 ;;; Commentary:
  28
  29 ;;; Change Log:
  30
  31 ;;; Code:
  32
  33 (require 'mh-e)
  34 (mh-require-cl)
  35
  36 (require 'font-lock)
  37
  38 ;;; CL Replacements
  39
  40 ;;;###mh-autoload
  41 (defun mh-search-from-end (char string)
  42   "Return the position of last occurrence of CHAR in STRING.
  43 If CHAR is not present in STRING then return nil. The function is
  44 used in lieu of `search' in the CL package."
  45   (loop for index from (1- (length string)) downto 0
  46         when (equal (aref string index) char) return index
  47         finally return nil))
  48
  49 \f
  50
  51 ;;; General Utilities
  52
  53 ;;;###mh-autoload
  54 (defun mh-beginning-of-word (&optional n)
  55   "Return position of the N th word backwards."
  56   (unless n (setq n 1))
  57   (let ((syntax-table (syntax-table)))
  58     (unwind-protect
  59         (save-excursion
  60           (mh-mail-abbrev-make-syntax-table)
  61           (set-syntax-table mail-abbrev-syntax-table)
  62           (backward-word n)
  63           (point))
  64       (set-syntax-table syntax-table))))
  65
  66 ;;;###mh-autoload
  67 (defun mh-colors-available-p ()
  68   "Check if colors are available in the Emacs being used."
  69   (or (featurep 'xemacs)
  70       (let ((color-cells (mh-display-color-cells)))
  71         (and (numberp color-cells) (>= color-cells 8)))))
  72
  73 ;;;###mh-autoload
  74 (defun mh-colors-in-use-p ()
  75   "Check if colors are being used in the folder buffer."
  76   (and mh-colors-available-flag font-lock-mode))
  77
  78 ;;;###mh-autoload
  79 (defun mh-delete-line (lines)
  80   "Delete the next LINES lines."
  81   (delete-region (point) (progn (forward-line lines) (point))))
  82
  83 ;;;###mh-autoload
  84 (defun mh-make-local-vars (&rest pairs)
  85   "Initialize local variables according to the variable-value PAIRS."
  86   (while pairs
  87     (set (make-local-variable (car pairs)) (car (cdr pairs)))
  88     (setq pairs (cdr (cdr pairs)))))
  89
  90 ;;;###mh-autoload
  91 (defun mh-mapc (function list)
  92   "Apply FUNCTION to each element of LIST for side effects only."
  93   (while list
  94     (funcall function (car list))
  95     (setq list (cdr list))))
  96
  97 (defvar mh-pick-regexp-chars ".*$["
  98   "List of special characters in pick regular expressions.")
  99
 100 ;;;###mh-autoload
 101 (defun mh-quote-pick-expr (pick-expr)
 102   "Quote `mh-pick-regexp-chars' in PICK-EXPR.
 103 PICK-EXPR is a list of strings. Return nil if PICK-EXPR is nil."
 104   (let ((quoted-pick-expr))
 105     (dolist (string pick-expr)
 106       (when (and string
 107                  (not (string-equal string "")))
 108         (loop for i from 0 to (1- (length mh-pick-regexp-chars)) do
 109               (let ((s (string ?\\ (aref mh-pick-regexp-chars i))))
 110                 (setq string (mh-replace-regexp-in-string s s string t t))))
 111         (setq quoted-pick-expr (append quoted-pick-expr (list string)))))
 112     quoted-pick-expr))
 113
 114 ;;;###mh-autoload
 115 (defun mh-replace-string (old new)
 116   "Replace all occurrences of OLD with NEW in the current buffer.
 117 Ignores case when searching for OLD."
 118   (goto-char (point-min))
 119   (let ((case-fold-search t))
 120     (while (search-forward old nil t)
 121       (replace-match new t t))))
 122
 123 \f
 124
 125 ;;; Logo Display
 126
 127 (defvar mh-logo-cache nil)
 128
 129 ;; Shush compiler.
 130 (defvar image-load-path)
 131
 132 ;;;###mh-autoload
 133 (defun mh-logo-display ()
 134   "Modify mode line to display MH-E logo."
 135   (mh-do-in-gnu-emacs
 136     (let* ((load-path (mh-image-load-path-for-library "mh-e" "mh-logo.xpm"))
 137            (image-load-path (cons (car load-path)
 138                                   (when (boundp 'image-load-path)
 139                                     image-load-path))))
 140       (add-text-properties
 141        0 2
 142        `(display ,(or mh-logo-cache
 143                       (setq mh-logo-cache
 144                             (mh-funcall-if-exists
 145                              find-image '((:type xpm :ascent center
 146                                                  :file "mh-logo.xpm"))))))
 147        (car mode-line-buffer-identification))))
 148   (mh-do-in-xemacs
 149     (setq modeline-buffer-identification
 150           (list
 151            (if mh-modeline-glyph
 152                (cons modeline-buffer-id-left-extent mh-modeline-glyph)
 153              (cons modeline-buffer-id-left-extent "XEmacs%N:"))
 154            (cons modeline-buffer-id-right-extent " %17b")))))
 155
 156 \f
 157
 158 ;;; Read MH Profile
 159
 160 (defvar mh-find-path-run nil
 161   "Non-nil if `mh-find-path' has been run already.
 162 Do not access this variable; `mh-find-path' already uses it to
 163 avoid running more than once.")
 164
 165 ;;;###mh-autoload
 166 (defun mh-find-path ()
 167   "Set variables from user's MH profile.
 168
 169 This function sets `mh-user-path' from your \"Path:\" MH profile
 170 component (but defaults to \"Mail\" if one isn't present),
 171 `mh-draft-folder' from \"Draft-Folder:\", `mh-unseen-seq' from
 172 \"Unseen-Sequence:\", `mh-previous-seq' from
 173 \"Previous-Sequence:\", and `mh-inbox' from \"Inbox:\" (defaults
 174 to \"+inbox\").
 175
 176 The hook `mh-find-path-hook' is run after these variables have
 177 been set. This hook can be used the change the value of these
 178 variables if you need to run with different values between MH and
 179 MH-E."
 180   (unless mh-find-path-run
 181     ;; Sanity checks.
 182     (if (and (getenv "MH")
 183              (not (file-readable-p (getenv "MH"))))
 184         (error "MH environment variable contains unreadable file %s"
 185                (getenv "MH")))
 186     (if (null (mh-variants))
 187         (error "Install MH and run install-mh before running MH-E"))
 188     (if (not (or (getenv "MH") (file-readable-p "~/.mh_profile")))
 189         (error "Run install-mh before running MH-E"))
 190     ;; Read MH profile.
 191     (setq mh-user-path (mh-profile-component "Path"))
 192     (if (not mh-user-path)
 193         (setq mh-user-path "Mail"))
 194     (setq mh-user-path
 195           (file-name-as-directory
 196            (expand-file-name mh-user-path (expand-file-name "~"))))
 197     (mh-set-x-image-cache-directory (expand-file-name ".mhe-x-image-cache"
 198                                                       mh-user-path))
 199     (setq mh-draft-folder (mh-profile-component "Draft-Folder"))
 200     (if mh-draft-folder
 201         (progn
 202           (if (not (mh-folder-name-p mh-draft-folder))
 203               (setq mh-draft-folder (format "+%s" mh-draft-folder)))
 204           (if (not (file-exists-p (mh-expand-file-name mh-draft-folder)))
 205               (error
 206                "Draft folder \"%s\" not found; create it and try again"
 207                (mh-expand-file-name mh-draft-folder)))))
 208     (setq mh-inbox (mh-profile-component "Inbox"))
 209     (cond ((not mh-inbox)
 210            (setq mh-inbox "+inbox"))
 211           ((not (mh-folder-name-p mh-inbox))
 212            (setq mh-inbox (format "+%s" mh-inbox))))
 213     (setq mh-unseen-seq (mh-profile-component "Unseen-Sequence"))
 214     (if mh-unseen-seq
 215         (setq mh-unseen-seq (intern mh-unseen-seq))
 216       (setq mh-unseen-seq 'unseen))     ;old MH default?
 217     (setq mh-previous-seq (mh-profile-component "Previous-Sequence"))
 218     (if mh-previous-seq
 219         (setq mh-previous-seq (intern mh-previous-seq)))
 220     (run-hooks 'mh-find-path-hook)
 221     (mh-collect-folder-names)
 222     (setq mh-find-path-run t)))
 223
 224 \f
 225
 226 ;;; Help Functions
 227
 228 ;;;###mh-autoload
 229 (defun mh-ephem-message (string)
 230   "Display STRING in the minibuffer momentarily."
 231   (message "%s" string)
 232   (sit-for 5)
 233   (message ""))
 234
 235 (defvar mh-help-default nil
 236   "Mode to use if messages are not present for the current mode.")
 237
 238 (defvar mh-help-messages nil
 239   "Help messages for all modes.
 240 This is an alist of alists. The primary key is a symbol
 241 representing the mode; the value is described in `mh-set-help'.")
 242
 243 ;;;###mh-autoload
 244 (defun mh-set-help (messages &optional default)
 245   "Set help messages.
 246
 247 The MESSAGES are assumed to be an associative array. It is used
 248 to show help for the most common commands in the current mode.
 249 The key is a prefix char. The value is one or more strings which
 250 are concatenated together and displayed in a help buffer if ? is
 251 pressed after the prefix character. The special key nil is used
 252 to display the non-prefixed commands.
 253
 254 The substitutions described in `substitute-command-keys' are performed as
 255 well.
 256
 257 If optional argument DEFAULT is non-nil, then these messages will
 258 be used if help is asked for an unknown mode."
 259   (add-to-list 'mh-help-messages (cons major-mode messages))
 260   (if default
 261       (setq mh-help-default major-mode)))
 262
 263 ;;;###mh-autoload
 264 (defun mh-help (&optional help-messages)
 265   "Display cheat sheet for the MH-E commands.
 266 See `mh-set-help' for setting the help messages.
 267 HELP-MESSAGES are used instead if given.
 268 This is a list of one or more strings which are concatenated together
 269 and displayed in a help buffer."
 270   (interactive)
 271   (let* ((help (or help-messages
 272                   (cdr (assoc nil (assoc major-mode mh-help-messages)))))
 273          (text (substitute-command-keys (mapconcat 'identity help ""))))
 274     (with-electric-help
 275      (function
 276       (lambda ()
 277         (insert text)))
 278      mh-help-buffer)))
 279
 280 ;;;###mh-autoload
 281 (defun mh-prefix-help ()
 282   "Display cheat sheet for the commands of the current prefix in minibuffer."
 283   (interactive)
 284   ;; We got here because the user pressed a "?", but he pressed a prefix key
 285   ;; before that. Since the key vector starts at index 0, the index of the
 286   ;; last keystroke is length-1 and thus the second to last keystroke is at
 287   ;; length-2. We use that information to obtain a suitable prefix character
 288   ;; from the recent keys.
 289   (let* ((keys (recent-keys))
 290          (prefix-char (elt keys (- (length keys) 2)))
 291          (help (cdr (assoc prefix-char (assoc major-mode mh-help-messages)))))
 292     (mh-help help)))
 293
 294 \f
 295
 296 ;;; Message Number Utilities
 297
 298 ;;;###mh-autoload
 299 (defun mh-coalesce-msg-list (messages)
 300   "Given a list of MESSAGES, return a list of message number ranges.
 301 This is the inverse of `mh-read-msg-list', which expands ranges.
 302 Message lists passed to MH programs should be processed by this
 303 function to avoid exceeding system command line argument limits."
 304   (let ((msgs (sort (copy-sequence messages) 'mh-greaterp))
 305         (range-high nil)
 306         (prev -1)
 307         (ranges nil))
 308     (while prev
 309       (if range-high
 310           (if (or (not (numberp prev))
 311                   (not (equal (car msgs) (1- prev))))
 312               (progn                    ;non-sequential, flush old range
 313                 (if (eq prev range-high)
 314                     (setq ranges (cons range-high ranges))
 315                   (setq ranges (cons (format "%s-%s" prev range-high) ranges)))
 316                 (setq range-high nil))))
 317       (or range-high
 318           (setq range-high (car msgs))) ;start new or first range
 319       (setq prev (car msgs))
 320       (setq msgs (cdr msgs)))
 321     ranges))
 322
 323 (defun mh-greaterp (msg1 msg2)
 324   "Return the greater of two message indicators MSG1 and MSG2.
 325 Strings are \"smaller\" than numbers.
 326 Valid values are things like \"cur\", \"last\", 1, and 1820."
 327   (if (numberp msg1)
 328       (if (numberp msg2)
 329           (> msg1 msg2)
 330         t)
 331     (if (numberp msg2)
 332         nil
 333       (string-lessp msg2 msg1))))
 334
 335 ;;;###mh-autoload
 336 (defun mh-lessp (msg1 msg2)
 337   "Return the lesser of two message indicators MSG1 and MSG2.
 338 Strings are \"smaller\" than numbers.
 339 Valid values are things like \"cur\", \"last\", 1, and 1820."
 340   (not (mh-greaterp msg1 msg2)))
 341
 342 ;;;###mh-autoload
 343 (defun mh-get-msg-num (error-if-no-message)
 344   "Return the message number of the displayed message.
 345 If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if
 346 the cursor is not pointing to a message."
 347   (save-excursion
 348     (beginning-of-line)
 349     (cond ((looking-at (mh-scan-msg-number-regexp))
 350            (string-to-number (buffer-substring (match-beginning 1)
 351                                                (match-end 1))))
 352           (error-if-no-message
 353            (error "Cursor not pointing to message"))
 354           (t nil))))
 355
 356 (add-to-list 'debug-ignored-errors "^Cursor not pointing to message$")
 357
 358 \f
 359
 360 ;;; Folder Cache and Access
 361
 362 (defvar mh-sub-folders-cache (make-hash-table :test #'equal))
 363 (defvar mh-current-folder-name nil)
 364 (defvar mh-flists-partial-line "")
 365 (defvar mh-flists-process nil)
 366
 367 ;;;###mh-autoload
 368 (defun mh-clear-sub-folders-cache ()
 369   "Clear `mh-sub-folders-cache'."
 370   (clrhash mh-sub-folders-cache))
 371
 372 ;; Initialize mh-sub-folders-cache...
 373 (defun mh-collect-folder-names ()
 374   "Collect folder names by running \"folders\"."
 375   (unless mh-flists-process
 376     (setq mh-flists-process
 377           (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter
 378                               "-recurse" "-fast"))))
 379
 380 (defun mh-collect-folder-names-filter (process output)
 381   "Read folder names.
 382 PROCESS is the flists process that was run to collect folder
 383 names and the function is called when OUTPUT is available."
 384   (let ((position 0)
 385         (prevailing-match-data (match-data))
 386         line-end folder)
 387     (unwind-protect
 388         (while (setq line-end (string-match "\n" output position))
 389           (setq folder (format "+%s%s"
 390                                mh-flists-partial-line
 391                                (substring output position line-end)))
 392           (setq mh-flists-partial-line "")
 393           (unless (equal (aref folder 1) ?.)
 394             (mh-populate-sub-folders-cache folder))
 395           (setq position (1+ line-end)))
 396       (set-match-data prevailing-match-data))
 397     (setq mh-flists-partial-line (substring output position))))
 398
 399 (defun mh-populate-sub-folders-cache (folder)
 400   "Tell `mh-sub-folders-cache' about FOLDER."
 401   (let* ((last-slash (mh-search-from-end ?/ folder))
 402          (child1 (substring folder (1+ (or last-slash 0))))
 403          (parent (and last-slash (substring folder 0 last-slash)))
 404          (parent-slash (and parent (mh-search-from-end ?/ parent)))
 405          (child2 (and parent (substring parent (1+ (or parent-slash 0)))))
 406          (grand-parent (and parent-slash (substring parent 0 parent-slash)))
 407          (cache-entry (gethash parent mh-sub-folders-cache)))
 408     (unless (loop for x in cache-entry when (equal (car x) child1) return t
 409                   finally return nil)
 410       (push (list child1) cache-entry)
 411       (setf (gethash parent mh-sub-folders-cache)
 412             (sort cache-entry (lambda (x y) (string< (car x) (car y)))))
 413       (when parent
 414         (loop for x in (gethash grand-parent mh-sub-folders-cache)
 415               when (equal (car x) child2)
 416               do (progn (setf (cdr x) t) (return)))))))
 417
 418 (defun mh-normalize-folder-name (folder &optional empty-string-okay
 419                                         dont-remove-trailing-slash
 420                                         return-nil-if-folder-empty)
 421   "Normalizes FOLDER name.
 422
 423 Makes sure that two '/' characters never occur next to each
 424 other. Also all occurrences of \"..\" and \".\" are suitably
 425 processed. So \"+inbox/../news\" will be normalized to \"+news\".
 426
 427 If optional argument EMPTY-STRING-OKAY is nil then a '+' is added
 428 at the front if FOLDER lacks one. If non-nil and FOLDER is the
 429 empty string then nothing is added.
 430
 431 If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a
 432 trailing '/' if present is retained (if present), otherwise it is
 433 removed.
 434
 435 If optional argument RETURN-NIL-IF-FOLDER-EMPTY is non-nil, then
 436 return nil if FOLDER is \"\" or \"+\". This is useful when
 437 normalizing the folder for the \"folders\" command which displays
 438 the directories in / if passed \"+\". This is usually not
 439 desired. If this argument is non-nil, then EMPTY-STRING-OKAY has
 440 no effect."
 441   (cond
 442    ((if (and (or (equal folder "+") (equal folder ""))
 443              return-nil-if-folder-empty)
 444         (setq folder nil)))
 445    ((stringp folder)
 446     ;; Replace two or more consecutive '/' characters with a single '/'
 447     (while (string-match "//" folder)
 448       (setq folder (replace-match "/" nil t folder)))
 449     (let* ((length (length folder))
 450            (trailing-slash-present (and (> length 0)
 451                                         (equal (aref folder (1- length)) ?/)))
 452            (leading-slash-present (and (> length 0)
 453                                        (equal (aref folder 0) ?/))))
 454       (when (and (> length 0) (equal (aref folder 0) ?@)
 455                  (stringp mh-current-folder-name))
 456         (setq folder (format "%s/%s/" mh-current-folder-name
 457                              (substring folder 1))))
 458       ;; XXX: Purge empty strings from the list that split-string
 459       ;; returns. In XEmacs, (split-string "+foo/" "/") returns
 460       ;; ("+foo" "") while in GNU Emacs it returns ("+foo"). In the
 461       ;; code it is assumed that the components list has no empty
 462       ;; strings.
 463       (let ((components (delete "" (split-string folder "/")))
 464             (result ()))
 465         ;; Remove .. and . from the pathname.
 466         (dolist (component components)
 467           (cond ((and (equal component "..") result)
 468                  (pop result))
 469                 ((equal component ".."))
 470                 ((equal component "."))
 471                 (t (push component result))))
 472         (setq folder "")
 473         (dolist (component result)
 474           (setq folder (concat component "/" folder)))
 475         ;; Remove trailing '/' if needed.
 476         (unless (and trailing-slash-present dont-remove-trailing-slash)
 477           (when (not (equal folder ""))
 478             (setq folder (substring folder 0 (1- (length folder))))))
 479         (when leading-slash-present
 480           (setq folder (concat "/" folder)))))
 481     (cond ((and empty-string-okay (equal folder "")))
 482           ((equal folder "")
 483            (setq folder "+"))
 484           ((not (equal (aref folder 0) ?+))
 485            (setq folder (concat "+" folder))))))
 486   folder)
 487
 488 (defmacro mh-children-p (folder)
 489   "Return t if FOLDER from sub-folders cache has children.
 490 The car of folder is the name, and the cdr is either t or some
 491 sort of count that I do not understand. It's too small to be the
 492 number of messages in the sub-folders and too large to be the
 493 number of sub-folders. XXX"
 494   `(if (cdr ,folder)
 495        t
 496      nil))
 497
 498 ;;;###mh-autoload
 499 (defun mh-folder-list (folder)
 500   "Return FOLDER and its descendents.
 501 FOLDER may have a + prefix. Returns a list of strings without the
 502 + prefix. If FOLDER is nil, then all folders are considered. For
 503 example, if your Mail directory only contains the folders +inbox,
 504 +outbox, +lists, and +lists/mh-e, then
 505
 506   (mh-folder-list nil)
 507        => (\"inbox\" \"lists\" \"lists/mh-e\" \"outbox\")
 508   (mh-folder-list \"+lists\")
 509        => (\"lists\" \"lists/mh-e\")
 510
 511 Respects the value of `mh-recursive-folders-flag'. If this flag
 512 is nil, and the sub-folders have not been explicitly viewed, then
 513 they will not be returned."
 514   (let ((folder-list))
 515     ;; Normalize folder. Strip leading + and trailing slash(es). If no
 516     ;; folder is specified, ensure it is nil to avoid adding the
 517     ;; folder to the folder-list and adding a slash to it.
 518     (when folder
 519       (setq folder (mh-replace-regexp-in-string "^\+" "" folder))
 520       (setq folder (mh-replace-regexp-in-string "/+$" "" folder))
 521       (if (equal folder "")
 522           (setq folder nil)))
 523     ;; Add provided folder to list, unless all folders are asked for.
 524     ;; Then append slash to separate sub-folders.
 525     (unless (null folder)
 526       (setq folder-list (list folder))
 527       (setq folder (concat folder "/")))
 528     (loop for f in (mh-sub-folders folder) do
 529           (setq folder-list
 530                 (append folder-list
 531                         (if (mh-children-p f)
 532                             (mh-folder-list (concat folder (car f)))
 533                           (list (concat folder (car f)))))))
 534     folder-list))
 535
 536 ;;;###mh-autoload
 537 (defun mh-sub-folders (folder &optional add-trailing-slash-flag)
 538   "Find the subfolders of FOLDER.
 539 The function avoids running folders unnecessarily by caching the
 540 results of the actual folders call.
 541
 542 If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a
 543 slash is added to each of the sub-folder names that may have
 544 nested folders within them."
 545   (let* ((folder (mh-normalize-folder-name folder nil nil t))
 546          (match (gethash folder mh-sub-folders-cache 'no-result))
 547          (sub-folders (cond ((eq match 'no-result)
 548                              (setf (gethash folder mh-sub-folders-cache)
 549                                    (mh-sub-folders-actual folder)))
 550                             (t match))))
 551     (if add-trailing-slash-flag
 552         (mapcar #'(lambda (x)
 553                     (if (cdr x) (cons (concat (car x) "/") (cdr x)) x))
 554                 sub-folders)
 555       sub-folders)))
 556
 557 ;; FIXME: This function does not do well if FOLDER does not exist. It
 558 ;; then changes the context to that folder which causes problems down
 559 ;; the line. Since a folder in the cache could later be deleted, it
 560 ;; would be good for mh-sub-folders-actual to return nil in this case
 561 ;; so that mh-sub-folders could delete it from the cache. This
 562 ;; function could protect itself by using a temporary context.
 563 (defun mh-sub-folders-actual (folder)
 564   "Execute the command folders to return the sub-folders of FOLDER.
 565 Filters out the folder names that start with \".\" so that
 566 directories that aren't usually mail folders are hidden.
 567 Expects FOLDER to have already been normalized with
 568   (mh-normalize-folder-name folder nil nil t)"
 569   (let ((arg-list `(,(expand-file-name "folders" mh-progs)
 570                     nil (t nil) nil "-noheader" "-norecurse" "-nototal"
 571                     ,@(if (stringp folder) (list folder) ())))
 572         (results ())
 573         (current-folder (concat
 574                          (with-temp-buffer
 575                            (call-process (expand-file-name "folder" mh-progs)
 576                                          nil '(t nil) nil "-fast")
 577                            (buffer-substring (point-min) (1- (point-max))))
 578                          "+")))
 579     (with-temp-buffer
 580       (apply #'call-process arg-list)
 581       (goto-char (point-min))
 582       (while (not (and (eolp) (bolp)))
 583         (goto-char (mh-line-end-position))
 584         (let ((start-pos (mh-line-beginning-position))
 585               (has-pos (search-backward " has "
 586                                         (mh-line-beginning-position) t)))
 587           (when (integerp has-pos)
 588             (while (equal (char-after has-pos) ? )
 589               (decf has-pos))
 590             (incf has-pos)
 591             (while (equal (char-after start-pos) ? )
 592               (incf start-pos))
 593             (let* ((name (buffer-substring start-pos has-pos))
 594                    (first-char (aref name 0))
 595                    (last-char (aref name (1- (length name)))))
 596               (unless (member first-char '(?. ?# ?,))
 597                 (when (and (equal last-char ?+) (equal name current-folder))
 598                   (setq name (substring name 0 (1- (length name)))))
 599                 (push
 600                  (cons name
 601                        (search-forward "(others)" (mh-line-end-position) t))
 602                  results))))
 603           (forward-line 1))))
 604     (setq results (nreverse results))
 605     (when (stringp folder)
 606       (setq results (cdr results))
 607       (let ((folder-name-len (length (format "%s/" (substring folder 1)))))
 608         (setq results (mapcar (lambda (f)
 609                                 (cons (substring (car f) folder-name-len)
 610                                       (cdr f)))
 611                               results))))
 612     results))
 613
 614 ;;;###mh-autoload
 615 (defun mh-remove-from-sub-folders-cache (folder)
 616   "Remove FOLDER and its parent from `mh-sub-folders-cache'.
 617 FOLDER should be unconditionally removed from the cache. Also the
 618 last ancestor of FOLDER present in the cache must be removed as
 619 well.
 620
 621 To see why this is needed assume we have a folder +foo which has
 622 a single sub-folder qux. Now we create the folder +foo/bar/baz.
 623 Here we will need to invalidate the cached sub-folders of +foo,
 624 otherwise completion on +foo won't tell us about the option
 625 +foo/bar!"
 626   (remhash folder mh-sub-folders-cache)
 627   (block ancestor-found
 628     (let ((parent folder)
 629           (one-ancestor-found nil)
 630           last-slash)
 631       (while (setq last-slash (mh-search-from-end ?/ parent))
 632         (setq parent (substring parent 0 last-slash))
 633         (unless (eq (gethash parent  mh-sub-folders-cache 'none) 'none)
 634           (remhash parent mh-sub-folders-cache)
 635           (if one-ancestor-found
 636               (return-from ancestor-found)
 637             (setq one-ancestor-found t))))
 638       (remhash nil mh-sub-folders-cache))))
 639
 640 \f
 641
 642 ;;; Folder Utilities
 643
 644 ;;;###mh-autoload
 645 (defun mh-folder-name-p (name)
 646   "Return non-nil if NAME is the name of a folder.
 647 A name (a string or symbol) can be a folder name if it begins
 648 with \"+\"."
 649   (if (symbolp name)
 650       (eq (aref (symbol-name name) 0) ?+)
 651     (and (> (length name) 0)
 652          (eq (aref name 0) ?+))))
 653
 654 ;;;###mh-autoload
 655 (defun mh-expand-file-name (filename &optional default)
 656   "Expand FILENAME like `expand-file-name', but also handle MH folder names.
 657 Any filename that starts with '+' is treated as a folder name.
 658 See `expand-file-name' for description of DEFAULT."
 659   (if (mh-folder-name-p filename)
 660       (expand-file-name (substring filename 1) mh-user-path)
 661     (expand-file-name filename default)))
 662
 663 (defvar mh-folder-hist nil)
 664
 665 ;; Shush compiler.
 666 (defvar mh-speed-flists-cache)
 667
 668 (defvar mh-allow-root-folder-flag nil
 669   "Non-nil means \"+\" is an acceptable folder name.
 670 This variable is used to communicate with
 671 `mh-folder-completion-function'. That function can have exactly
 672 three arguments so we bind this variable to t or nil.
 673
 674 This variable should never be set.")
 675
 676 (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map))
 677 (define-key mh-folder-completion-map " " 'minibuffer-complete)  ;Why???
 678
 679 (defvar mh-speed-flists-inhibit-flag nil)
 680
 681 ;;;###mh-autoload
 682 (defun mh-speed-flists-active-p ()
 683   "Check if speedbar is running with message counts enabled."
 684   (and (featurep 'mh-speed)
 685        (not mh-speed-flists-inhibit-flag)
 686        (> (hash-table-count mh-speed-flists-cache) 0)))
 687
 688 ;;;###mh-autoload
 689 (defun mh-folder-completion-function (name predicate flag)
 690   "Programmable completion for folder names.
 691 NAME is the partial folder name that has been input. PREDICATE if
 692 non-nil is a function that is used to filter the possible
 693 choices. FLAG is nil to indicate `try-completion', t for
 694 `all-completions', or the symbol lambda for `test-completion'.
 695 See Info node `(elisp) Programmed Completion' for details."
 696   (let* ((orig-name name)
 697          ;; After normalization, name is nil, +, or +something. If a
 698          ;; trailing slash is present, it is preserved.
 699          (name (mh-normalize-folder-name name nil t))
 700          (last-slash (mh-search-from-end ?/ name))
 701          ;; nil if + or +folder; +folder/ if slash present.
 702          (last-complete (if last-slash (substring name 0 (1+ last-slash)) nil))
 703          ;; Either +folder/remainder, +remainder, or "".
 704          (remainder (cond (last-complete (substring name (1+ last-slash)))
 705                           (name (substring name 1))
 706                           (t ""))))
 707     (cond ((eq flag nil)
 708            (let ((try-res
 709                   (try-completion
 710                    name
 711                    (mapcar (lambda (x)
 712                              (cons (concat (or last-complete "+") (car x))
 713                                    (cdr x)))
 714                     (mh-sub-folders last-complete t))
 715                    predicate)))
 716              (cond ((eq try-res nil) nil)
 717                    ((and (eq try-res t) (equal name orig-name)) t)
 718                    ((eq try-res t) name)
 719                    (t try-res))))
 720           ((eq flag t)
 721            (mapcar (lambda (x)
 722                      (concat (or last-complete "+") x))
 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-exists-p path))
 731                    ((equal path mh-user-path) nil)
 732                    (t (file-exists-p path))))))))
 733
 734 ;; Shush compiler.
 735 (defvar completion-root-regexp)          ; XEmacs
 736 (defvar minibuffer-completing-file-name) ; XEmacs
 737
 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))
 748    t))
 749
 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))
 811
 812 \f
 813
 814 ;;; Message Utilities
 815
 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.
 819
 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)))
 824
 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:"))
 830         nil
 831       (skip-chars-forward " \t")
 832       (buffer-substring-no-properties
 833        (point) (progn (mh-header-field-end)(point))))))
 834
 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     ""))
 847
 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)))
 859
 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)))
 866
 867 ;;;###mh-autoload
 868 (defun mh-mail-header-end ()
 869   "Substitute for `mail-header-end' that doesn't widen the buffer.
 870
 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)))
 888
 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)))
 896
 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
 905
 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)))))
 918
 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)))
 926
 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))
 935
 936 ;;;###mh-autoload
 937 (defun mh-letter-toggle-header-field-display (arg)
 938   "Toggle display of header field at point.
 939
 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)))))
 981
 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 " "))))
 992
 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)))))
1001
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)))
1008
1009 (provide 'mh-utils)
1010
1011 ;; Local Variables:
1012 ;; indent-tabs-mode: nil
1013 ;; sentence-end-double-space: nil
1014 ;; End:
1015
1016 ;;; mh-utils.el ends here