cgit.sxemacs.org Git - packages/blob - xemacs-packages/mh-e/mh-utils.el

   1 ;;; mh-utils.el --- MH-E code needed for both sending and reading
   2
   3 ;; Copyright (C) 1993, 95, 1997,
   4 ;;  2000, 01, 02, 2003 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., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Internal support for MH-E package.
  31
  32 ;;; Change Log:
  33
  34 ;;; Code:
  35
  36 ;; Is this XEmacs-land? Located here since needed by mh-customize.el.
  37 (defvar mh-xemacs-flag (featurep 'xemacs)
  38   "Non-nil means the current Emacs is XEmacs.")
  39
  40 (require 'cl)
  41 (require 'gnus-util)
  42 (require 'font-lock)
  43 (load "tool-bar" t t)
  44 (require 'mh-loaddefs)
  45 (require 'mh-customize)
  46 (require 'mh-inc)
  47
  48 (load "mm-decode" t t)                  ; Non-fatal dependency
  49 (load "mm-view" t t)                    ; Non-fatal dependency
  50 (load "hl-line" t t)                    ; Non-fatal dependency
  51 (load "executable" t t)                 ; Non-fatal dependency on
  52                                         ; executable-find
  53
  54 ;; Shush the byte-compiler
  55 (defvar font-lock-auto-fontify)
  56 (defvar font-lock-defaults)
  57 (defvar mark-active)
  58
  59 ;;; Autoloads
  60 (autoload 'gnus-article-highlight-citation "gnus-cite")
  61 (require 'sendmail)
  62 (autoload 'Info-goto-node "info")
  63 (unless (fboundp 'make-hash-table)
  64   (autoload 'make-hash-table "cl"))
  65
  66 ;;; Set for local environment:
  67 ;;; mh-progs and mh-lib used to be set in paths.el, which tried to
  68 ;;; figure out at build time which of several possible directories MH
  69 ;;; was installed into.  But if you installed MH after building Emacs,
  70 ;;; this would almost certainly be wrong, so now we do it at run time.
  71
  72 (defvar mh-progs nil
  73   "Directory containing MH commands, such as inc, repl, and rmm.")
  74
  75 (defvar mh-lib nil
  76   "Directory containing the MH library.
  77 This directory contains, among other things, the components file.")
  78
  79 (defvar mh-lib-progs nil
  80   "Directory containing MH helper programs.
  81 This directory contains, among other things, the mhl program.")
  82
  83 (defvar mh-nmh-flag nil
  84   "Non-nil means nmh is installed on this system instead of MH.")
  85
  86 (defvar mh-flists-present-flag nil
  87   "Non-nil means that we have `flists'.")
  88
  89 ;;;###autoload
  90 (put 'mh-progs 'risky-local-variable t)
  91 ;;;###autoload
  92 (put 'mh-lib 'risky-local-variable t)
  93 ;;;###autoload
  94 (put 'mh-lib-progs 'risky-local-variable t)
  95 ;;;###autoload
  96 (put 'mh-nmh-flag 'risky-local-variable t)
  97
  98 ;;; CL Replacements
  99 (defun mh-search-from-end (char string)
 100   "Return the position of last occurrence of CHAR in STRING.
 101 If CHAR is not present in STRING then return nil. The function is used in lieu
 102 of `search' in the CL package."
 103   (loop for index from (1- (length string)) downto 0
 104         when (equal (aref string index) char) return index
 105         finally return nil))
 106
 107 ;;; Macros to generate correct code for different emacs variants
 108
 109 (defmacro mh-do-in-gnu-emacs (&rest body)
 110   "Execute BODY if in GNU Emacs."
 111   (unless mh-xemacs-flag `(progn ,@body)))
 112 (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)
 113
 114 (defmacro mh-do-in-xemacs (&rest body)
 115   "Execute BODY if in GNU Emacs."
 116   (when mh-xemacs-flag `(progn ,@body)))
 117 (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)
 118
 119 (defmacro mh-funcall-if-exists (function &rest args)
 120   "Call FUNCTION with ARGS as parameters if it exists."
 121   `(if (fboundp ',function)
 122     (funcall ',function ,@args)))
 123
 124 (defmacro mh-make-local-hook (hook)
 125   "Make HOOK local if needed.
 126 XEmacs and versions of GNU Emacs before 21.1 require `make-local-hook' to be
 127 called."
 128   (when (and (fboundp 'make-local-hook)
 129              (not (get 'make-local-hook 'byte-obsolete-info)))
 130     `(make-local-hook ,hook)))
 131
 132 (defmacro mh-mark-active-p (check-transient-mark-mode-flag)
 133   "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.
 134 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if
 135 variable `transient-mark-mode' is active."
 136   (cond (mh-xemacs-flag                 ;XEmacs
 137          `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))
 138         ((not check-transient-mark-mode-flag) ;GNU Emacs
 139          `(and (boundp 'mark-active) mark-active))
 140         (t                              ;GNU Emacs
 141          `(and (boundp 'transient-mark-mode) transient-mark-mode
 142                (boundp 'mark-active) mark-active))))
 143
 144 ;;; Additional header fields that might someday be added:
 145 ;;; "Sender: " "Reply-to: "
 146
 147 (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)"
 148   "Regexp to find the number of a message in a scan line.
 149 The message's number must be surrounded with \\( \\)")
 150
 151 (defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]"
 152   "Regexp to find a scan line in which the message number overflowed.
 153 The message's number is left truncated in this case.")
 154
 155 (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)"
 156   "Regexp to find message number width in an scan format.
 157 The message number width must be surrounded with \\( \\).")
 158
 159 (defvar mh-scan-msg-format-string "%d"
 160   "Format string for width of the message number in a scan format.
 161 Use `0%d' for zero-filled message numbers.")
 162
 163 (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]"
 164   "Format string containing a regexp matching the scan listing for a message.
 165 The desired message's number will be an argument to format.")
 166
 167 (defvar mh-default-folder-for-message-function nil
 168   "Function to select a default folder for refiling or Fcc.
 169 If set to a function, that function is called with no arguments by
 170 `\\[mh-refile-msg]' and `\\[mh-to-fcc]' to get a default when
 171 prompting the user for a folder.  The function is called from within a
 172 `save-excursion', with point at the start of the message.  It should
 173 return the folder to offer as the refile or Fcc folder, as a string
 174 with a leading `+' sign.  It can also return an empty string to use no
 175 default, or nil to calculate the default the usual way.
 176 NOTE: This variable is not an ordinary hook;
 177 It may not be a list of functions.")
 178
 179 (defvar mh-show-buffer-mode-line-buffer-id "    {show-%s} %d"
 180   "Format string to produce `mode-line-buffer-identification' for show buffers.
 181 First argument is folder name.  Second is message number.")
 182
 183 (defvar mh-cmd-note 4
 184   "Column to insert notation.
 185 Use `mh-set-cmd-note' to modify it.
 186 This value may be dynamically updated if `mh-adaptive-cmd-note-flag' is
 187 non-nil and `mh-scan-format-file' is t.
 188 Note that the first column is column number 0.")
 189 (make-variable-buffer-local 'mh-cmd-note)
 190
 191 (defvar mh-note-seq "%"
 192   "String whose first character is used to notate messages in a sequence.")
 193
 194 (defvar mh-mail-header-separator "--------"
 195   "*Line used by MH to separate headers from text in messages being composed.
 196 This variable should not be used directly in programs. Programs should use
 197 `mail-header-separator' instead. `mail-header-separator' is initialized to
 198 `mh-mail-header-separator' in `mh-letter-mode'; in other contexts, you may
 199 have to perform this initialization yourself.
 200
 201 Do not make this a regexp as it may be the argument to `insert' and it is
 202 passed through `regexp-quote' before being used by functions like
 203 `re-search-forward'.")
 204
 205 ;; Variables for MIME display
 206
 207 ;; Structure to keep track of MIME handles on a per buffer basis.
 208 (defstruct (mh-buffer-data (:conc-name mh-mime-)
 209                            (:constructor mh-make-buffer-data))
 210   (handles ())                          ; List of MIME handles
 211   (handles-cache (make-hash-table))     ; Cache to avoid multiple decodes of
 212                                         ; nested messages
 213   (parts-count 0)                       ; The button number is generated from
 214                                         ; this number
 215   (part-index-hash (make-hash-table)))  ; Avoid incrementing the part number
 216                                         ; for nested messages
 217 ;;; This has to be a macro, since we do: (setf (mh-buffer-data) ...)
 218 (defmacro mh-buffer-data ()
 219   "Convenience macro to get the MIME data structures of the current buffer."
 220   `(gethash (current-buffer) mh-globals-hash))
 221
 222 (defvar mh-globals-hash (make-hash-table)
 223   "Keeps track of MIME data on a per buffer basis.")
 224
 225 (defvar mh-gnus-pgp-support-flag (not (not (locate-library "mml2015")))
 226   "Non-nil means installed Gnus has PGP support.")
 227
 228 (defvar mh-mm-inline-media-tests
 229   `(("image/jpeg"
 230      mm-inline-image
 231      (lambda (handle)
 232        (mm-valid-and-fit-image-p 'jpeg handle)))
 233     ("image/png"
 234      mm-inline-image
 235      (lambda (handle)
 236        (mm-valid-and-fit-image-p 'png handle)))
 237     ("image/gif"
 238      mm-inline-image
 239      (lambda (handle)
 240        (mm-valid-and-fit-image-p 'gif handle)))
 241     ("image/tiff"
 242      mm-inline-image
 243      (lambda (handle)
 244        (mm-valid-and-fit-image-p 'tiff handle)) )
 245     ("image/xbm"
 246      mm-inline-image
 247      (lambda (handle)
 248        (mm-valid-and-fit-image-p 'xbm handle)))
 249     ("image/x-xbitmap"
 250      mm-inline-image
 251      (lambda (handle)
 252        (mm-valid-and-fit-image-p 'xbm handle)))
 253     ("image/xpm"
 254      mm-inline-image
 255      (lambda (handle)
 256        (mm-valid-and-fit-image-p 'xpm handle)))
 257     ("image/x-pixmap"
 258      mm-inline-image
 259      (lambda (handle)
 260        (mm-valid-and-fit-image-p 'xpm handle)))
 261     ("image/bmp"
 262      mm-inline-image
 263      (lambda (handle)
 264        (mm-valid-and-fit-image-p 'bmp handle)))
 265     ("image/x-portable-bitmap"
 266      mm-inline-image
 267      (lambda (handle)
 268        (mm-valid-and-fit-image-p 'pbm handle)))
 269     ("text/plain" mm-inline-text identity)
 270     ("text/enriched" mm-inline-text identity)
 271     ("text/richtext" mm-inline-text identity)
 272     ("text/x-patch" mm-display-patch-inline
 273      (lambda (handle)
 274        (locate-library "diff-mode")))
 275     ("application/emacs-lisp" mm-display-elisp-inline identity)
 276     ("application/x-emacs-lisp" mm-display-elisp-inline identity)
 277     ("text/html"
 278      ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text)
 279      (lambda (handle)
 280        (or (and (boundp 'mm-inline-text-html-renderer)
 281                 mm-inline-text-html-renderer)
 282            (and (boundp 'mm-text-html-renderer) mm-text-html-renderer))))
 283     ("text/x-vcard"
 284      mm-inline-text-vcard
 285      (lambda (handle)
 286        (or (featurep 'vcard)
 287            (locate-library "vcard"))))
 288     ("message/delivery-status" mm-inline-text identity)
 289     ("message/rfc822" mh-mm-inline-message identity)
 290     ;;("message/partial" mm-inline-partial identity)
 291     ;;("message/external-body" mm-inline-external-body identity)
 292     ("text/.*" mm-inline-text identity)
 293     ("audio/wav" mm-inline-audio
 294      (lambda (handle)
 295        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 296             (device-sound-enabled-p))))
 297     ("audio/au"
 298      mm-inline-audio
 299      (lambda (handle)
 300        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 301             (device-sound-enabled-p))))
 302     ("application/pgp-signature" ignore identity)
 303     ("application/x-pkcs7-signature" ignore identity)
 304     ("application/pkcs7-signature" ignore identity)
 305     ("application/x-pkcs7-mime" ignore identity)
 306     ("application/pkcs7-mime" ignore identity)
 307     ("multipart/alternative" ignore identity)
 308     ("multipart/mixed" ignore identity)
 309     ("multipart/related" ignore identity)
 310     ;; Disable audio and image
 311     ("audio/.*" ignore ignore)
 312     ("image/.*" ignore ignore)
 313     ;; Default to displaying as text
 314     (".*" mm-inline-text mm-readable-p))
 315   "Alist of media types/tests saying whether types can be displayed inline.")
 316
 317 ;; Copy of `goto-address-mail-regexp'
 318 (defvar mh-address-mail-regexp
 319   "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
 320   "A regular expression probably matching an e-mail address.")
 321
 322 ;; From goto-addr.el, which we don't want to force-load on users.
 323 ;;;###mh-autoload
 324 (defun mh-goto-address-find-address-at-point ()
 325   "Find e-mail address around or before point.
 326 Then search backwards to beginning of line for the start of an e-mail
 327 address.  If no e-mail address found, return nil."
 328   (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim)
 329   (if (or (looking-at mh-address-mail-regexp)   ; already at start
 330           (and (re-search-forward mh-address-mail-regexp
 331                                   (line-end-position) 'lim)
 332                (goto-char (match-beginning 0))))
 333       (match-string-no-properties 0)))
 334
 335 (defun mh-mail-header-end ()
 336   "Substitute for `mail-header-end' that doesn't widen the buffer.
 337 In MH-E we frequently need to find the end of headers in nested messages, where
 338 the buffer has been narrowed. This function works in this situation."
 339   (save-excursion
 340     (rfc822-goto-eoh)
 341     (point)))
 342
 343 (defun mh-in-header-p ()
 344   "Return non-nil if the point is in the header of a draft message."
 345   (< (point) (mh-mail-header-end)))
 346
 347 (defun mh-header-field-beginning ()
 348   "Move to the beginning of the current header field.
 349 Handles RFC 822 continuation lines."
 350   (beginning-of-line)
 351   (while (looking-at "^[ \t]")
 352     (forward-line -1)))
 353
 354 (defun mh-header-field-end ()
 355   "Move to the end of the current header field.
 356 Handles RFC 822 continuation lines."
 357   (forward-line 1)
 358   (while (looking-at "^[ \t]")
 359     (forward-line 1))
 360   (backward-char 1))                    ;to end of previous line
 361
 362 (defun mh-letter-header-font-lock (limit)
 363   "Return the entire mail header to font-lock.
 364 Argument LIMIT limits search."
 365   (if (= (point) limit)
 366       nil
 367     (let* ((mail-header-end (save-match-data (mh-mail-header-end)))
 368            (lesser-limit (if (< mail-header-end limit) mail-header-end limit)))
 369       (when (mh-in-header-p)
 370         (set-match-data (list 1 lesser-limit))
 371         (goto-char lesser-limit)
 372         t))))
 373
 374 (defun mh-header-field-font-lock (field limit)
 375   "Return the value of a header field FIELD to font-lock.
 376 Argument LIMIT limits search."
 377   (if (= (point) limit)
 378       nil
 379     (let* ((mail-header-end (mh-mail-header-end))
 380            (lesser-limit (if (< mail-header-end limit) mail-header-end limit))
 381            (case-fold-search t))
 382       (when (and (< (point) mail-header-end) ;Only within header
 383                  (re-search-forward (format "^%s" field) lesser-limit t))
 384         (let ((match-one-b (match-beginning 0))
 385               (match-one-e (match-end 0)))
 386           (mh-header-field-end)
 387           (if (> (point) limit)         ;Don't search for end beyond limit
 388               (goto-char limit))
 389           (set-match-data (list match-one-b match-one-e
 390                                 (1+ match-one-e) (point)))
 391           t)))))
 392
 393 (defun mh-header-to-font-lock (limit)
 394   "Return the value of a header field To to font-lock.
 395 Argument LIMIT limits search."
 396   (mh-header-field-font-lock "To:" limit))
 397
 398 (defun mh-header-cc-font-lock (limit)
 399   "Return the value of a header field cc to font-lock.
 400 Argument LIMIT limits search."
 401   (mh-header-field-font-lock "cc:" limit))
 402
 403 (defun mh-header-subject-font-lock (limit)
 404   "Return the value of a header field Subject to font-lock.
 405 Argument LIMIT limits search."
 406   (mh-header-field-font-lock "Subject:" limit))
 407
 408 (eval-and-compile
 409   ;; Otherwise byte-compilation fails on `mh-show-font-lock-keywords-with-cite'
 410   (defvar mh-show-font-lock-keywords
 411     '(("^\\(From:\\|Sender:\\)\\(.*\\)"  (1 'default) (2 mh-show-from-face))
 412       (mh-header-to-font-lock            (0 'default) (1 mh-show-to-face))
 413       (mh-header-cc-font-lock            (0 'default) (1 mh-show-cc-face))
 414       ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$"
 415        (1 'default) (2 mh-show-from-face))
 416       (mh-header-subject-font-lock       (0 'default) (1 mh-show-subject-face))
 417       ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)"
 418        (1 'default) (2 mh-show-cc-face))
 419       ("^\\(In-reply-to\\|Date\\):\\(.*\\)$"
 420        (1 'default) (2 mh-show-date-face))
 421       (mh-letter-header-font-lock        (0 mh-show-header-face append t)))
 422     "Additional expressions to highlight in MH-show mode."))
 423
 424 (defvar mh-show-font-lock-keywords-with-cite
 425   (eval-when-compile
 426     (let* ((cite-chars "[>|}]")
 427            (cite-prefix "A-Za-z")
 428            (cite-suffix (concat cite-prefix "0-9_.@-`'\"")))
 429       (append
 430        mh-show-font-lock-keywords
 431        (list
 432         ;; Use MATCH-ANCHORED to effectively anchor the regexp left side.
 433         `(,cite-chars
 434           (,(concat "\\=[ \t]*"
 435                     "\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
 436                     "\\(" cite-chars "[ \t]*\\)\\)+"
 437                     "\\(.*\\)")
 438            (beginning-of-line) (end-of-line)
 439            (2 font-lock-constant-face nil t)
 440            (4 font-lock-comment-face nil t)))))))
 441   "Additional expressions to highlight in MH-show mode.")
 442
 443 (defvar mh-letter-font-lock-keywords
 444   `(,@mh-show-font-lock-keywords-with-cite
 445     (mh-font-lock-field-data (1 'mh-letter-header-field-face prepend t))))
 446
 447 (defun mh-show-font-lock-fontify-region (beg end loudly)
 448   "Limit font-lock in `mh-show-mode' to the header.
 449 Used when `mh-highlight-citation-p' is set to gnus, leaving the body to be
 450 dealt with by gnus highlighting. The region between BEG and END is
 451 given over to be fontified and LOUDLY controls if a user sees a
 452 message about the fontification operation."
 453   (let ((header-end (mh-mail-header-end)))
 454     (cond
 455      ((and (< beg header-end)(< end header-end))
 456       (font-lock-default-fontify-region beg end loudly))
 457      ((and (< beg header-end)(>= end header-end))
 458       (font-lock-default-fontify-region beg header-end loudly))
 459      (t
 460       nil))))
 461
 462 ;; Needed to help shush the byte-compiler.
 463 (if mh-xemacs-flag
 464     (progn
 465       (eval-and-compile
 466         (require 'gnus)
 467         (require 'gnus-art)
 468         (require 'gnus-cite))))
 469
 470 (defun mh-gnus-article-highlight-citation ()
 471   "Highlight cited text in current buffer using gnus."
 472   (interactive)
 473   ;; Requiring gnus-cite should have been sufficient. However for Emacs21.1,
 474   ;; recursive-load-depth-limit is only 10, so an error occurs. Also it may be
 475   ;; better to have an autoload at top-level (though that won't work because
 476   ;; of recursive-load-depth-limit). That gets rid of a compiler warning as
 477   ;; well.
 478   (unless mh-xemacs-flag
 479     (require 'gnus-art)
 480     (require 'gnus-cite))
 481   ;; Don't allow Gnus to create buttons while highlighting, maybe this is bad
 482   ;; style?
 483   (flet ((gnus-article-add-button (&rest args) nil))
 484     (let* ((modified (buffer-modified-p))
 485            (gnus-article-buffer (buffer-name))
 486            (gnus-cite-face-list `(,@(cdr gnus-cite-face-list)
 487                                     ,(car gnus-cite-face-list))))
 488       (gnus-article-highlight-citation t)
 489       (set-buffer-modified-p modified))))
 490
 491 ;;; Internal bookkeeping variables:
 492
 493 ;; Cached value of the `Path:' component in the user's MH profile.
 494 ;; User's mail folder directory.
 495 (defvar mh-user-path nil)
 496
 497 ;; An mh-draft-folder of nil means do not use a draft folder.
 498 ;; Cached value of the `Draft-Folder:' component in the user's MH profile.
 499 ;; Name of folder containing draft messages.
 500 (defvar mh-draft-folder nil)
 501
 502 ;; Cached value of the `Unseen-Sequence:' component in the user's MH profile.
 503 ;; Name of the Unseen sequence.
 504 (defvar mh-unseen-seq nil)
 505
 506 ;; Cached value of the `Previous-Sequence:' component in the user's MH
 507 ;; profile.
 508 ;; Name of the Previous sequence.
 509 (defvar mh-previous-seq nil)
 510
 511 ;; Cached value of the `Inbox:' component in the user's MH profile,
 512 ;; or "+inbox" if no such component.
 513 ;; Name of the Inbox folder.
 514 (defvar mh-inbox nil)
 515
 516 ;; The names of ephemeral buffers have a " *mh-" prefix (so that they are
 517 ;; hidden and can be programmatically removed in mh-quit), and the variable
 518 ;; names have the form mh-temp-.*-buffer.
 519 (defconst mh-temp-buffer " *mh-temp*")  ;scratch
 520
 521 ;; The names of MH-E buffers that are not ephemeral and can be used by the
 522 ;; user (and deleted by the user when no longer needed) have a "*MH-E " prefix
 523 ;; (so they can be programmatically removed in mh-quit), and the variable
 524 ;; names have the form mh-.*-buffer.
 525 (defconst mh-folders-buffer "*MH-E Folders*") ;folder list
 526 (defconst mh-info-buffer "*MH-E Info*") ;version information buffer
 527 (defconst mh-log-buffer "*MH-E Log*") ;output of MH commands and so on
 528 (defconst mh-recipients-buffer "*MH-E Recipients*") ;killed when draft sent
 529 (defconst mh-sequences-buffer "*MH-E Sequences*") ;sequences list
 530 (defconst mh-mail-delivery-buffer "*MH-E Mail Delivery*") ;mail delivery log
 531
 532 ;; Number of lines to keep in mh-log-buffer.
 533 (defvar mh-log-buffer-lines 100)
 534
 535 ;; Window configuration before MH-E command.
 536 (defvar mh-previous-window-config nil)
 537
 538 ;;Non-nil means next SPC or whatever goes to next undeleted message.
 539 (defvar mh-page-to-next-msg-flag nil)
 540
 541 ;;; Internal variables local to a folder.
 542
 543 ;; Name of current folder, a string.
 544 (defvar mh-current-folder nil)
 545
 546 ;; Buffer that displays message for this folder.
 547 (defvar mh-show-buffer nil)
 548
 549 ;; Full path of directory for this folder.
 550 (defvar mh-folder-filename nil)
 551
 552 ;;Number of msgs in buffer.
 553 (defvar mh-msg-count nil)
 554
 555 ;; If non-nil, show the message in a separate window.
 556 (defvar mh-showing-mode nil)
 557
 558 (defvar mh-show-mode-map (make-sparse-keymap)
 559   "Keymap used by the show buffer.")
 560
 561 (defvar mh-show-folder-buffer nil
 562   "Keeps track of folder whose message is being displayed.")
 563
 564 (defvar mh-logo-cache nil)
 565
 566 (defun mh-logo-display ()
 567   "Modify mode line to display MH-E logo."
 568   (mh-do-in-gnu-emacs
 569    (add-text-properties
 570     0 2
 571     `(display ,(or mh-logo-cache
 572                    (setq mh-logo-cache
 573                          (mh-funcall-if-exists
 574                           find-image '((:type xpm :ascent center
 575                                               :file "mh-logo.xpm"))))))
 576     (car mode-line-buffer-identification)))
 577   (mh-do-in-xemacs
 578    (setq modeline-buffer-identification
 579          (list
 580           (if mh-modeline-glyph
 581               (cons modeline-buffer-id-left-extent mh-modeline-glyph)
 582             (cons modeline-buffer-id-left-extent "XEmacs%N:"))
 583           (cons modeline-buffer-id-right-extent " %17b")))))
 584
 585
 586 ;;; This holds a documentation string used by describe-mode.
 587 (defun mh-showing-mode (&optional arg)
 588   "Change whether messages should be displayed.
 589 With arg, display messages iff ARG is positive."
 590   (setq mh-showing-mode
 591         (if (null arg)
 592             (not mh-showing-mode)
 593           (> (prefix-numeric-value arg) 0))))
 594
 595 ;; The sequences of this folder.  An alist of (seq . msgs).
 596 (defvar mh-seq-list nil)
 597
 598 ;; List of displayed messages to be removed from the Unseen sequence.
 599 (defvar mh-seen-list nil)
 600
 601 ;; If non-nil, show buffer contains message with all headers.
 602 ;; If nil, show buffer contains message processed normally.
 603 ;; Showing message with headers or normally.
 604 (defvar mh-showing-with-headers nil)
 605
 606
 607 ;;; MH-E macros
 608
 609 (defmacro with-mh-folder-updating (save-modification-flag &rest body)
 610   "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY).
 611 Execute BODY, which can modify the folder buffer without having to
 612 worry about file locking or the read-only flag, and return its result.
 613 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification
 614 flag is unchanged, otherwise it is cleared."
 615   (setq save-modification-flag (car save-modification-flag)) ; CL style
 616   `(prog1
 617        (let ((mh-folder-updating-mod-flag (buffer-modified-p))
 618              (buffer-read-only nil)
 619              (buffer-file-name nil))    ;don't let the buffer get locked
 620          (prog1
 621              (progn
 622                ,@body)
 623            (mh-set-folder-modified-p mh-folder-updating-mod-flag)))
 624      ,@(if (not save-modification-flag)
 625            '((mh-set-folder-modified-p nil)))))
 626
 627 (put 'with-mh-folder-updating 'lisp-indent-hook 'defun)
 628
 629 (defmacro mh-in-show-buffer (show-buffer &rest body)
 630   "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY).
 631 Display buffer SHOW-BUFFER in other window and execute BODY in it.
 632 Stronger than `save-excursion', weaker than `save-window-excursion'."
 633   (setq show-buffer (car show-buffer))  ; CL style
 634   `(let ((mh-in-show-buffer-saved-window (selected-window)))
 635      (switch-to-buffer-other-window ,show-buffer)
 636      (if mh-bury-show-buffer-flag (bury-buffer (current-buffer)))
 637      (unwind-protect
 638          (progn
 639            ,@body)
 640        (select-window mh-in-show-buffer-saved-window))))
 641
 642 (put 'mh-in-show-buffer 'lisp-indent-hook 'defun)
 643
 644 (defmacro mh-do-at-event-location (event &rest body)
 645   "Switch to the location of EVENT and execute BODY.
 646 After BODY has been executed return to original window. The modification flag
 647 of the buffer in the event window is preserved."
 648   (let ((event-window (make-symbol "event-window"))
 649         (event-position (make-symbol "event-position"))
 650         (original-window (make-symbol "original-window"))
 651         (original-position (make-symbol "original-position"))
 652         (modified-flag (make-symbol "modified-flag")))
 653     `(save-excursion
 654        (let* ((,event-window
 655                (or (mh-funcall-if-exists posn-window (event-start ,event))
 656                    (mh-funcall-if-exists event-window ,event)))
 657               (,event-position
 658                (or (mh-funcall-if-exists posn-point (event-start ,event))
 659                    (mh-funcall-if-exists event-closest-point ,event)))
 660               (,original-window (selected-window))
 661               (,original-position (progn
 662                                    (set-buffer (window-buffer ,event-window))
 663                                    (set-marker (make-marker) (point))))
 664               (,modified-flag (buffer-modified-p))
 665               (buffer-read-only nil))
 666          (unwind-protect (progn
 667                            (select-window ,event-window)
 668                            (goto-char ,event-position)
 669                            ,@body)
 670            (set-buffer-modified-p ,modified-flag)
 671            (goto-char ,original-position)
 672            (set-marker ,original-position nil)
 673            (select-window ,original-window))))))
 674
 675 (put 'mh-do-at-event-location 'lisp-indent-hook 'defun)
 676
 677 (defmacro mh-make-seq (name msgs)
 678   "Create sequence NAME with the given MSGS."
 679   (list 'cons name msgs))
 680
 681 (defmacro mh-seq-name (sequence)
 682   "Extract sequence name from the given SEQUENCE."
 683   (list 'car sequence))
 684
 685 (defmacro mh-seq-msgs (sequence)
 686   "Extract messages from the given SEQUENCE."
 687   (list 'cdr sequence))
 688
 689 (defun mh-recenter (arg)
 690   "Like recenter but with three improvements:
 691 - At the end of the buffer it tries to show fewer empty lines.
 692 - operates only if the current buffer is in the selected window.
 693   (Commands like `save-some-buffers' can make this false.)
 694 - nil ARG means recenter as if prefix argument had been given."
 695   (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window)))
 696          nil)
 697         ((= (point-max) (save-excursion
 698                           (forward-line (- (/ (window-height) 2) 2))
 699                           (point)))
 700          (let ((lines-from-end 2))
 701            (save-excursion
 702              (while (> (point-max) (progn (forward-line) (point)))
 703                (incf lines-from-end)))
 704            (recenter (- lines-from-end))))
 705         ;; '(4) is the same as C-u prefix argument.
 706         (t (recenter (or arg '(4))))))
 707
 708 (defun mh-start-of-uncleaned-message ()
 709   "Position uninteresting headers off the top of the window."
 710   (let ((case-fold-search t))
 711     (re-search-forward
 712      "^To:\\|^Cc:\\|^From:\\|^Subject:\\|^Date:" nil t)
 713     (beginning-of-line)
 714     (mh-recenter 0)))
 715
 716 (defun mh-invalidate-show-buffer ()
 717   "Invalidate the show buffer so we must update it to use it."
 718   (if (get-buffer mh-show-buffer)
 719       (save-excursion
 720         (set-buffer mh-show-buffer)
 721         (mh-unvisit-file))))
 722
 723 (defun mh-unvisit-file ()
 724   "Separate current buffer from the message file it was visiting."
 725   (or (not (buffer-modified-p))
 726       (null buffer-file-name)           ;we've been here before
 727       (yes-or-no-p (format "Message %s modified; flush changes? "
 728                            (file-name-nondirectory buffer-file-name)))
 729       (error "Flushing changes not confirmed"))
 730   (clear-visited-file-modtime)
 731   (unlock-buffer)
 732   (setq buffer-file-name nil))
 733
 734 ;;;###mh-autoload
 735 (defun mh-get-msg-num (error-if-no-message)
 736   "Return the message number of the displayed message.
 737 If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is
 738 not pointing to a message."
 739   (save-excursion
 740     (beginning-of-line)
 741     (cond ((looking-at mh-scan-msg-number-regexp)
 742            (string-to-int (buffer-substring (match-beginning 1)
 743                                             (match-end 1))))
 744           (error-if-no-message
 745            (error "Cursor not pointing to message"))
 746           (t nil))))
 747
 748 (defun mh-folder-name-p (name)
 749   "Return non-nil if NAME is the name of a folder.
 750 A name (a string or symbol) can be a folder name if it begins with \"+\"."
 751   (if (symbolp name)
 752       (eq (aref (symbol-name name) 0) ?+)
 753     (and (> (length name) 0)
 754          (eq (aref name 0) ?+))))
 755
 756
 757 (defun mh-expand-file-name (filename &optional default)
 758   "Expand FILENAME like `expand-file-name', but also handle MH folder names.
 759 Any filename that starts with '+' is treated as a folder name.
 760 See `expand-file-name' for description of DEFAULT."
 761   (if (mh-folder-name-p filename)
 762       (expand-file-name (substring filename 1) mh-user-path)
 763     (expand-file-name filename default)))
 764
 765
 766 (defun mh-msg-filename (msg &optional folder)
 767   "Return the file name of MSG in FOLDER (default current folder)."
 768   (expand-file-name (int-to-string msg)
 769                     (if folder
 770                         (mh-expand-file-name folder)
 771                       mh-folder-filename)))
 772
 773 ;;; Infrastructure to generate show-buffer functions from folder functions
 774 ;;; XEmacs does not have deactivate-mark? What is the equivalent of
 775 ;;; transient-mark-mode for XEmacs? Should we be restoring the mark in the
 776 ;;; folder buffer after the operation has been carried out.
 777 (defmacro mh-defun-show-buffer (function original-function
 778                                          &optional dont-return)
 779   "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer.
 780 If the buffer we start in is still visible and DONT-RETURN is nil then switch
 781 to it after that."
 782   `(defun ,function ()
 783      ,(format "Calls %s from the message's folder.\n%s\nSee `%s' for more info.\n"
 784               original-function
 785               (if dont-return ""
 786                 "When function completes, returns to the show buffer if it is
 787 still visible.\n")
 788               original-function)
 789      (interactive)
 790      (when (buffer-live-p (get-buffer mh-show-folder-buffer))
 791        (let ((config (current-window-configuration))
 792              (folder-buffer mh-show-folder-buffer)
 793              (normal-exit nil)
 794              ,@(if dont-return () '((cur-buffer-name (buffer-name)))))
 795          (pop-to-buffer mh-show-folder-buffer nil)
 796          (unless (equal (buffer-name
 797                          (window-buffer (frame-first-window (selected-frame))))
 798                         folder-buffer)
 799            (delete-other-windows))
 800          (mh-goto-cur-msg t)
 801          (mh-funcall-if-exists deactivate-mark)
 802          (unwind-protect
 803              (prog1 (call-interactively (function ,original-function))
 804                (setq normal-exit t))
 805            (mh-funcall-if-exists deactivate-mark)
 806            (when (eq major-mode 'mh-folder-mode)
 807              (mh-funcall-if-exists hl-line-highlight))
 808            (cond ((not normal-exit)
 809                   (set-window-configuration config))
 810                  ,(if dont-return
 811                       `(t (setq mh-previous-window-config config))
 812                     `((and (get-buffer cur-buffer-name)
 813                            (window-live-p (get-buffer-window
 814                                            (get-buffer cur-buffer-name))))
 815                       (pop-to-buffer (get-buffer cur-buffer-name) nil)))))))))
 816
 817 ;;; Generate interactive functions for the show buffer from the corresponding
 818 ;;; folder functions.
 819 (mh-defun-show-buffer mh-show-previous-undeleted-msg
 820                       mh-previous-undeleted-msg)
 821 (mh-defun-show-buffer mh-show-next-undeleted-msg
 822                       mh-next-undeleted-msg)
 823 (mh-defun-show-buffer mh-show-quit mh-quit)
 824 (mh-defun-show-buffer mh-show-delete-msg mh-delete-msg)
 825 (mh-defun-show-buffer mh-show-refile-msg mh-refile-msg)
 826 (mh-defun-show-buffer mh-show-undo mh-undo)
 827 (mh-defun-show-buffer mh-show-execute-commands mh-execute-commands)
 828 (mh-defun-show-buffer mh-show-reply mh-reply t)
 829 (mh-defun-show-buffer mh-show-redistribute mh-redistribute)
 830 (mh-defun-show-buffer mh-show-forward mh-forward t)
 831 (mh-defun-show-buffer mh-show-header-display mh-header-display)
 832 (mh-defun-show-buffer mh-show-refile-or-write-again
 833                       mh-refile-or-write-again)
 834 (mh-defun-show-buffer mh-show-show mh-show)
 835 (mh-defun-show-buffer mh-show-write-message-to-file
 836                       mh-write-msg-to-file)
 837 (mh-defun-show-buffer mh-show-extract-rejected-mail
 838                       mh-extract-rejected-mail t)
 839 (mh-defun-show-buffer mh-show-delete-msg-no-motion
 840                       mh-delete-msg-no-motion)
 841 (mh-defun-show-buffer mh-show-first-msg mh-first-msg)
 842 (mh-defun-show-buffer mh-show-last-msg mh-last-msg)
 843 (mh-defun-show-buffer mh-show-copy-msg mh-copy-msg)
 844 (mh-defun-show-buffer mh-show-edit-again mh-edit-again t)
 845 (mh-defun-show-buffer mh-show-goto-msg mh-goto-msg)
 846 (mh-defun-show-buffer mh-show-inc-folder mh-inc-folder)
 847 (mh-defun-show-buffer mh-show-delete-subject-or-thread
 848                       mh-delete-subject-or-thread)
 849 (mh-defun-show-buffer mh-show-delete-subject mh-delete-subject)
 850 (mh-defun-show-buffer mh-show-print-msg mh-print-msg)
 851 (mh-defun-show-buffer mh-show-send mh-send t)
 852 (mh-defun-show-buffer mh-show-toggle-showing mh-toggle-showing t)
 853 (mh-defun-show-buffer mh-show-pipe-msg mh-pipe-msg t)
 854 (mh-defun-show-buffer mh-show-sort-folder mh-sort-folder)
 855 (mh-defun-show-buffer mh-show-visit-folder mh-visit-folder t)
 856 (mh-defun-show-buffer mh-show-rescan-folder mh-rescan-folder)
 857 (mh-defun-show-buffer mh-show-pack-folder mh-pack-folder)
 858 (mh-defun-show-buffer mh-show-kill-folder mh-kill-folder t)
 859 (mh-defun-show-buffer mh-show-list-folders mh-list-folders t)
 860 (mh-defun-show-buffer mh-show-search-folder mh-search-folder t)
 861 (mh-defun-show-buffer mh-show-undo-folder mh-undo-folder)
 862 (mh-defun-show-buffer mh-show-delete-msg-from-seq
 863                       mh-delete-msg-from-seq)
 864 (mh-defun-show-buffer mh-show-delete-seq mh-delete-seq)
 865 (mh-defun-show-buffer mh-show-list-sequences mh-list-sequences)
 866 (mh-defun-show-buffer mh-show-narrow-to-seq mh-narrow-to-seq)
 867 (mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq)
 868 (mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq)
 869 (mh-defun-show-buffer mh-show-widen mh-widen)
 870 (mh-defun-show-buffer mh-show-narrow-to-subject mh-narrow-to-subject)
 871 (mh-defun-show-buffer mh-show-narrow-to-from mh-narrow-to-from)
 872 (mh-defun-show-buffer mh-show-narrow-to-cc mh-narrow-to-cc)
 873 (mh-defun-show-buffer mh-show-narrow-to-range mh-narrow-to-range)
 874 (mh-defun-show-buffer mh-show-narrow-to-to mh-narrow-to-to)
 875 (mh-defun-show-buffer mh-show-store-msg mh-store-msg)
 876 (mh-defun-show-buffer mh-show-page-digest mh-page-digest)
 877 (mh-defun-show-buffer mh-show-page-digest-backwards
 878                       mh-page-digest-backwards)
 879 (mh-defun-show-buffer mh-show-burst-digest mh-burst-digest)
 880 (mh-defun-show-buffer mh-show-page-msg mh-page-msg)
 881 (mh-defun-show-buffer mh-show-previous-page mh-previous-page)
 882 (mh-defun-show-buffer mh-show-modify mh-modify t)
 883 (mh-defun-show-buffer mh-show-next-button mh-next-button)
 884 (mh-defun-show-buffer mh-show-prev-button mh-prev-button)
 885 (mh-defun-show-buffer mh-show-toggle-mime-part mh-folder-toggle-mime-part)
 886 (mh-defun-show-buffer mh-show-save-mime-part mh-folder-save-mime-part)
 887 (mh-defun-show-buffer mh-show-inline-mime-part mh-folder-inline-mime-part)
 888 (mh-defun-show-buffer mh-show-toggle-threads mh-toggle-threads)
 889 (mh-defun-show-buffer mh-show-thread-delete mh-thread-delete)
 890 (mh-defun-show-buffer mh-show-thread-refile mh-thread-refile)
 891 (mh-defun-show-buffer mh-show-update-sequences mh-update-sequences)
 892 (mh-defun-show-buffer mh-show-next-unread-msg mh-next-unread-msg)
 893 (mh-defun-show-buffer mh-show-previous-unread-msg mh-previous-unread-msg)
 894 (mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor)
 895 (mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling)
 896 (mh-defun-show-buffer mh-show-thread-previous-sibling
 897                       mh-thread-previous-sibling)
 898 (mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t)
 899 (mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick)
 900 (mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick)
 901 (mh-defun-show-buffer mh-show-junk-blacklist mh-junk-blacklist)
 902 (mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist)
 903 (mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages)
 904 (mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages)
 905 (mh-defun-show-buffer mh-show-index-sequenced-messages
 906                       mh-index-sequenced-messages)
 907
 908 ;;; Populate mh-show-mode-map
 909 (gnus-define-keys mh-show-mode-map
 910   " "    mh-show-page-msg
 911   "!"    mh-show-refile-or-write-again
 912   "'"    mh-show-toggle-tick
 913   ","    mh-show-header-display
 914   "."    mh-show-show
 915   ">"    mh-show-write-message-to-file
 916   "?"    mh-help
 917   "E"    mh-show-extract-rejected-mail
 918   "M"    mh-show-modify
 919   "\177" mh-show-previous-page
 920   "\C-d" mh-show-delete-msg-no-motion
 921   "\t"   mh-show-next-button
 922   [backtab] mh-show-prev-button
 923   "\M-\t" mh-show-prev-button
 924   "\ed"  mh-show-redistribute
 925   "^"    mh-show-refile-msg
 926   "c"    mh-show-copy-msg
 927   "d"    mh-show-delete-msg
 928   "e"    mh-show-edit-again
 929   "f"    mh-show-forward
 930   "g"    mh-show-goto-msg
 931   "i"    mh-show-inc-folder
 932   "k"    mh-show-delete-subject-or-thread
 933   "l"    mh-show-print-msg
 934   "m"    mh-show-send
 935   "n"    mh-show-next-undeleted-msg
 936   "\M-n" mh-show-next-unread-msg
 937   "o"    mh-show-refile-msg
 938   "p"    mh-show-previous-undeleted-msg
 939   "\M-p" mh-show-previous-unread-msg
 940   "q"    mh-show-quit
 941   "r"    mh-show-reply
 942   "s"    mh-show-send
 943   "t"    mh-show-toggle-showing
 944   "u"    mh-show-undo
 945   "x"    mh-show-execute-commands
 946   "v"    mh-show-index-visit-folder
 947   "|"    mh-show-pipe-msg)
 948
 949 (gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map)
 950   "?"    mh-prefix-help
 951   "'"    mh-index-ticked-messages
 952   "S"    mh-show-sort-folder
 953   "f"    mh-show-visit-folder
 954   "i"    mh-index-search
 955   "k"    mh-show-kill-folder
 956   "l"    mh-show-list-folders
 957   "n"    mh-index-new-messages
 958   "o"    mh-show-visit-folder
 959   "q"    mh-show-index-sequenced-messages
 960   "r"    mh-show-rescan-folder
 961   "s"    mh-show-search-folder
 962   "t"    mh-show-toggle-threads
 963   "u"    mh-show-undo-folder
 964   "v"    mh-show-visit-folder)
 965
 966 (gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map)
 967   "'"    mh-show-narrow-to-tick
 968   "?"    mh-prefix-help
 969   "d"    mh-show-delete-msg-from-seq
 970   "k"    mh-show-delete-seq
 971   "l"    mh-show-list-sequences
 972   "n"    mh-show-narrow-to-seq
 973   "p"    mh-show-put-msg-in-seq
 974   "s"    mh-show-msg-is-in-seq
 975   "w"    mh-show-widen)
 976
 977 (define-key mh-show-mode-map "I" mh-inc-spool-map)
 978
 979 (gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map)
 980   "?"    mh-prefix-help
 981   "b"    mh-show-junk-blacklist
 982   "w"    mh-show-junk-whitelist)
 983
 984 (gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map)
 985   "?"    mh-prefix-help
 986   "u"    mh-show-thread-ancestor
 987   "p"    mh-show-thread-previous-sibling
 988   "n"    mh-show-thread-next-sibling
 989   "t"    mh-show-toggle-threads
 990   "d"    mh-show-thread-delete
 991   "o"    mh-show-thread-refile)
 992
 993 (gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map)
 994   "'"    mh-show-narrow-to-tick
 995   "?"    mh-prefix-help
 996   "c"    mh-show-narrow-to-cc
 997   "f"    mh-show-narrow-to-from
 998   "r"    mh-show-narrow-to-range
 999   "s"    mh-show-narrow-to-subject
1000   "t"    mh-show-narrow-to-to
1001   "w"    mh-show-widen)
1002
1003 (gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map)
1004   "?"    mh-prefix-help
1005   "s"    mh-show-store-msg
1006   "u"    mh-show-store-msg)
1007
1008 ;; Untested...
1009 (gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map)
1010   "?"    mh-prefix-help
1011   " "    mh-show-page-digest
1012   "\177" mh-show-page-digest-backwards
1013   "b"    mh-show-burst-digest)
1014
1015 (gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map)
1016   "?"           mh-prefix-help
1017   "a"           mh-mime-save-parts
1018   "v"           mh-show-toggle-mime-part
1019   "o"           mh-show-save-mime-part
1020   "i"           mh-show-inline-mime-part
1021   "\t"          mh-show-next-button
1022   [backtab]     mh-show-prev-button
1023   "\M-\t"       mh-show-prev-button)
1024
1025 (easy-menu-define
1026   mh-show-sequence-menu mh-show-mode-map "Menu for MH-E folder-sequence."
1027   '("Sequence"
1028     ["Add Message to Sequence..."       mh-show-put-msg-in-seq t]
1029     ["List Sequences for Message"       mh-show-msg-is-in-seq t]
1030     ["Delete Message from Sequence..."  mh-show-delete-msg-from-seq t]
1031     ["List Sequences in Folder..."      mh-show-list-sequences t]
1032     ["Delete Sequence..."               mh-show-delete-seq t]
1033     ["Narrow to Sequence..."            mh-show-narrow-to-seq t]
1034     ["Widen from Sequence"              mh-show-widen t]
1035     "--"
1036     ["Narrow to Subject Sequence"       mh-show-narrow-to-subject t]
1037     ["Narrow to Tick Sequence"          mh-show-narrow-to-tick
1038      (save-excursion
1039        (set-buffer mh-show-folder-buffer)
1040        (and mh-tick-seq (mh-seq-msgs (mh-find-seq mh-tick-seq))))]
1041     ["Delete Rest of Same Subject"      mh-show-delete-subject t]
1042     ["Toggle Tick Mark"                 mh-show-toggle-tick t]
1043     "--"
1044     ["Push State Out to MH"             mh-show-update-sequences t]))
1045
1046 (easy-menu-define
1047   mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message."
1048   '("Message"
1049     ["Show Message"                     mh-show-show t]
1050     ["Show Message with Header"         mh-show-header-display t]
1051     ["Next Message"                     mh-show-next-undeleted-msg t]
1052     ["Previous Message"                 mh-show-previous-undeleted-msg t]
1053     ["Go to First Message"              mh-show-first-msg t]
1054     ["Go to Last Message"               mh-show-last-msg t]
1055     ["Go to Message by Number..."       mh-show-goto-msg t]
1056     ["Modify Message"                   mh-show-modify t]
1057     ["Delete Message"                   mh-show-delete-msg t]
1058     ["Refile Message"                   mh-show-refile-msg t]
1059     ["Undo Delete/Refile"               mh-show-undo t]
1060     ["Process Delete/Refile"            mh-show-execute-commands t]
1061     "--"
1062     ["Compose a New Message"            mh-send t]
1063     ["Reply to Message..."              mh-show-reply t]
1064     ["Forward Message..."               mh-show-forward t]
1065     ["Redistribute Message..."          mh-show-redistribute t]
1066     ["Edit Message Again"               mh-show-edit-again t]
1067     ["Re-edit a Bounced Message"        mh-show-extract-rejected-mail t]
1068     "--"
1069     ["Copy Message to Folder..."        mh-show-copy-msg t]
1070     ["Print Message"                    mh-show-print-msg t]
1071     ["Write Message to File..."         mh-show-write-msg-to-file t]
1072     ["Pipe Message to Command..."       mh-show-pipe-msg t]
1073     ["Unpack Uuencoded Message..."      mh-show-store-msg t]
1074     ["Burst Digest Message"             mh-show-burst-digest t]))
1075
1076 (easy-menu-define
1077   mh-show-folder-menu mh-show-mode-map  "Menu for MH-E folder."
1078   '("Folder"
1079     ["Incorporate New Mail"             mh-show-inc-folder t]
1080     ["Toggle Show/Folder"               mh-show-toggle-showing t]
1081     ["Execute Delete/Refile"            mh-show-execute-commands t]
1082     ["Rescan Folder"                    mh-show-rescan-folder t]
1083     ["Thread Folder"                    mh-show-toggle-threads t]
1084     ["Pack Folder"                      mh-show-pack-folder t]
1085     ["Sort Folder"                      mh-show-sort-folder t]
1086     "--"
1087     ["List Folders"                     mh-show-list-folders t]
1088     ["Visit a Folder..."                mh-show-visit-folder t]
1089     ["View New Messages"                mh-show-index-new-messages t]
1090     ["Search a Folder..."               mh-show-search-folder t]
1091     ["Indexed Search..."                mh-index-search t]
1092     "--"
1093     ["Quit MH-E"                        mh-quit t]))
1094
1095
1096 ;;; Ensure new buffers won't get this mode if default-major-mode is nil.
1097 (put 'mh-show-mode 'mode-class 'special)
1098
1099 ;; Avoid compiler warnings in XEmacs and Emacs 20
1100 (eval-when-compile
1101   (defvar tool-bar-mode)
1102   (defvar tool-bar-map))
1103
1104 (define-derived-mode mh-show-mode text-mode "MH-Show"
1105   "Major mode for showing messages in MH-E.\\<mh-show-mode-map>
1106 The value of `mh-show-mode-hook' is a list of functions to
1107 be called, with no arguments, upon entry to this mode."
1108   (set (make-local-variable 'mail-header-separator) mh-mail-header-separator)
1109   (setq paragraph-start (default-value 'paragraph-start))
1110   (mh-show-unquote-From)
1111   (mh-show-xface)
1112   (mh-show-addr)
1113   (setq buffer-invisibility-spec '((vanish . t) t))
1114   (set (make-local-variable 'line-move-ignore-invisible) t)
1115   (make-local-variable 'font-lock-defaults)
1116   ;;(set (make-local-variable 'font-lock-support-mode) nil)
1117   (cond
1118    ((equal mh-highlight-citation-p 'font-lock)
1119     (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t)))
1120    ((equal mh-highlight-citation-p 'gnus)
1121     (setq font-lock-defaults '((mh-show-font-lock-keywords)
1122                                t nil nil nil
1123                                (font-lock-fontify-region-function
1124                                 . mh-show-font-lock-fontify-region)))
1125     (mh-gnus-article-highlight-citation))
1126    (t
1127     (setq font-lock-defaults '(mh-show-font-lock-keywords t))))
1128   (if (and mh-xemacs-flag
1129            font-lock-auto-fontify)
1130       (turn-on-font-lock))
1131   (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)
1132   (mh-funcall-if-exists mh-toolbar-init :show)
1133   (when mh-decode-mime-flag
1134     (mh-make-local-hook 'kill-buffer-hook)
1135     (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t))
1136   (easy-menu-add mh-show-sequence-menu)
1137   (easy-menu-add mh-show-message-menu)
1138   (easy-menu-add mh-show-folder-menu)
1139   (make-local-variable 'mh-show-folder-buffer)
1140   (buffer-disable-undo)
1141   (setq buffer-read-only t)
1142   (use-local-map mh-show-mode-map)
1143   (run-hooks 'mh-show-mode-hook))
1144
1145 (defun mh-show-addr ()
1146   "Use `goto-address'."
1147   (when mh-show-use-goto-addr-flag
1148     (if (not (featurep 'goto-addr))
1149         (load "goto-addr" t t))
1150     (if (fboundp 'goto-address)
1151         (goto-address))))
1152
1153 \f
1154
1155 ;; X-Face and Face display
1156 (defvar mh-show-xface-function
1157   (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface)))
1158          (load "x-face" t t)
1159          #'mh-face-display-function)
1160         ((>= emacs-major-version 21)
1161          #'mh-face-display-function)
1162         (t #'ignore))
1163   "Determine at run time what function should be called to display X-Face.")
1164
1165 (defvar mh-uncompface-executable
1166   (and (fboundp 'executable-find) (executable-find "uncompface")))
1167
1168 (defun mh-face-to-png (data)
1169   "Convert base64 encoded DATA to png image."
1170   (with-temp-buffer
1171     (insert data)
1172     (ignore-errors (base64-decode-region (point-min) (point-max)))
1173     (buffer-string)))
1174
1175 (defun mh-uncompface (data)
1176   "Run DATA through `uncompface' to generate bitmap."
1177   (with-temp-buffer
1178     (insert data)
1179     (when (and mh-uncompface-executable
1180                (equal (call-process-region (point-min) (point-max)
1181                                            mh-uncompface-executable t '(t nil))
1182                       0))
1183       (mh-icontopbm)
1184       (buffer-string))))
1185
1186 (defun mh-icontopbm ()
1187   "Elisp substitute for `icontopbm'."
1188   (goto-char (point-min))
1189   (let ((end (point-max)))
1190     (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t)
1191       (save-excursion
1192         (goto-char (point-max))
1193         (insert (string-to-number (match-string 1) 16))
1194         (insert (string-to-number (match-string 2) 16))))
1195     (delete-region (point-min) end)
1196     (goto-char (point-min))
1197     (insert "P4\n48 48\n")))
1198
1199 (mh-do-in-xemacs (defvar default-enable-multibyte-characters))
1200
1201 (defun mh-face-display-function ()
1202   "Display a Face or X-Face header field.
1203 Display Face if both are present."
1204   (save-restriction
1205     (goto-char (point-min))
1206     (re-search-forward "\n\n" (point-max) t)
1207     (narrow-to-region (point-min) (point))
1208     (let* ((case-fold-search t)
1209            (default-enable-multibyte-characters nil)
1210            (face (message-fetch-field "face" t))
1211            (x-face (message-fetch-field "x-face" t))
1212            (url (message-fetch-field "x-image-url" t))
1213            raw type)
1214       (cond (face (setq raw (mh-face-to-png face)
1215                         type 'png))
1216             (x-face (setq raw (mh-uncompface x-face)
1217                           type 'pbm))
1218             (url (setq type 'url)))
1219       (when type
1220         (goto-char (point-min))
1221         (when (re-search-forward "^from:" (point-max) t)
1222           ;; GNU Emacs
1223           (mh-do-in-gnu-emacs
1224             (if (eq type 'url)
1225                 (mh-x-image-url-display url)
1226               (mh-funcall-if-exists
1227                insert-image (create-image
1228                              raw type t
1229                              :foreground (face-foreground 'mh-show-xface-face)
1230                              :background (face-background 'mh-show-xface-face))
1231                             " ")))
1232           ;; XEmacs
1233           (mh-do-in-xemacs
1234             (cond
1235              ((eq type 'url)
1236               (mh-x-image-url-display url))
1237              ((eq type 'png)
1238               (when (featurep 'png)
1239                 (set-extent-begin-glyph
1240                  (make-extent (point) (point))
1241                  (make-glyph (vector 'png ':data (mh-face-to-png face))))))
1242              ;; Try internal xface support if available...
1243              ((and (eq type 'pbm) (featurep 'xface))
1244               (set-glyph-face
1245                (set-extent-begin-glyph
1246                 (make-extent (point) (point))
1247                 (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
1248                'mh-show-xface-face))
1249              ;; Otherwise try external support with x-face...
1250              ((and (eq type 'pbm)
1251                    (fboundp 'x-face-xmas-wl-display-x-face)
1252                    (fboundp 'executable-find) (executable-find "uncompface"))
1253               (mh-funcall-if-exists x-face-xmas-wl-display-x-face)))
1254             (when raw (insert " "))))))))
1255
1256
1257 (defun mh-show-xface ()
1258   "Display X-Face."
1259   (when (and window-system mh-show-use-xface-flag
1260              (or mh-decode-mime-flag mhl-formfile
1261                  mh-clean-message-header-flag))
1262     (funcall mh-show-xface-function)))
1263
1264 \f
1265
1266 ;; X-Image-URL display
1267
1268 (defvar mh-x-image-cache-directory nil
1269   "Directory where X-Image-URL images are cached.")
1270
1271 (defvar mh-convert-executable (executable-find "convert"))
1272 (defvar mh-wget-executable (executable-find "wget"))
1273 (defvar mh-x-image-temp-file nil)
1274 (defvar mh-x-image-url nil)
1275 (defvar mh-x-image-marker nil)
1276 (defvar mh-x-image-url-cache-file nil)
1277
1278 (defun mh-x-image-url-cache-canonicalize (url)
1279   "Canonicalize URL.
1280 Replace the ?/ character with a ?! character."
1281   (with-temp-buffer
1282     (insert url)
1283     (goto-char (point-min))
1284     (while (search-forward "/" nil t) (replace-match "!"))
1285     (format "%s/%s.png" mh-x-image-cache-directory (buffer-string))))
1286
1287 (defun mh-x-image-url-fetch-image (url cache-file marker sentinel)
1288   "Fetch and display the image specified by URL.
1289 After the image is fetched, it is stored in CACHE-FILE. It will be displayed
1290 in a buffer and position specified by MARKER. The actual display is carried
1291 out by the SENTINEL function."
1292   (if (and mh-wget-executable
1293            mh-fetch-x-image-url
1294            (or (eq mh-fetch-x-image-url t)
1295                (y-or-n-p (format "Fetch %s? " url))))
1296       (let ((buffer (get-buffer-create (generate-new-buffer-name " *mh-url*")))
1297             (filename (make-temp-name "/tmp/mhe-wget")))
1298         (save-excursion
1299           (set-buffer buffer)
1300           (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
1301           (set (make-local-variable 'mh-x-image-marker) marker)
1302           (set (make-local-variable 'mh-x-image-temp-file) filename))
1303         (set-process-sentinel
1304          (start-process "*wget*" buffer mh-wget-executable "-O" filename url)
1305          sentinel))
1306     ;; Make sure we don't ask about this image again
1307     (when (and mh-wget-executable (eq mh-fetch-x-image-url 'ask))
1308       (make-symbolic-link mh-x-image-cache-directory cache-file t))))
1309
1310 (defun mh-x-image-display (image marker)
1311   "Display IMAGE at MARKER."
1312   (save-excursion
1313     (set-buffer (marker-buffer marker))
1314     (let ((buffer-read-only nil)
1315           (default-enable-multibyte-characters nil)
1316           (buffer-modified-flag (buffer-modified-p)))
1317       (unwind-protect
1318           (when (and (file-readable-p image) (not (file-symlink-p image)))
1319             (goto-char marker)
1320             (mh-do-in-gnu-emacs
1321               (mh-funcall-if-exists insert-image (create-image image 'png)))
1322             (mh-do-in-xemacs
1323               (when (featurep 'png)
1324                 (set-extent-begin-glyph
1325                  (make-extent (point) (point))
1326                  (make-glyph
1327                   (vector 'png ':data (with-temp-buffer
1328                                         (insert-file-contents-literally image)
1329                                         (buffer-string))))))))
1330         (set-buffer-modified-p buffer-modified-flag)))))
1331
1332 (defun mh-x-image-scale-and-display (process change)
1333   "When the wget PROCESS terminates scale and display image.
1334 The argument CHANGE is ignored."
1335   (when (eq (process-status process) 'exit)
1336     (let (marker temp-file cache-filename wget-buffer)
1337       (save-excursion
1338         (set-buffer (setq wget-buffer (process-buffer process)))
1339         (setq marker mh-x-image-marker
1340               cache-filename mh-x-image-url-cache-file
1341               temp-file mh-x-image-temp-file))
1342       (when mh-convert-executable
1343         (call-process mh-convert-executable nil nil nil "-resize" "96x48"
1344                        temp-file cache-filename))
1345       (if (file-exists-p cache-filename)
1346           (mh-x-image-display cache-filename marker)
1347         (make-symbolic-link mh-x-image-cache-directory cache-filename t))
1348       (ignore-errors
1349         (set-marker marker nil)
1350         (delete-process process)
1351         (kill-buffer wget-buffer)
1352         (delete-file temp-file)))))
1353
1354 (defun mh-x-image-url-display (url)
1355   "Display image from location URL.
1356 If the URL isn't present in the cache then it is fetched with wget."
1357   (let ((cache-filename (mh-x-image-url-cache-canonicalize url))
1358         (marker (set-marker (make-marker) (point))))
1359     (cond ((file-exists-p cache-filename)
1360            (mh-x-image-display cache-filename marker))
1361           ((not mh-fetch-x-image-url)
1362            (set-marker marker nil))
1363           ((and (not (file-exists-p mh-x-image-cache-directory))
1364                 (call-process "mkdir" nil nil nil mh-x-image-cache-directory)
1365                 nil))
1366           ((and (file-exists-p mh-x-image-cache-directory)
1367                 (file-directory-p mh-x-image-cache-directory))
1368            (mh-x-image-url-fetch-image url cache-filename marker
1369                                        'mh-x-image-scale-and-display)))))
1370
1371 \f
1372
1373 (defun mh-maybe-show (&optional msg)
1374   "Display message at cursor, but only if in show mode.
1375 If optional arg MSG is non-nil, display that message instead."
1376   (if mh-showing-mode (mh-show msg)))
1377
1378 (defun mh-show (&optional message)
1379   "Show message at cursor.
1380 If optional argument MESSAGE is non-nil, display that message instead.
1381 Force a two-window display with the folder window on top (size given by the
1382 variable `mh-summary-height') and the show buffer below it.
1383 If the message is already visible, display the start of the message.
1384
1385 Display of the message is controlled by setting the variables
1386 `mh-clean-message-header-flag' and `mhl-formfile'.  The default behavior is
1387 to scroll uninteresting headers off the top of the window.
1388 Type \"\\[mh-header-display]\" to see the message with all its headers."
1389   (interactive)
1390   (and mh-showing-with-headers
1391        (or mhl-formfile mh-clean-message-header-flag)
1392        (mh-invalidate-show-buffer))
1393   (mh-show-msg message))
1394
1395 (defun mh-show-mouse (EVENT)
1396   "Move point to mouse EVENT and show message."
1397   (interactive "e")
1398   (mouse-set-point EVENT)
1399   (mh-show))
1400
1401 (defun mh-summary-height ()
1402   "Return ideal value for the variable `mh-summary-height'.
1403 The current frame height is taken into consideration."
1404   (or (and (fboundp 'frame-height)
1405            (> (frame-height) 24)
1406            (min 10 (/ (frame-height) 6)))
1407       4))
1408
1409 (defun mh-show-msg (msg)
1410   "Show MSG.
1411 The value of `mh-show-hook' is a list of functions to be called, with no
1412 arguments, after the message has been displayed."
1413   (if (not msg)
1414       (setq msg (mh-get-msg-num t)))
1415   (mh-showing-mode t)
1416   (setq mh-page-to-next-msg-flag nil)
1417   (let ((folder mh-current-folder)
1418         (folders (list mh-current-folder))
1419         (clean-message-header mh-clean-message-header-flag)
1420         (show-window (get-buffer-window mh-show-buffer)))
1421     (if (not (eq (next-window (minibuffer-window)) (selected-window)))
1422         (delete-other-windows))         ; force ourself to the top window
1423     (mh-in-show-buffer (mh-show-buffer)
1424       (if (and show-window
1425                (equal (mh-msg-filename msg folder) buffer-file-name))
1426           (progn                        ;just back up to start
1427             (goto-char (point-min))
1428             (if (not clean-message-header)
1429                 (mh-start-of-uncleaned-message)))
1430         (mh-display-msg msg folder)))
1431     (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split
1432         (shrink-window (- (window-height) (or mh-summary-height
1433                                               (mh-summary-height)))))
1434     (mh-recenter nil)
1435     (if (not (memq msg mh-seen-list))
1436         (setq mh-seen-list (cons msg mh-seen-list)))
1437     (when mh-update-sequences-after-mh-show-flag
1438       (mh-update-sequences)
1439       (when mh-index-data
1440         (setq folders
1441               (append (mh-index-delete-from-sequence mh-unseen-seq (list msg))
1442                       folders)))
1443       (when (mh-speed-flists-active-p)
1444         (apply #'mh-speed-flists t folders)))
1445     (run-hooks 'mh-show-hook)))
1446
1447 (defun mh-modify (&optional message)
1448   "Edit message at cursor.
1449 If optional argument MESSAGE is non-nil, edit that message instead.
1450 Force a two-window display with the folder window on top (size given by the
1451 value of the variable `mh-summary-height') and the message editing buffer below
1452 it.
1453
1454 The message is displayed in raw form."
1455   (interactive)
1456   (let* ((message (or message (mh-get-msg-num t)))
1457          (msg-filename (mh-msg-filename message))
1458          edit-buffer)
1459     (when (not (file-exists-p msg-filename))
1460       (error "Message %d does not exist" message))
1461
1462     ;; Invalidate the show buffer if it is showing the same message that is
1463     ;; to be edited.
1464     (when (and (buffer-live-p (get-buffer mh-show-buffer))
1465                (equal (save-excursion (set-buffer mh-show-buffer)
1466                                       buffer-file-name)
1467                       msg-filename))
1468       (mh-invalidate-show-buffer))
1469
1470     ;; Edit message
1471     (find-file msg-filename)
1472     (setq edit-buffer (current-buffer))
1473
1474     ;; Set buffer properties
1475     (mh-letter-mode)
1476     (use-local-map text-mode-map)
1477
1478     ;; Just show the edit buffer...
1479     (delete-other-windows)
1480     (switch-to-buffer edit-buffer)))
1481
1482 (defun mh-show-unquote-From ()
1483   "Decode >From at beginning of lines for `mh-show-mode'."
1484   (save-excursion
1485     (let ((modified (buffer-modified-p))
1486           (case-fold-search nil))
1487       (goto-char (mh-mail-header-end))
1488       (while (re-search-forward "^>From" nil t)
1489         (replace-match "From"))
1490       (set-buffer-modified-p modified))))
1491
1492 (defun mh-msg-folder (folder-name)
1493   "Return the name of the buffer for FOLDER-NAME."
1494   folder-name)
1495
1496 (defun mh-display-msg (msg-num folder-name)
1497   "Display MSG-NUM of FOLDER-NAME.
1498 Sets the current buffer to the show buffer."
1499   (let ((folder (mh-msg-folder folder-name)))
1500     (set-buffer folder)
1501     ;; When Gnus uses external displayers it has to keep handles longer. So
1502     ;; we will delete these handles when mh-quit is called on the folder. It
1503     ;; would be nicer if there are weak pointers in emacs lisp, then we could
1504     ;; get the garbage collector to do this for us.
1505     (unless (mh-buffer-data)
1506       (setf (mh-buffer-data) (mh-make-buffer-data)))
1507     ;; Bind variables in folder buffer in case they are local
1508     (let ((formfile mhl-formfile)
1509           (clean-message-header mh-clean-message-header-flag)
1510           (invisible-headers mh-invisible-headers)
1511           (visible-headers mh-visible-headers)
1512           (msg-filename (mh-msg-filename msg-num folder-name))
1513           (show-buffer mh-show-buffer)
1514           (mm-inline-media-tests mh-mm-inline-media-tests))
1515       (if (not (file-exists-p msg-filename))
1516           (error "Message %d does not exist" msg-num))
1517       (if (and (> mh-show-maximum-size 0)
1518                (> (elt (file-attributes msg-filename) 7)
1519                   mh-show-maximum-size)
1520                (not (y-or-n-p
1521                      (format
1522                       "Message %d (%d bytes) exceeds %d bytes. Display it? "
1523                       msg-num (elt (file-attributes msg-filename) 7)
1524                       mh-show-maximum-size))))
1525           (error "Message %d not displayed" msg-num))
1526       (set-buffer show-buffer)
1527       (cond ((not (equal msg-filename buffer-file-name))
1528              (mh-unvisit-file)
1529              (setq buffer-read-only nil)
1530              (erase-buffer)
1531              ;; Changing contents, so this hook needs to be reinitialized.
1532              ;; pgp.el uses this.
1533              (if (boundp 'write-contents-hooks) ;Emacs 19
1534                  (kill-local-variable 'write-contents-hooks))
1535              (if formfile
1536                  (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
1537                                          (if (stringp formfile)
1538                                              (list "-form" formfile))
1539                                          msg-filename)
1540                (insert-file-contents-literally msg-filename))
1541              ;; Cleanup old mime handles
1542              (mh-mime-cleanup)
1543              ;; Use mm to display buffer
1544              (when (and mh-decode-mime-flag (not formfile))
1545                (mh-add-missing-mime-version-header)
1546                (setf (mh-buffer-data) (mh-make-buffer-data))
1547                (mh-mime-display))
1548              (mh-show-mode)
1549              ;; Header cleanup
1550              (goto-char (point-min))
1551              (cond (clean-message-header
1552                     (mh-clean-msg-header (point-min)
1553                                          invisible-headers
1554                                          visible-headers)
1555                     (goto-char (point-min)))
1556                    (t
1557                     (mh-start-of-uncleaned-message)))
1558              (mh-decode-message-header)
1559              ;; the parts of visiting we want to do (no locking)
1560              (or (eq buffer-undo-list t) ;don't save undo info for prev msgs
1561                  (setq buffer-undo-list nil))
1562              (set-buffer-auto-saved)
1563              ;; the parts of set-visited-file-name we want to do (no locking)
1564              (setq buffer-file-name msg-filename)
1565              (setq buffer-backed-up nil)
1566              (auto-save-mode 1)
1567              (set-mark nil)
1568              (unwind-protect
1569                  (when (and mh-decode-mime-flag (not formfile))
1570                    (setq buffer-read-only nil)
1571                    (mh-display-smileys)
1572                    (mh-display-emphasis))
1573                (setq buffer-read-only t))
1574              (set-buffer-modified-p nil)
1575              (setq mh-show-folder-buffer folder)
1576              (setq mode-line-buffer-identification
1577                    (list (format mh-show-buffer-mode-line-buffer-id
1578                                  folder-name msg-num)))
1579              (mh-logo-display)
1580              (set-buffer folder)
1581              (setq mh-showing-with-headers nil))))))
1582
1583 (defun mh-clean-msg-header (start invisible-headers visible-headers)
1584   "Flush extraneous lines in message header.
1585 Header is cleaned from START to the end of the message header.
1586 INVISIBLE-HEADERS contains a regular expression specifying lines to delete
1587 from the header. VISIBLE-HEADERS contains a regular expression specifying the
1588 lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil."
1589   (let ((case-fold-search t)
1590         (buffer-read-only nil)
1591         (after-change-functions nil))   ;Work around emacs-20 font-lock bug
1592                                         ;causing an endless loop.
1593     (save-restriction
1594       (goto-char start)
1595       (if (search-forward "\n\n" nil 'move)
1596           (backward-char 1))
1597       (narrow-to-region start (point))
1598       (goto-char (point-min))
1599       (if visible-headers
1600           (while (< (point) (point-max))
1601             (cond ((looking-at visible-headers)
1602                    (forward-line 1)
1603                    (while (looking-at "[ \t]") (forward-line 1)))
1604                   (t
1605                    (mh-delete-line 1)
1606                    (while (looking-at "[ \t]")
1607                      (mh-delete-line 1)))))
1608         (while (re-search-forward invisible-headers nil t)
1609           (beginning-of-line)
1610           (mh-delete-line 1)
1611           (while (looking-at "[ \t]")
1612             (mh-delete-line 1)))))
1613     (let ((mh-compose-skipped-header-fields ()))
1614       (mh-letter-hide-all-skipped-fields))
1615     (unlock-buffer)))
1616
1617 (defun mh-delete-line (lines)
1618   "Delete the next LINES lines."
1619   (delete-region (point) (progn (forward-line lines) (point))))
1620
1621 (defun mh-notate (msg notation offset)
1622   "Mark MSG with the character NOTATION at position OFFSET.
1623 Null MSG means the message at cursor.
1624 If NOTATION is nil then no change in the buffer occurs."
1625   (save-excursion
1626     (if (or (null msg)
1627             (mh-goto-msg msg t t))
1628         (with-mh-folder-updating (t)
1629           (beginning-of-line)
1630           (forward-char offset)
1631           (let* ((change-stack-flag (and (stringp notation)
1632                                          (equal offset (1+ mh-cmd-note))
1633                                          (not (eq notation mh-note-seq))))
1634                  (msg (and change-stack-flag (or msg (mh-get-msg-num nil))))
1635                  (stack (and msg (gethash msg mh-sequence-notation-history)))
1636                  (notation (or notation (char-after))))
1637             (if stack
1638                 ;; The presence of the stack tells us that we don't need to
1639                 ;; notate the message, since the notation would be replaced
1640                 ;; by a sequence notation. So we will just put the notation
1641                 ;; at the bottom of the stack. If the sequence is deleted,
1642                 ;; the correct notation will be shown.
1643                 (setf (gethash msg mh-sequence-notation-history)
1644                       (reverse (cons (aref notation 0) (cdr (reverse stack)))))
1645               ;; Since we don't have any sequence notations in the way, just
1646               ;; notate the scan line.
1647               (delete-char 1)
1648               (insert notation))
1649             (when change-stack-flag
1650               (mh-thread-update-scan-line-map msg notation offset)))))))
1651
1652 (defun mh-find-msg-get-num (step)
1653   "Return the message number of the message nearest the cursor.
1654 Jumps over non-message lines, such as inc errors.
1655 If we have to search, STEP tells whether to search forward or backward."
1656   (or (mh-get-msg-num nil)
1657       (let ((msg-num nil)
1658             (nreverses 0))
1659         (while (and (not msg-num)
1660                     (< nreverses 2))
1661           (cond ((eobp)
1662                  (setq step -1)
1663                  (setq nreverses (1+ nreverses)))
1664                 ((bobp)
1665                  (setq step 1)
1666                  (setq nreverses (1+ nreverses))))
1667           (forward-line step)
1668           (setq msg-num (mh-get-msg-num nil)))
1669         msg-num)))
1670
1671 (defun mh-goto-msg (number &optional no-error-if-no-message dont-show)
1672   "Position the cursor at message NUMBER.
1673 Optional non-nil second argument NO-ERROR-IF-NO-MESSAGE means return nil
1674 instead of signaling an error if message does not exist; in this case, the
1675 cursor is positioned near where the message would have been.
1676 Non-nil third argument DONT-SHOW means not to show the message."
1677   (interactive "NGo to message: ")
1678   (setq number (prefix-numeric-value number))
1679   (let ((point (point))
1680         (return-value t))
1681     (goto-char (point-min))
1682     (unless (re-search-forward (format "^[ ]*%s[^0-9]+" number) nil t)
1683       (goto-char point)
1684       (unless no-error-if-no-message
1685         (error "No message %d" number))
1686       (setq return-value nil))
1687     (beginning-of-line)
1688     (or dont-show (not return-value) (mh-maybe-show number))
1689     return-value))
1690
1691 (defun mh-msg-search-pat (n)
1692   "Return a search pattern for message N in the scan listing."
1693   (format mh-scan-msg-search-regexp n))
1694
1695 (defun mh-get-profile-field (field)
1696   "Find and return the value of FIELD in the current buffer.
1697 Returns nil if the field is not in the buffer."
1698   (let ((case-fold-search t))
1699     (goto-char (point-min))
1700     (cond ((not (re-search-forward (format "^%s" field) nil t)) nil)
1701           ((looking-at "[\t ]*$") nil)
1702           (t
1703            (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t)
1704            (let ((start (match-beginning 1)))
1705              (end-of-line)
1706              (buffer-substring start (point)))))))
1707
1708 (defvar mail-user-agent)
1709 (defvar read-mail-command)
1710
1711 (defvar mh-find-path-run nil
1712   "Non-nil if `mh-find-path' has been run already.")
1713
1714 (defun mh-find-path ()
1715   "Set `mh-progs', `mh-lib', and `mh-lib-progs' variables.
1716 Set `mh-user-path', `mh-draft-folder', `mh-unseen-seq', `mh-previous-seq',
1717 `mh-inbox' from user's MH profile.
1718 The value of `mh-find-path-hook' is a list of functions to be called, with no
1719 arguments, after these variable have been set."
1720   (mh-find-progs)
1721   (unless mh-find-path-run
1722     (setq mh-find-path-run t)
1723     (setq read-mail-command 'mh-rmail)
1724     (setq mail-user-agent 'mh-e-user-agent))
1725   (save-excursion
1726     ;; Be sure profile is fully expanded before switching buffers
1727     (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile"))))
1728       (set-buffer (get-buffer-create mh-temp-buffer))
1729       (setq buffer-offer-save nil)      ;for people who set default to t
1730       (erase-buffer)
1731       (condition-case err
1732           (insert-file-contents profile)
1733         (file-error
1734          (mh-install profile err)))
1735       (setq mh-user-path (mh-get-profile-field "Path:"))
1736       (if (not mh-user-path)
1737           (setq mh-user-path "Mail"))
1738       (setq mh-user-path
1739             (file-name-as-directory
1740              (expand-file-name mh-user-path (expand-file-name "~"))))
1741       (unless mh-x-image-cache-directory
1742         (setq mh-x-image-cache-directory
1743               (expand-file-name ".mhe-x-image-cache" mh-user-path)))
1744       (setq mh-draft-folder (mh-get-profile-field "Draft-Folder:"))
1745       (if mh-draft-folder
1746           (progn
1747             (if (not (mh-folder-name-p mh-draft-folder))
1748                 (setq mh-draft-folder (format "+%s" mh-draft-folder)))
1749             (if (not (file-exists-p (mh-expand-file-name mh-draft-folder)))
1750                 (error "Draft folder \"%s\" not found.  Create it and try again"
1751                        (mh-expand-file-name mh-draft-folder)))))
1752       (setq mh-inbox (mh-get-profile-field "Inbox:"))
1753       (cond ((not mh-inbox)
1754              (setq mh-inbox "+inbox"))
1755             ((not (mh-folder-name-p mh-inbox))
1756              (setq mh-inbox (format "+%s" mh-inbox))))
1757       (setq mh-unseen-seq (mh-get-profile-field "Unseen-Sequence:"))
1758       (if mh-unseen-seq
1759           (setq mh-unseen-seq (intern mh-unseen-seq))
1760         (setq mh-unseen-seq 'unseen))   ;old MH default?
1761       (setq mh-previous-seq (mh-get-profile-field "Previous-Sequence:"))
1762       (if mh-previous-seq
1763           (setq mh-previous-seq (intern mh-previous-seq)))
1764       (run-hooks 'mh-find-path-hook)
1765       (mh-collect-folder-names))))
1766
1767 (defun mh-file-command-p (file)
1768   "Return t if file FILE is the name of a executable regular file."
1769   (and (file-regular-p file) (file-executable-p file)))
1770
1771 (defun mh-find-progs ()
1772   "Find the directories for the installed MH/nmh binaries and config files.
1773 Set the `mh-progs' and `mh-lib', and `mh-lib-progs' variables to the
1774 directory names and set `mh-nmh-flag' if we detect nmh instead of MH."
1775   (unless (and mh-progs mh-lib mh-lib-progs)
1776     (let ((path (or (mh-path-search exec-path "mhparam")
1777                     (mh-path-search '("/usr/local/nmh/bin" ; nmh default
1778                                       "/usr/local/bin/mh/"
1779                                       "/usr/local/mh/"
1780                                       "/usr/bin/mh/" ;Ultrix 4.2, Linux
1781                                       "/usr/new/mh/" ;Ultrix <4.2
1782                                       "/usr/contrib/mh/bin/" ;BSDI
1783                                       "/usr/pkg/bin/" ; NetBSD
1784                                       "/usr/local/bin/"
1785                                       )
1786                                     "mhparam"))))
1787       (if (not path)
1788           (error "Unable to find the `mhparam' command"))
1789       (save-excursion
1790         (let ((tmp-buffer (get-buffer-create mh-temp-buffer)))
1791           (set-buffer tmp-buffer)
1792           (unwind-protect
1793               (progn
1794                 (call-process (expand-file-name "mhparam" path)
1795                               nil '(t nil) nil "libdir" "etcdir")
1796                 (goto-char (point-min))
1797                 (if (search-forward-regexp "^libdir:\\s-\\(\\S-+\\)\\s-*$"
1798                                            nil t)
1799                     (setq mh-lib-progs (match-string 1)
1800                           mh-lib mh-lib-progs
1801                           mh-progs path))
1802                 (goto-char (point-min))
1803                 (if (search-forward-regexp "^etcdir:\\s-\\(\\S-+\\)\\s-*$"
1804                                            nil t)
1805                     (setq mh-lib (match-string 1)
1806                           mh-nmh-flag t)))
1807             (kill-buffer tmp-buffer))))
1808       (unless (and mh-progs mh-lib mh-lib-progs)
1809         (error "Unable to determine paths from `mhparam' command"))
1810       (setq mh-flists-present-flag
1811             (file-exists-p (expand-file-name "flists" mh-progs))))))
1812
1813 (defun mh-path-search (path file)
1814   "Search PATH, a list of directory names, for FILE.
1815 Returns the element of PATH that contains FILE, or nil if not found."
1816   (while (and path
1817               (not (funcall 'mh-file-command-p
1818                             (expand-file-name file (car path)))))
1819     (setq path (cdr path)))
1820   (car path))
1821
1822 (defvar mh-no-install nil)              ;do not run install-mh
1823
1824 (defun mh-install (profile error-val)
1825   "Initialize the MH environment.
1826 This is called if we fail to read the PROFILE file. ERROR-VAL is the error
1827 that made this call necessary."
1828   (if (or (getenv "MH")
1829           (file-exists-p profile)
1830           mh-no-install)
1831       (signal (car error-val)
1832               (list (format "Cannot read MH profile \"%s\"" profile)
1833                     (car (cdr (cdr error-val))))))
1834   ;; The "install-mh" command will output a short note which
1835   ;; mh-exec-cmd will display to the user.
1836   ;; The MH 5 version of install-mh might try prompt the user
1837   ;; for information, which would fail here.
1838   (mh-exec-cmd (expand-file-name "install-mh" mh-lib-progs) "-auto")
1839   ;; now try again to read the profile file
1840   (erase-buffer)
1841   (condition-case err
1842       (insert-file-contents profile)
1843     (file-error
1844      (signal (car err)                  ;re-signal with more specific msg
1845              (list (format "Cannot read MH profile \"%s\"" profile)
1846                    (car (cdr (cdr err))))))))
1847
1848 (defun mh-set-folder-modified-p (flag)
1849   "Mark current folder as modified or unmodified according to FLAG."
1850   (set-buffer-modified-p flag))
1851
1852 (defun mh-find-seq (name)
1853   "Return sequence NAME."
1854   (assoc name mh-seq-list))
1855
1856 (defun mh-seq-to-msgs (seq)
1857   "Return a list of the messages in SEQ."
1858   (mh-seq-msgs (mh-find-seq seq)))
1859
1860 (defun mh-update-scan-format (fmt width)
1861   "Return a scan format with the (msg) width in the FMT replaced with WIDTH.
1862
1863 The message number width portion of the format is discovered using
1864 `mh-scan-msg-format-regexp'. Its replacement is controlled with
1865 `mh-scan-msg-format-string'."
1866   (or (and
1867        (string-match mh-scan-msg-format-regexp fmt)
1868        (let ((begin (match-beginning 1))
1869              (end (match-end 1)))
1870          (concat (substring fmt 0 begin)
1871                  (format mh-scan-msg-format-string width)
1872                  (substring fmt end))))
1873       fmt))
1874
1875 (defun mh-message-number-width (folder)
1876   "Return the widest message number in this FOLDER."
1877   (or mh-progs (mh-find-path))
1878   (let ((tmp-buffer (get-buffer-create mh-temp-buffer))
1879         (width 0))
1880     (save-excursion
1881       (set-buffer tmp-buffer)
1882       (erase-buffer)
1883       (apply 'call-process
1884              (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil
1885              (list folder "last" "-format" "%(msg)"))
1886       (goto-char (point-min))
1887       (if (re-search-forward mh-scan-msg-number-regexp nil 0 1)
1888           (setq width (length (buffer-substring
1889                                (match-beginning 1) (match-end 1))))))
1890     width))
1891
1892 (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag)
1893   "Add MSGS to SEQ.
1894 Remove duplicates and keep sequence sorted. If optional INTERNAL-FLAG is
1895 non-nil, do not mark the message in the scan listing or inform MH of the
1896 addition.
1897
1898 If DONT-ANNOTATE-FLAG is non-nil then the annotations in the folder buffer are
1899 not updated."
1900   (let ((entry (mh-find-seq seq))
1901         (internal-seq-flag (mh-internal-seq seq)))
1902     (if (and msgs (atom msgs)) (setq msgs (list msgs)))
1903     (unless internal-flag
1904       (mh-add-to-sequence seq msgs)
1905       (when (not dont-annotate-flag)
1906         (mh-iterate-on-range msg msgs
1907           (unless (memq msg (cdr entry))
1908             (mh-add-sequence-notation msg internal-seq-flag)))))
1909     (if (null entry)
1910         (setq mh-seq-list
1911               (cons (mh-make-seq seq (mh-canonicalize-sequence msgs))
1912                     mh-seq-list))
1913       (if msgs (setcdr entry (mh-canonicalize-sequence
1914                               (append msgs (mh-seq-msgs entry))))))))
1915
1916 (defun mh-canonicalize-sequence (msgs)
1917   "Sort MSGS in decreasing order and remove duplicates."
1918   (let* ((sorted-msgs (sort (copy-sequence msgs) '>))
1919          (head sorted-msgs))
1920     (while (cdr head)
1921       (if (= (car head) (cadr head))
1922           (setcdr head (cddr head))
1923         (setq head (cdr head))))
1924     sorted-msgs))
1925
1926 (defvar mh-sub-folders-cache (make-hash-table :test #'equal))
1927 (defvar mh-current-folder-name nil)
1928 (defvar mh-flists-partial-line "")
1929 (defvar mh-flists-process nil)
1930
1931 ;; Initialize mh-sub-folders-cache...
1932 (defun mh-collect-folder-names ()
1933   "Collect folder names by running `flists'."
1934   (unless mh-flists-process
1935     (setq mh-flists-process
1936           (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter
1937                               "-recurse" "-fast"))))
1938
1939 (defun mh-collect-folder-names-filter (process output)
1940   "Read folder names.
1941 PROCESS is the flists process that was run to collect folder names and the
1942 function is called when OUTPUT is available."
1943   (let ((position 0)
1944         (prevailing-match-data (match-data))
1945         line-end folder)
1946     (unwind-protect
1947         (while (setq line-end (string-match "\n" output position))
1948           (setq folder (format "+%s%s"
1949                                mh-flists-partial-line
1950                                (substring output position line-end)))
1951           (setq mh-flists-partial-line "")
1952           (unless (equal (aref folder 1) ?.)
1953             (mh-populate-sub-folders-cache folder))
1954           (setq position (1+ line-end)))
1955       (set-match-data prevailing-match-data))
1956     (setq mh-flists-partial-line (substring output position))))
1957
1958 (defun mh-populate-sub-folders-cache (folder)
1959   "Tell `mh-sub-folders-cache' about FOLDER."
1960   (let* ((last-slash (mh-search-from-end ?/ folder))
1961          (child1 (substring folder (1+ (or last-slash 0))))
1962          (parent (and last-slash (substring folder 0 last-slash)))
1963          (parent-slash (and parent (mh-search-from-end ?/ parent)))
1964          (child2 (and parent (substring parent (1+ (or parent-slash 0)))))
1965          (grand-parent (and parent-slash (substring parent 0 parent-slash)))
1966          (cache-entry (gethash parent mh-sub-folders-cache)))
1967     (unless (loop for x in cache-entry when (equal (car x) child1) return t
1968                   finally return nil)
1969       (push (list child1) cache-entry)
1970       (setf (gethash parent mh-sub-folders-cache)
1971             (sort cache-entry (lambda (x y) (string< (car x) (car y)))))
1972       (when parent
1973         (loop for x in (gethash grand-parent mh-sub-folders-cache)
1974               when (equal (car x) child2)
1975               do (progn (setf (cdr x) t) (return)))))))
1976
1977 (defun mh-normalize-folder-name (folder &optional empty-string-okay
1978                                         dont-remove-trailing-slash)
1979   "Normalizes FOLDER name.
1980 Makes sure that two '/' characters never occur next to each other. Also all
1981 occurrences of \"..\" and \".\" are suitably processed. So \"+inbox/../news\"
1982 will be normalized to \"+news\".
1983
1984 If optional argument EMPTY-STRING-OKAY is nil then a '+' is added at the
1985 front if FOLDER lacks one. If non-nil and FOLDER is the empty string then
1986 nothing is added.
1987
1988 If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a trailing '/'
1989 if present is retained (if present), otherwise it is removed."
1990   (when (stringp folder)
1991     ;; Replace two or more consecutive '/' characters with a single '/'
1992     (while (string-match "//" folder)
1993       (setq folder (replace-match "/" nil t folder)))
1994     (let* ((length (length folder))
1995            (trailing-slash-present (and (> length 0)
1996                                         (equal (aref folder (1- length)) ?/)))
1997            (leading-slash-present (and (> length 0)
1998                                        (equal (aref folder 0) ?/))))
1999       (when (and (> length 0) (equal (aref folder 0) ?@)
2000                  (stringp mh-current-folder-name))
2001         (setq folder (format "%s/%s/" mh-current-folder-name
2002                              (substring folder 1))))
2003       ;; XXX: Purge empty strings from the list that split-string returns. In
2004       ;;  XEmacs, (split-string "+foo/" "/") returns ("+foo" "") while in GNU
2005       ;;  Emacs it returns ("+foo"). In the code it is assumed that the
2006       ;; components list has no empty strings.
2007       (let ((components (delete "" (split-string folder "/")))
2008             (result ()))
2009         ;; Remove .. and . from the pathname.
2010         (dolist (component components)
2011           (cond ((and (equal component "..") result)
2012                  (pop result))
2013                 ((equal component ".."))
2014                 ((equal component "."))
2015                 (t (push component result))))
2016         (setq folder "")
2017         (dolist (component result)
2018           (setq folder (concat component "/" folder)))
2019         ;; Remove trailing '/' if needed.
2020         (unless (and trailing-slash-present dont-remove-trailing-slash)
2021           (when (not (equal folder ""))
2022             (setq folder (substring folder 0 (1- (length folder))))))
2023         (when leading-slash-present
2024           (setq folder (concat "/" folder)))))
2025     (cond ((and empty-string-okay (equal folder "")))
2026           ((equal folder "") (setq folder "+"))
2027           ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder)))))
2028   folder)
2029
2030 (defun mh-sub-folders (folder &optional add-trailing-slash-flag)
2031   "Find the subfolders of FOLDER.
2032 The function avoids running folders unnecessarily by caching the results of
2033 the actual folders call.
2034
2035 If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a slash is added
2036 to each of the sub-folder names that may have nested folders within them."
2037   (let* ((folder (mh-normalize-folder-name folder))
2038          (match (gethash folder mh-sub-folders-cache 'no-result))
2039          (sub-folders (cond ((eq match 'no-result)
2040                              (setf (gethash folder mh-sub-folders-cache)
2041                                    (mh-sub-folders-actual folder)))
2042                             (t match))))
2043     (if add-trailing-slash-flag
2044         (mapcar #'(lambda (x)
2045                     (if (cdr x) (cons (concat (car x) "/") (cdr x)) x))
2046                 sub-folders)
2047       sub-folders)))
2048
2049 (defun mh-sub-folders-actual (folder)
2050   "Execute the command folders to return the sub-folders of FOLDER.
2051 Filters out the folder names that start with \".\" so that directories that
2052 aren't usually mail folders are hidden."
2053   (let ((arg-list `(,(expand-file-name "folders" mh-progs)
2054                     nil (t nil) nil "-noheader" "-norecurse" "-nototal"
2055                     ,@(if (stringp folder) (list folder) ())))
2056         (results ())
2057         (current-folder (concat
2058                          (with-temp-buffer
2059                            (call-process (expand-file-name "folder" mh-progs)
2060                                          nil '(t nil) nil "-fast")
2061                            (buffer-substring (point-min) (1- (point-max))))
2062                          "+")))
2063     (with-temp-buffer
2064       (apply #'call-process arg-list)
2065       (goto-char (point-min))
2066       (while (not (and (eolp) (bolp)))
2067         (goto-char (line-end-position))
2068         (let ((has-pos (search-backward " has " (line-beginning-position) t)))
2069           (when (integerp has-pos)
2070             (while (equal (char-after has-pos) ? )
2071               (decf has-pos))
2072             (incf has-pos)
2073             (let* ((name (buffer-substring (line-beginning-position) has-pos))
2074                    (first-char (aref name 0))
2075                    (last-char (aref name (1- (length name)))))
2076               (unless (member first-char '(?. ?# ?,))
2077                 (when (and (equal last-char ?+) (equal name current-folder))
2078                   (setq name (substring name 0 (1- (length name)))))
2079                 (push
2080                  (cons name
2081                        (search-forward "(others)" (line-end-position) t))
2082                  results))))
2083           (forward-line 1))))
2084     (setq results (nreverse results))
2085     (when (stringp folder)
2086       (setq results (cdr results))
2087       (let ((folder-name-len (length (format "%s/" (substring folder 1)))))
2088         (setq results (mapcar (lambda (f)
2089                                 (cons (substring (car f) folder-name-len)
2090                                       (cdr f)))
2091                               results))))
2092     results))
2093
2094 (defun mh-remove-from-sub-folders-cache (folder)
2095   "Remove FOLDER and its parent from `mh-sub-folders-cache'.
2096 FOLDER should be unconditionally removed from the cache. Also the last ancestor
2097 of FOLDER present in the cache must be removed as well.
2098
2099 To see why this is needed assume we have a folder +foo which has a single
2100 sub-folder qux. Now we create the folder +foo/bar/baz. Here we will need to
2101 invalidate the cached sub-folders of +foo, otherwise completion on +foo won't
2102 tell us about the option +foo/bar!"
2103   (remhash folder mh-sub-folders-cache)
2104   (block ancestor-found
2105     (let ((parent folder)
2106           (one-ancestor-found nil)
2107           last-slash)
2108       (while (setq last-slash (mh-search-from-end ?/ parent))
2109         (setq parent (substring parent 0 last-slash))
2110         (unless (eq (gethash parent  mh-sub-folders-cache 'none) 'none)
2111           (remhash parent mh-sub-folders-cache)
2112           (if one-ancestor-found
2113               (return-from ancestor-found)
2114             (setq one-ancestor-found t))))
2115       (remhash nil mh-sub-folders-cache))))
2116
2117 (defvar mh-folder-hist nil)
2118 (defvar mh-speed-folder-map)
2119 (defvar mh-speed-flists-cache)
2120
2121 (defvar mh-allow-root-folder-flag nil
2122   "Non-nil means \"+\" is an acceptable folder name.
2123 This variable is used to communicate with `mh-folder-completion-function'. That
2124 function can have exactly three arguments so we bind this variable to t or nil.
2125
2126 This variable should never be set.")
2127
2128 (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map))
2129 (define-key mh-folder-completion-map " " 'minibuffer-complete)
2130
2131 (defvar mh-speed-flists-inhibit-flag nil)
2132
2133 (defun mh-speed-flists-active-p ()
2134   "Check if speedbar is running with message counts enabled."
2135   (and (featurep 'mh-speed)
2136        (not mh-speed-flists-inhibit-flag)
2137        (> (hash-table-count mh-speed-flists-cache) 0)))
2138
2139 (defun mh-folder-completion-function (name predicate flag)
2140   "Programmable completion for folder names.
2141 NAME is the partial folder name that has been input. PREDICATE if non-nil is a
2142 function that is used to filter the possible choices and FLAG determines
2143 whether the completion is over."
2144   (let* ((orig-name name)
2145          (name (mh-normalize-folder-name name nil t))
2146          (last-slash (mh-search-from-end ?/ name))
2147          (last-complete (if last-slash (substring name 0 last-slash) nil))
2148          (remainder (cond (last-complete (substring name (1+ last-slash)))
2149                           ((and (> (length name) 0) (equal (aref name 0) ?+))
2150                            (substring name 1))
2151                           (t ""))))
2152     (cond ((eq flag nil)
2153            (let ((try-res (try-completion
2154                            name
2155                            (mapcar (lambda (x)
2156                                      (cons (if (not last-complete)
2157                                                (concat "+" (car x))
2158                                              (concat last-complete "/" (car x)))
2159                                            (cdr x)))
2160                                    (mh-sub-folders last-complete t))
2161                            predicate)))
2162              (cond ((eq try-res nil) nil)
2163                    ((and (eq try-res t) (equal name orig-name)) t)
2164                    ((eq try-res t) name)
2165                    (t try-res))))
2166           ((eq flag t)
2167            (all-completions
2168             remainder (mh-sub-folders last-complete t) predicate))
2169           ((eq flag 'lambda)
2170            (let ((path (concat mh-user-path
2171                                (substring (mh-normalize-folder-name name) 1))))
2172              (cond (mh-allow-root-folder-flag (file-exists-p path))
2173                    ((equal path mh-user-path) nil)
2174                    (t (file-exists-p path))))))))
2175
2176 (defun mh-folder-completing-read (prompt default allow-root-folder-flag)
2177   "Read folder name with PROMPT and default result DEFAULT.
2178 If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be a folder name
2179 corresponding to `mh-user-path'."
2180   (mh-normalize-folder-name
2181    (let ((minibuffer-local-completion-map mh-folder-completion-map)
2182          (mh-allow-root-folder-flag allow-root-folder-flag))
2183      (completing-read prompt 'mh-folder-completion-function nil nil nil
2184                       'mh-folder-hist default))
2185    t))
2186
2187 (defun mh-prompt-for-folder (prompt default can-create
2188                              &optional default-string allow-root-folder-flag)
2189   "Prompt for a folder name with PROMPT.
2190 Returns the folder's name as a string. DEFAULT is used if the folder exists
2191 and the user types return. If the CAN-CREATE flag is t, then a folder is
2192 created if it doesn't already exist. If optional argument DEFAULT-STRING is
2193 non-nil, use it in the prompt instead of DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is
2194 non-nil then the function will accept the folder +, which means all folders
2195 when used in searching."
2196   (if (null default)
2197       (setq default ""))
2198   (let* ((default-string (cond (default-string (format " [%s]? "
2199                                                        default-string))
2200                                ((equal "" default) "? ")
2201                                (t (format " [%s]? " default))))
2202          (prompt (format "%s folder%s" prompt default-string))
2203          (mh-current-folder-name mh-current-folder)
2204          read-name folder-name)
2205     (while (and (setq read-name (mh-folder-completing-read
2206                                  prompt default allow-root-folder-flag))
2207                 (equal read-name "")
2208                 (equal default "")))
2209     (cond ((or (equal read-name "")
2210                (and (equal read-name "+") (not allow-root-folder-flag)))
2211            (setq read-name default))
2212           ((not (mh-folder-name-p read-name))
2213            (setq read-name (format "+%s" read-name))))
2214     (if (or (not read-name) (equal "" read-name))
2215         (error "No folder specified"))
2216     (setq folder-name read-name)
2217     (cond ((and (> (length folder-name) 0)
2218                 (eq (aref folder-name (1- (length folder-name))) ?/))
2219            (setq folder-name (substring folder-name 0 -1))))
2220     (let* ((last-slash (mh-search-from-end ?/ folder-name))
2221            (parent (and last-slash (substring folder-name 0 last-slash)))
2222            (child (if last-slash
2223                       (substring folder-name (1+ last-slash))
2224                     (substring folder-name 1))))
2225       (unless (member child
2226                       (mapcar #'car (gethash parent mh-sub-folders-cache)))
2227         (mh-remove-from-sub-folders-cache folder-name)))
2228     (let ((new-file-flag
2229            (not (file-exists-p (mh-expand-file-name folder-name)))))
2230       (cond ((and new-file-flag
2231                   (y-or-n-p
2232                    (format "Folder %s does not exist.  Create it? "
2233                            folder-name)))
2234              (message "Creating %s" folder-name)
2235              (mh-exec-cmd-error nil "folder" folder-name)
2236              (mh-remove-from-sub-folders-cache folder-name)
2237              (when (boundp 'mh-speed-folder-map)
2238                (mh-speed-add-folder folder-name))
2239              (message "Creating %s...done" folder-name))
2240             (new-file-flag
2241              (error "Folder %s is not created" folder-name))
2242             ((not (file-directory-p (mh-expand-file-name folder-name)))
2243              (error "\"%s\" is not a directory"
2244                     (mh-expand-file-name folder-name)))))
2245     folder-name))
2246
2247 (defun mh-truncate-log-buffer ()
2248   "If `mh-log-buffer' is too big then truncate it.
2249 If the number of lines in `mh-log-buffer' exceeds `mh-log-buffer-lines' then
2250 keep only the last `mh-log-buffer-lines'. As a side effect the point is set to
2251 the end of the log buffer.
2252
2253 The function returns the size of the final size of the log buffer."
2254   (with-current-buffer (get-buffer-create mh-log-buffer)
2255     (goto-char (point-max))
2256     (save-excursion
2257       (when (equal (forward-line (- mh-log-buffer-lines)) 0)
2258         (delete-region (point-min) (point))))
2259     (unless (or (bobp)
2260                 (save-excursion
2261                   (and (equal (forward-line -1) 0) (equal (char-after) ?\f))))
2262       (insert "\n\f\n"))
2263     (buffer-size)))
2264
2265 ;;; Issue commands to MH.
2266
2267 (defun mh-exec-cmd (command &rest args)
2268   "Execute mh-command COMMAND with ARGS.
2269 The side effects are what is desired.
2270 Any output is assumed to be an error and is shown to the user.
2271 The output is not read or parsed by MH-E."
2272   (save-excursion
2273     (set-buffer (get-buffer-create mh-log-buffer))
2274     (let* ((initial-size (mh-truncate-log-buffer))
2275            (start (point))
2276            (args (mh-list-to-string args)))
2277       (apply 'call-process (expand-file-name command mh-progs) nil t nil args)
2278       (when (> (buffer-size) initial-size)
2279         (save-excursion
2280           (goto-char start)
2281           (insert "Errors when executing: " command)
2282           (loop for arg in args do (insert " " arg))
2283           (insert "\n"))
2284         (save-window-excursion
2285           (switch-to-buffer-other-window mh-log-buffer)
2286           (sit-for 5))))))
2287
2288 (defun mh-exec-cmd-error (env command &rest args)
2289   "In environment ENV, execute mh-command COMMAND with ARGS.
2290 ENV is nil or a string of space-separated \"var=value\" elements.
2291 Signals an error if process does not complete successfully."
2292   (save-excursion
2293     (set-buffer (get-buffer-create mh-temp-buffer))
2294     (erase-buffer)
2295     (let ((process-environment process-environment))
2296       ;; XXX: We should purge the list that split-string returns of empty
2297       ;;  strings. This can happen in XEmacs if leading or trailing spaces
2298       ;;  are present.
2299       (dolist (elem (if (stringp env) (split-string env " ") ()))
2300         (push elem process-environment))
2301       (mh-handle-process-error
2302        command (apply #'call-process (expand-file-name command mh-progs)
2303                       nil t nil (mh-list-to-string args))))))
2304
2305 (defun mh-exec-cmd-daemon (command filter &rest args)
2306   "Execute MH command COMMAND in the background.
2307
2308 If FILTER is non-nil then it is used to process the output otherwise the
2309 default filter `mh-process-daemon' is used. See `set-process-filter' for more
2310 details of FILTER.
2311
2312 ARGS are passed to COMMAND as command line arguments."
2313   (save-excursion
2314     (set-buffer (get-buffer-create mh-log-buffer))
2315     (mh-truncate-log-buffer))
2316   (let* ((process-connection-type nil)
2317          (process (apply 'start-process
2318                          command nil
2319                          (expand-file-name command mh-progs)
2320                          (mh-list-to-string args))))
2321     (set-process-filter process (or filter 'mh-process-daemon))
2322     process))
2323
2324 (defun mh-exec-cmd-env-daemon (env command filter &rest args)
2325   "In ennvironment ENV, execute mh-command COMMAND in the background.
2326
2327 ENV is nil or a string of space-separated \"var=value\" elements.
2328 Signals an error if process does not complete successfully.
2329
2330 If FILTER is non-nil then it is used to process the output otherwise the
2331 default filter `mh-process-daemon' is used. See `set-process-filter' for more
2332 details of FILTER.
2333
2334 ARGS are passed to COMMAND as command line arguments."
2335   (let ((process-environment process-environment))
2336     (dolist (elem (if (stringp env) (split-string env " ") ()))
2337       (push elem process-environment))
2338     (apply #'mh-exec-cmd-daemon command filter args)))
2339
2340 (defun mh-process-daemon (process output)
2341   "PROCESS daemon that puts OUTPUT into a temporary buffer.
2342 Any output from the process is displayed in an asynchronous pop-up window."
2343   (set-buffer (get-buffer-create mh-log-buffer))
2344   (insert-before-markers output)
2345   (display-buffer mh-log-buffer))
2346
2347 (defun mh-exec-cmd-quiet (raise-error command &rest args)
2348   "Signal RAISE-ERROR if COMMAND with ARGS fails.
2349 Execute MH command COMMAND with ARGS.  ARGS is a list of strings.
2350 Return at start of mh-temp buffer, where output can be parsed and used.
2351 Returns value of `call-process', which is 0 for success, unless RAISE-ERROR is
2352 non-nil, in which case an error is signaled if `call-process' returns non-0."
2353   (set-buffer (get-buffer-create mh-temp-buffer))
2354   (erase-buffer)
2355   (let ((value
2356          (apply 'call-process
2357                 (expand-file-name command mh-progs) nil t nil
2358                 args)))
2359     (goto-char (point-min))
2360     (if raise-error
2361         (mh-handle-process-error command value)
2362       value)))
2363
2364 (defun mh-profile-component (component)
2365   "Return COMPONENT value from mhparam, or nil if unset."
2366   (save-excursion
2367     (mh-exec-cmd-quiet nil "mhparam" "-components" component)
2368     (mh-get-profile-field (concat component ":"))))
2369
2370 (defun mh-exchange-point-and-mark-preserving-active-mark ()
2371   "Put the mark where point is now, and point where the mark is now.
2372 This command works even when the mark is not active, and preserves whether the
2373 mark is active or not."
2374   (interactive nil)
2375   (let ((is-active (and (boundp 'mark-active) mark-active)))
2376     (let ((omark (mark t)))
2377       (if (null omark)
2378           (error "No mark set in this buffer"))
2379       (set-mark (point))
2380       (goto-char omark)
2381       (if (boundp 'mark-active)
2382           (setq mark-active is-active))
2383       nil)))
2384
2385 (defun mh-exec-cmd-output (command display &rest args)
2386   "Execute MH command COMMAND with DISPLAY flag and ARGS.
2387 Put the output into buffer after point.  Set mark after inserted text.
2388 Output is expected to be shown to user, not parsed by MH-E."
2389   (push-mark (point) t)
2390   (apply 'call-process
2391          (expand-file-name command mh-progs) nil t display
2392          (mh-list-to-string args))
2393
2394   ;; The following is used instead of 'exchange-point-and-mark because the
2395   ;; latter activates the current region (between point and mark), which
2396   ;; turns on highlighting.  So prior to this bug fix, doing "inc" would
2397   ;; highlight a region containing the new messages, which is undesirable.
2398   ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4.
2399   (mh-exchange-point-and-mark-preserving-active-mark))
2400
2401 (defun mh-exec-lib-cmd-output (command &rest args)
2402   "Execute MH library command COMMAND with ARGS.
2403 Put the output into buffer after point.  Set mark after inserted text."
2404   (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args))
2405
2406 (defun mh-handle-process-error (command status)
2407   "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS."
2408   (if (equal status 0)
2409       status
2410     (goto-char (point-min))
2411     (insert (if (integerp status)
2412                 (format "%s: exit code %d\n" command status)
2413               (format "%s: %s\n" command status)))
2414     (save-excursion
2415       (let ((error-message (buffer-substring (point-min) (point-max))))
2416         (set-buffer (get-buffer-create mh-log-buffer))
2417         (mh-truncate-log-buffer)
2418         (insert error-message)))
2419     (error "%s failed, check %s buffer for error message"
2420            command mh-log-buffer)))
2421
2422 (defun mh-list-to-string (l)
2423   "Flatten the list L and make every element of the new list into a string."
2424   (nreverse (mh-list-to-string-1 l)))
2425
2426 (defun mh-list-to-string-1 (l)
2427   "Flatten the list L and make every element of the new list into a string."
2428   (let ((new-list nil))
2429     (while l
2430       (cond ((null (car l)))
2431             ((symbolp (car l))
2432              (setq new-list (cons (symbol-name (car l)) new-list)))
2433             ((numberp (car l))
2434              (setq new-list (cons (int-to-string (car l)) new-list)))
2435             ((equal (car l) ""))
2436             ((stringp (car l)) (setq new-list (cons (car l) new-list)))
2437             ((listp (car l))
2438              (setq new-list (nconc (mh-list-to-string-1 (car l))
2439                                    new-list)))
2440             (t (error "Bad element in mh-list-to-string: %s" (car l))))
2441       (setq l (cdr l)))
2442     new-list))
2443
2444 (defun mh-replace-in-string (regexp newtext string)
2445   "Replace REGEXP with NEWTEXT everywhere in STRING and return result.
2446 NEWTEXT is taken literally---no \\DIGIT escapes will be recognized.
2447
2448 The function body was copied from `dired-replace-in-string' in dired.el.
2449 Emacs21 has `replace-regexp-in-string' while XEmacs has `replace-in-string'.
2450 Neither is present in Emacs20. The file gnus-util.el in Gnus 5.10.1 and above
2451 has `gnus-replace-in-string'. We should use that when we decide to not support
2452 older versions of Gnus."
2453   (let ((result "") (start 0) mb me)
2454     (while (string-match regexp string start)
2455       (setq mb (match-beginning 0)
2456             me (match-end 0)
2457             result (concat result (substring string start mb) newtext)
2458             start me))
2459     (concat result (substring string start))))
2460
2461 (provide 'mh-utils)
2462
2463 ;;; Local Variables:
2464 ;;; indent-tabs-mode: nil
2465 ;;; sentence-end-double-space: nil
2466 ;;; End:
2467
2468 ;;; mh-utils.el ends here