code.delx.au - gnu-emacs/blob - lisp/mh-e/mh-utils.el

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