Mercurial > emacs
comparison lisp/mh-e/mh-utils.el @ 49459:06b77df47802
* mh-e: Created directory. ChangeLog will appear in a week when we
release version 7.2.
* lisp/mail/mh-alias.el, lisp/mail/mh-comp.el,
lisp/mail/mh-customize.el, lisp/mail/mh-e.el, lisp/mail/mh-funcs.el,
lisp/mail/mh-identity.el, lisp/mail/mh-index.el,
lisp/mail/mh-loaddefs.el, lisp/mail/mh-mime.el, lisp/mail/mh-pick.el,
lisp/mail/mh-seq.el, lisp/mail/mh-speed.el, lisp/mail/mh-utils.el,
lisp/mail/mh-xemacs-compat.el: Moved to mh-e. Note that reply2.pbm and
reply2.xpm, which were created by the MH-E package, were left in mail
since they can probably be used by other mail packages.
* makefile.w32-in (WINS): Added mh-e.
* makefile.nt (WINS): Added mh-e.
| author | Bill Wohler <wohler@newt.com> |
|---|---|
| date | Sun, 26 Jan 2003 02:38:37 +0000 |
| parents | |
| children | b35587af8747 |
comparison
equal
deleted
inserted
replaced
| 49458:5ddabc4c81b0 | 49459:06b77df47802 |
|---|---|
| 1 ;;; mh-utils.el --- MH-E code needed for both sending and reading | |
| 2 | |
| 3 ;; Copyright (C) 1993, 1995, 1997, 2000, 2001, 2002 Free Software Foundation, Inc. | |
| 4 | |
| 5 ;; Author: Bill Wohler <wohler@newt.com> | |
| 6 ;; Maintainer: Bill Wohler <wohler@newt.com> | |
| 7 ;; Keywords: mail | |
| 8 ;; See: mh-e.el | |
| 9 | |
| 10 ;; This file is part of GNU Emacs. | |
| 11 | |
| 12 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
| 13 ;; it under the terms of the GNU General Public License as published by | |
| 14 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 15 ;; any later version. | |
| 16 | |
| 17 ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 20 ;; GNU General Public License for more details. | |
| 21 | |
| 22 ;; You should have received a copy of the GNU General Public License | |
| 23 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
| 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 25 ;; Boston, MA 02111-1307, USA. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;; Internal support for MH-E package. | |
| 30 | |
| 31 ;;; Change Log: | |
| 32 | |
| 33 ;; $Id: mh-utils.el,v 1.34 2003/01/08 23:21:16 wohler Exp $ | |
| 34 | |
| 35 ;;; Code: | |
| 36 | |
| 37 ;; Is this XEmacs-land? Located here since needed by mh-customize.el. | |
| 38 (defvar mh-xemacs-flag (featurep 'xemacs) | |
| 39 "Non-nil means the current Emacs is XEmacs.") | |
| 40 | |
| 41 (require 'cl) | |
| 42 (require 'gnus-util) | |
| 43 (require 'font-lock) | |
| 44 (require 'mh-loaddefs) | |
| 45 (require 'mh-customize) | |
| 46 | |
| 47 (load "mm-decode" t t) ; Non-fatal dependency | |
| 48 (load "mm-view" t t) ; Non-fatal dependency | |
| 49 (load "executable" t t) ; Non-fatal dependency on | |
| 50 ; executable-find | |
| 51 | |
| 52 ;; Shush the byte-compiler | |
| 53 (defvar font-lock-auto-fontify) | |
| 54 (defvar font-lock-defaults) | |
| 55 (defvar mark-active) | |
| 56 (defvar tool-bar-mode) | |
| 57 | |
| 58 ;;; Autoloads | |
| 59 (autoload 'gnus-article-highlight-citation "gnus-cite") | |
| 60 (autoload 'mail-header-end "sendmail") | |
| 61 (autoload 'Info-goto-node "info") | |
| 62 (unless (fboundp 'make-hash-table) | |
| 63 (autoload 'make-hash-table "cl")) | |
| 64 | |
| 65 ;;; Set for local environment: | |
| 66 ;;; mh-progs and mh-lib used to be set in paths.el, which tried to | |
| 67 ;;; figure out at build time which of several possible directories MH | |
| 68 ;;; was installed into. But if you installed MH after building Emacs, | |
| 69 ;;; this would almost certainly be wrong, so now we do it at run time. | |
| 70 | |
| 71 (defvar mh-progs nil | |
| 72 "Directory containing MH commands, such as inc, repl, and rmm.") | |
| 73 | |
| 74 (defvar mh-lib nil | |
| 75 "Directory containing the MH library. | |
| 76 This directory contains, among other things, the components file.") | |
| 77 | |
| 78 (defvar mh-lib-progs nil | |
| 79 "Directory containing MH helper programs. | |
| 80 This directory contains, among other things, the mhl program.") | |
| 81 | |
| 82 (defvar mh-nmh-flag nil | |
| 83 "Non-nil means nmh is installed on this system instead of MH.") | |
| 84 | |
| 85 ;;;###autoload | |
| 86 (put 'mh-progs 'risky-local-variable t) | |
| 87 ;;;###autoload | |
| 88 (put 'mh-lib 'risky-local-variable t) | |
| 89 ;;;###autoload | |
| 90 (put 'mh-lib-progs 'risky-local-variable t) | |
| 91 ;;;###autoload | |
| 92 (put 'mh-nmh-flag 'risky-local-variable t) | |
| 93 | |
| 94 ;;; CL Replacements | |
| 95 (defun mh-search-from-end (char string) | |
| 96 "Return the position of last occurrence of CHAR in STRING. | |
| 97 If CHAR is not present in STRING then return nil. The function is used in lieu | |
| 98 of `search' in the CL package." | |
| 99 (loop for index from (1- (length string)) downto 0 | |
| 100 when (equal (aref string index) char) return index | |
| 101 finally return nil)) | |
| 102 | |
| 103 ;;; Macro to generate correct code for different emacs variants | |
| 104 | |
| 105 (defmacro mh-mark-active-p (check-transient-mark-mode-flag) | |
| 106 "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs. | |
| 107 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if | |
| 108 variable `transient-mark-mode' is active." | |
| 109 (cond (mh-xemacs-flag ;XEmacs | |
| 110 `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p))) | |
| 111 ((not check-transient-mark-mode-flag) ;GNU Emacs | |
| 112 `(and (boundp 'mark-active) mark-active)) | |
| 113 (t ;GNU Emacs | |
| 114 `(and (boundp 'transient-mark-mode) transient-mark-mode | |
| 115 (boundp 'mark-active) mark-active)))) | |
| 116 | |
| 117 ;;; Additional header fields that might someday be added: | |
| 118 ;;; "Sender: " "Reply-to: " | |
| 119 | |
| 120 (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" | |
| 121 "Regexp to find the number of a message in a scan line. | |
| 122 The message's number must be surrounded with \\( \\)") | |
| 123 | |
| 124 (defvar mh-scan-msg-overflow-regexp "^\\?[0-9]" | |
| 125 "Regexp to find a scan line in which the message number overflowed. | |
| 126 The message's number is left truncated in this case.") | |
| 127 | |
| 128 (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" | |
| 129 "Regexp to find message number width in an scan format. | |
| 130 The message number width must be surrounded with \\( \\).") | |
| 131 | |
| 132 (defvar mh-scan-msg-format-string "%d" | |
| 133 "Format string for width of the message number in a scan format. | |
| 134 Use `0%d' for zero-filled message numbers.") | |
| 135 | |
| 136 (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" | |
| 137 "Format string containing a regexp matching the scan listing for a message. | |
| 138 The desired message's number will be an argument to format.") | |
| 139 | |
| 140 (defvar mh-default-folder-for-message-function nil | |
| 141 "Function to select a default folder for refiling or Fcc. | |
| 142 If set to a function, that function is called with no arguments by | |
| 143 `\\[mh-refile-msg]' and `\\[mh-to-fcc]' to get a default when | |
| 144 prompting the user for a folder. The function is called from within a | |
| 145 `save-excursion', with point at the start of the message. It should | |
| 146 return the folder to offer as the refile or Fcc folder, as a string | |
| 147 with a leading `+' sign. It can also return an empty string to use no | |
| 148 default, or nil to calculate the default the usual way. | |
| 149 NOTE: This variable is not an ordinary hook; | |
| 150 It may not be a list of functions.") | |
| 151 | |
| 152 (defvar mh-show-buffer-mode-line-buffer-id "{show-%s} %d" | |
| 153 "Format string to produce `mode-line-buffer-identification' for show buffers. | |
| 154 First argument is folder name. Second is message number.") | |
| 155 | |
| 156 (defvar mh-cmd-note 4 | |
| 157 "Column to insert notation. | |
| 158 Use `mh-set-cmd-note' to modify it. | |
| 159 This value may be dynamically updated if `mh-adaptive-cmd-note-flag' is | |
| 160 non-nil and `mh-scan-format-file' is t. | |
| 161 Note that the first column is column number 0.") | |
| 162 (make-variable-buffer-local 'mh-cmd-note) | |
| 163 | |
| 164 (defvar mh-note-seq "%" | |
| 165 "String whose first character is used to notate messages in a sequence.") | |
| 166 | |
| 167 (defvar mh-mail-header-separator "--------" | |
| 168 "*Line used by MH to separate headers from text in messages being composed. | |
| 169 This variable should not be used directly in programs. Programs should use | |
| 170 `mail-header-separator' instead. `mail-header-separator' is initialized to | |
| 171 `mh-mail-header-separator' in `mh-letter-mode'; in other contexts, you may | |
| 172 have to perform this initialization yourself. | |
| 173 | |
| 174 Do not make this a regexp as it may be the argument to `insert' and it is | |
| 175 passed through `regexp-quote' before being used by functions like | |
| 176 `re-search-forward'.") | |
| 177 | |
| 178 ;; Variables for MIME display | |
| 179 | |
| 180 ;; Structure to keep track of MIME handles on a per buffer basis. | |
| 181 (defstruct (mh-buffer-data (:conc-name mh-mime-) | |
| 182 (:constructor mh-make-buffer-data)) | |
| 183 (handles ()) ; List of MIME handles | |
| 184 (handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of | |
| 185 ; nested messages | |
| 186 (parts-count 0) ; The button number is generated from | |
| 187 ; this number | |
| 188 (part-index-hash (make-hash-table))) ; Avoid incrementing the part number | |
| 189 ; for nested messages | |
| 190 ;;; This has to be a macro, since we do: (setf (mh-buffer-data) ...) | |
| 191 (defmacro mh-buffer-data () | |
| 192 "Convenience macro to get the MIME data structures of the current buffer." | |
| 193 `(gethash (current-buffer) mh-globals-hash)) | |
| 194 | |
| 195 (defvar mh-globals-hash (make-hash-table) | |
| 196 "Keeps track of MIME data on a per buffer basis.") | |
| 197 | |
| 198 (defvar mh-gnus-pgp-support-flag (not (not (locate-library "mml2015"))) | |
| 199 "Non-nil means installed Gnus has PGP support.") | |
| 200 | |
| 201 (defvar mh-mm-inline-media-tests | |
| 202 `(("image/jpeg" | |
| 203 mm-inline-image | |
| 204 (lambda (handle) | |
| 205 (mm-valid-and-fit-image-p 'jpeg handle))) | |
| 206 ("image/png" | |
| 207 mm-inline-image | |
| 208 (lambda (handle) | |
| 209 (mm-valid-and-fit-image-p 'png handle))) | |
| 210 ("image/gif" | |
| 211 mm-inline-image | |
| 212 (lambda (handle) | |
| 213 (mm-valid-and-fit-image-p 'gif handle))) | |
| 214 ("image/tiff" | |
| 215 mm-inline-image | |
| 216 (lambda (handle) | |
| 217 (mm-valid-and-fit-image-p 'tiff handle)) ) | |
| 218 ("image/xbm" | |
| 219 mm-inline-image | |
| 220 (lambda (handle) | |
| 221 (mm-valid-and-fit-image-p 'xbm handle))) | |
| 222 ("image/x-xbitmap" | |
| 223 mm-inline-image | |
| 224 (lambda (handle) | |
| 225 (mm-valid-and-fit-image-p 'xbm handle))) | |
| 226 ("image/xpm" | |
| 227 mm-inline-image | |
| 228 (lambda (handle) | |
| 229 (mm-valid-and-fit-image-p 'xpm handle))) | |
| 230 ("image/x-pixmap" | |
| 231 mm-inline-image | |
| 232 (lambda (handle) | |
| 233 (mm-valid-and-fit-image-p 'xpm handle))) | |
| 234 ("image/bmp" | |
| 235 mm-inline-image | |
| 236 (lambda (handle) | |
| 237 (mm-valid-and-fit-image-p 'bmp handle))) | |
| 238 ("image/x-portable-bitmap" | |
| 239 mm-inline-image | |
| 240 (lambda (handle) | |
| 241 (mm-valid-and-fit-image-p 'pbm handle))) | |
| 242 ("text/plain" mm-inline-text identity) | |
| 243 ("text/enriched" mm-inline-text identity) | |
| 244 ("text/richtext" mm-inline-text identity) | |
| 245 ("text/x-patch" mm-display-patch-inline | |
| 246 (lambda (handle) | |
| 247 (locate-library "diff-mode"))) | |
| 248 ("application/emacs-lisp" mm-display-elisp-inline identity) | |
| 249 ("application/x-emacs-lisp" mm-display-elisp-inline identity) | |
| 250 ("text/html" | |
| 251 ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text) | |
| 252 (lambda (handle) | |
| 253 (or (and (boundp 'mm-inline-text-html-renderer) | |
| 254 mm-inline-text-html-renderer) | |
| 255 (and (boundp 'mm-text-html-renderer) mm-text-html-renderer)))) | |
| 256 ("text/x-vcard" | |
| 257 mm-inline-text-vcard | |
| 258 (lambda (handle) | |
| 259 (or (featurep 'vcard) | |
| 260 (locate-library "vcard")))) | |
| 261 ("message/delivery-status" mm-inline-text identity) | |
| 262 ("message/rfc822" mh-mm-inline-message identity) | |
| 263 ;;("message/partial" mm-inline-partial identity) | |
| 264 ;;("message/external-body" mm-inline-external-body identity) | |
| 265 ("text/.*" mm-inline-text identity) | |
| 266 ("audio/wav" mm-inline-audio | |
| 267 (lambda (handle) | |
| 268 (and (or (featurep 'nas-sound) (featurep 'native-sound)) | |
| 269 (device-sound-enabled-p)))) | |
| 270 ("audio/au" | |
| 271 mm-inline-audio | |
| 272 (lambda (handle) | |
| 273 (and (or (featurep 'nas-sound) (featurep 'native-sound)) | |
| 274 (device-sound-enabled-p)))) | |
| 275 ("application/pgp-signature" ignore identity) | |
| 276 ("application/x-pkcs7-signature" ignore identity) | |
| 277 ("application/pkcs7-signature" ignore identity) | |
| 278 ("application/x-pkcs7-mime" ignore identity) | |
| 279 ("application/pkcs7-mime" ignore identity) | |
| 280 ("multipart/alternative" ignore identity) | |
| 281 ("multipart/mixed" ignore identity) | |
| 282 ("multipart/related" ignore identity) | |
| 283 ;; Disable audio and image | |
| 284 ("audio/.*" ignore ignore) | |
| 285 ("image/.*" ignore ignore) | |
| 286 ;; Default to displaying as text | |
| 287 (".*" mm-inline-text mm-readable-p)) | |
| 288 "Alist of media types/tests saying whether types can be displayed inline.") | |
| 289 | |
| 290 ;; Needed by mh-comp.el and mh-mime.el | |
| 291 (defvar mh-mhn-compose-insert-flag nil | |
| 292 "Non-nil means MIME insertion was done. | |
| 293 Triggers an automatic call to `mh-edit-mhn' in `mh-send-letter'. | |
| 294 This variable is buffer-local.") | |
| 295 (make-variable-buffer-local 'mh-mhn-compose-insert-flag) | |
| 296 | |
| 297 (defvar mh-mml-compose-insert-flag nil | |
| 298 "Non-nil means that a MIME insertion was done. | |
| 299 This buffer-local variable is used to remember if a MIME insertion was done. | |
| 300 Triggers an automatic call to `mh-mml-to-mime' in `mh-send-letter'.") | |
| 301 (make-variable-buffer-local 'mh-mml-compose-insert-flag) | |
| 302 | |
| 303 ;; Copy of `goto-address-mail-regexp' | |
| 304 (defvar mh-address-mail-regexp | |
| 305 "[-a-zA-Z0-9._]+@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+" | |
| 306 "A regular expression probably matching an e-mail address.") | |
| 307 | |
| 308 ;; From goto-addr.el, which we don't want to force-load on users. | |
| 309 ;;;###mh-autoload | |
| 310 (defun mh-goto-address-find-address-at-point () | |
| 311 "Find e-mail address around or before point. | |
| 312 Then search backwards to beginning of line for the start of an e-mail | |
| 313 address. If no e-mail address found, return nil." | |
| 314 (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) | |
| 315 (if (or (looking-at mh-address-mail-regexp) ; already at start | |
| 316 (and (re-search-forward mh-address-mail-regexp | |
| 317 (line-end-position) 'lim) | |
| 318 (goto-char (match-beginning 0)))) | |
| 319 (match-string-no-properties 0))) | |
| 320 | |
| 321 (defun mh-in-header-p () | |
| 322 "Return non-nil if the point is in the header of a draft message." | |
| 323 (< (point) (mail-header-end))) | |
| 324 | |
| 325 (defun mh-header-field-beginning () | |
| 326 "Move to the beginning of the current header field. | |
| 327 Handles RFC 822 continuation lines." | |
| 328 (beginning-of-line) | |
| 329 (while (looking-at "^[ \t]") | |
| 330 (forward-line -1))) | |
| 331 | |
| 332 (defun mh-header-field-end () | |
| 333 "Move to the end of the current header field. | |
| 334 Handles RFC 822 continuation lines." | |
| 335 (forward-line 1) | |
| 336 (while (looking-at "^[ \t]") | |
| 337 (forward-line 1)) | |
| 338 (backward-char 1)) ;to end of previous line | |
| 339 | |
| 340 (defun mh-letter-header-font-lock (limit) | |
| 341 "Return the entire mail header to font-lock. | |
| 342 Argument LIMIT limits search." | |
| 343 (if (= (point) limit) | |
| 344 nil | |
| 345 (let* ((mail-header-end (save-match-data (mail-header-end))) | |
| 346 (lesser-limit (if (< mail-header-end limit) mail-header-end limit))) | |
| 347 (when (mh-in-header-p) | |
| 348 (set-match-data (list 1 lesser-limit)) | |
| 349 (goto-char lesser-limit) | |
| 350 t)))) | |
| 351 | |
| 352 (defun mh-header-field-font-lock (field limit) | |
| 353 "Return the value of a header field FIELD to font-lock. | |
| 354 Argument LIMIT limits search." | |
| 355 (if (= (point) limit) | |
| 356 nil | |
| 357 (let* ((mail-header-end (mail-header-end)) | |
| 358 (lesser-limit (if (< mail-header-end limit) mail-header-end limit)) | |
| 359 (case-fold-search t)) | |
| 360 (when (and (< (point) mail-header-end) ;Only within header | |
| 361 (re-search-forward (format "^%s" field) lesser-limit t)) | |
| 362 (let ((match-one-b (match-beginning 0)) | |
| 363 (match-one-e (match-end 0))) | |
| 364 (mh-header-field-end) | |
| 365 (if (> (point) limit) ;Don't search for end beyond limit | |
| 366 (goto-char limit)) | |
| 367 (set-match-data (list match-one-b match-one-e | |
| 368 (1+ match-one-e) (point))) | |
| 369 t))))) | |
| 370 | |
| 371 (defun mh-header-to-font-lock (limit) | |
| 372 "Return the value of a header field To to font-lock. | |
| 373 Argument LIMIT limits search." | |
| 374 (mh-header-field-font-lock "To:" limit)) | |
| 375 | |
| 376 (defun mh-header-cc-font-lock (limit) | |
| 377 "Return the value of a header field cc to font-lock. | |
| 378 Argument LIMIT limits search." | |
| 379 (mh-header-field-font-lock "cc:" limit)) | |
| 380 | |
| 381 (defun mh-header-subject-font-lock (limit) | |
| 382 "Return the value of a header field Subject to font-lock. | |
| 383 Argument LIMIT limits search." | |
| 384 (mh-header-field-font-lock "Subject:" limit)) | |
| 385 | |
| 386 (eval-and-compile | |
| 387 ;; Otherwise byte-compilation fails on `mh-show-font-lock-keywords-with-cite' | |
| 388 (defvar mh-show-font-lock-keywords | |
| 389 '(("^\\(From:\\|Sender:\\)\\(.*\\)" (1 'default) (2 mh-show-from-face)) | |
| 390 (mh-header-to-font-lock (0 'default) (1 mh-show-to-face)) | |
| 391 (mh-header-cc-font-lock (0 'default) (1 mh-show-cc-face)) | |
| 392 ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" | |
| 393 (1 'default) (2 mh-show-from-face)) | |
| 394 (mh-header-subject-font-lock (0 'default) (1 mh-show-subject-face)) | |
| 395 ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" | |
| 396 (1 'default) (2 mh-show-cc-face)) | |
| 397 ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" | |
| 398 (1 'default) (2 mh-show-date-face)) | |
| 399 (mh-letter-header-font-lock (0 mh-show-header-face append t))) | |
| 400 "Additional expressions to highlight in MH-show mode.")) | |
| 401 | |
| 402 (defvar mh-show-font-lock-keywords-with-cite | |
| 403 (eval-when-compile | |
| 404 (let* ((cite-chars "[>|}]") | |
| 405 (cite-prefix "A-Za-z") | |
| 406 (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) | |
| 407 (append | |
| 408 mh-show-font-lock-keywords | |
| 409 (list | |
| 410 ;; Use MATCH-ANCHORED to effectively anchor the regexp left side. | |
| 411 `(,cite-chars | |
| 412 (,(concat "\\=[ \t]*" | |
| 413 "\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?" | |
| 414 "\\(" cite-chars "[ \t]*\\)\\)+" | |
| 415 "\\(.*\\)") | |
| 416 (beginning-of-line) (end-of-line) | |
| 417 (2 font-lock-constant-face nil t) | |
| 418 (4 font-lock-comment-face nil t))))))) | |
| 419 "Additional expressions to highlight in MH-show mode.") | |
| 420 | |
| 421 (defun mh-show-font-lock-fontify-region (beg end loudly) | |
| 422 "Limit font-lock in `mh-show-mode' to the header. | |
| 423 Used when `mh-highlight-citation-p' is set to gnus, leaving the body to be | |
| 424 dealt with by gnus highlighting. The region between BEG and END is | |
| 425 given over to be fontified and LOUDLY controls if a user sees a | |
| 426 message about the fontification operation." | |
| 427 (let ((header-end (mail-header-end))) | |
| 428 (cond | |
| 429 ((and (< beg header-end)(< end header-end)) | |
| 430 (font-lock-default-fontify-region beg end loudly)) | |
| 431 ((and (< beg header-end)(>= end header-end)) | |
| 432 (font-lock-default-fontify-region beg header-end loudly)) | |
| 433 (t | |
| 434 nil)))) | |
| 435 | |
| 436 ;; Needed to help shush the byte-compiler. | |
| 437 (if mh-xemacs-flag | |
| 438 (progn | |
| 439 (eval-and-compile | |
| 440 (require 'gnus) | |
| 441 (require 'gnus-art) | |
| 442 (require 'gnus-cite)))) | |
| 443 | |
| 444 (defun mh-gnus-article-highlight-citation () | |
| 445 "Highlight cited text in current buffer using gnus." | |
| 446 (interactive) | |
| 447 ;; Requiring gnus-cite should have been sufficient. However for Emacs21.1, | |
| 448 ;; recursive-load-depth-limit is only 10, so an error occurs. Also it may be | |
| 449 ;; better to have an autoload at top-level (though that won't work because | |
| 450 ;; of recursive-load-depth-limit). That gets rid of a compiler warning as | |
| 451 ;; well. | |
| 452 (unless mh-xemacs-flag | |
| 453 (require 'gnus-art) | |
| 454 (require 'gnus-cite)) | |
| 455 ;; Don't allow Gnus to create buttons while highlighting, maybe this is bad | |
| 456 ;; style? | |
| 457 (flet ((gnus-article-add-button (&rest args) nil)) | |
| 458 (let* ((modified (buffer-modified-p)) | |
| 459 (gnus-article-buffer (buffer-name)) | |
| 460 (gnus-cite-face-list `(,@(cdr gnus-cite-face-list) | |
| 461 ,(car gnus-cite-face-list)))) | |
| 462 (gnus-article-highlight-citation t) | |
| 463 (set-buffer-modified-p modified)))) | |
| 464 | |
| 465 ;;; Internal bookkeeping variables: | |
| 466 | |
| 467 ;; The value of `mh-folder-list-change-hook' is called whenever | |
| 468 ;; mh-folder-list variable is set. | |
| 469 ;; List of folder names for completion. | |
| 470 (defvar mh-folder-list nil) | |
| 471 | |
| 472 ;; Cached value of the `Path:' component in the user's MH profile. | |
| 473 ;; User's mail folder directory. | |
| 474 (defvar mh-user-path nil) | |
| 475 | |
| 476 ;; An mh-draft-folder of nil means do not use a draft folder. | |
| 477 ;; Cached value of the `Draft-Folder:' component in the user's MH profile. | |
| 478 ;; Name of folder containing draft messages. | |
| 479 (defvar mh-draft-folder nil) | |
| 480 | |
| 481 ;; Cached value of the `Unseen-Sequence:' component in the user's MH profile. | |
| 482 ;; Name of the Unseen sequence. | |
| 483 (defvar mh-unseen-seq nil) | |
| 484 | |
| 485 ;; Cached value of the `Previous-Sequence:' component in the user's MH | |
| 486 ;; profile. | |
| 487 ;; Name of the Previous sequence. | |
| 488 (defvar mh-previous-seq nil) | |
| 489 | |
| 490 ;; Cached value of the `Inbox:' component in the user's MH profile, | |
| 491 ;; or "+inbox" if no such component. | |
| 492 ;; Name of the Inbox folder. | |
| 493 (defvar mh-inbox nil) | |
| 494 | |
| 495 ;; Name of MH-E scratch buffer. | |
| 496 (defconst mh-temp-buffer " *mh-temp*") | |
| 497 | |
| 498 ;; Name of the MH-E folder list buffer. | |
| 499 (defconst mh-temp-folders-buffer "*Folders*") | |
| 500 | |
| 501 ;; Name of the MH-E sequences list buffer. | |
| 502 (defconst mh-temp-sequences-buffer "*Sequences*") | |
| 503 | |
| 504 ;; Window configuration before MH-E command. | |
| 505 (defvar mh-previous-window-config nil) | |
| 506 | |
| 507 ;;Non-nil means next SPC or whatever goes to next undeleted message. | |
| 508 (defvar mh-page-to-next-msg-flag nil) | |
| 509 | |
| 510 ;;; Internal variables local to a folder. | |
| 511 | |
| 512 ;; Name of current folder, a string. | |
| 513 (defvar mh-current-folder nil) | |
| 514 | |
| 515 ;; Buffer that displays message for this folder. | |
| 516 (defvar mh-show-buffer nil) | |
| 517 | |
| 518 ;; Full path of directory for this folder. | |
| 519 (defvar mh-folder-filename nil) | |
| 520 | |
| 521 ;;Number of msgs in buffer. | |
| 522 (defvar mh-msg-count nil) | |
| 523 | |
| 524 ;; If non-nil, show the message in a separate window. | |
| 525 (defvar mh-showing-mode nil) | |
| 526 | |
| 527 (defvar mh-show-mode-map (make-sparse-keymap) | |
| 528 "Keymap used by the show buffer.") | |
| 529 | |
| 530 (defvar mh-show-folder-buffer nil | |
| 531 "Keeps track of folder whose message is being displayed.") | |
| 532 | |
| 533 ;;; This holds a documentation string used by describe-mode. | |
| 534 (defun mh-showing-mode (&optional arg) | |
| 535 "Change whether messages should be displayed. | |
| 536 With arg, display messages iff ARG is positive." | |
| 537 (setq mh-showing-mode | |
| 538 (if (null arg) | |
| 539 (not mh-showing-mode) | |
| 540 (> (prefix-numeric-value arg) 0)))) | |
| 541 | |
| 542 ;; The sequences of this folder. An alist of (seq . msgs). | |
| 543 (defvar mh-seq-list nil) | |
| 544 | |
| 545 ;; List of displayed messages to be removed from the Unseen sequence. | |
| 546 (defvar mh-seen-list nil) | |
| 547 | |
| 548 ;; If non-nil, show buffer contains message with all headers. | |
| 549 ;; If nil, show buffer contains message processed normally. | |
| 550 ;; Showing message with headers or normally. | |
| 551 (defvar mh-showing-with-headers nil) | |
| 552 | |
| 553 | |
| 554 ;;; MH-E macros | |
| 555 | |
| 556 (defmacro with-mh-folder-updating (save-modification-flag &rest body) | |
| 557 "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). | |
| 558 Execute BODY, which can modify the folder buffer without having to | |
| 559 worry about file locking or the read-only flag, and return its result. | |
| 560 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification | |
| 561 flag is unchanged, otherwise it is cleared." | |
| 562 (setq save-modification-flag (car save-modification-flag)) ; CL style | |
| 563 `(prog1 | |
| 564 (let ((mh-folder-updating-mod-flag (buffer-modified-p)) | |
| 565 (buffer-read-only nil) | |
| 566 (buffer-file-name nil)) ;don't let the buffer get locked | |
| 567 (prog1 | |
| 568 (progn | |
| 569 ,@body) | |
| 570 (mh-set-folder-modified-p mh-folder-updating-mod-flag))) | |
| 571 ,@(if (not save-modification-flag) | |
| 572 '((mh-set-folder-modified-p nil))))) | |
| 573 | |
| 574 (put 'with-mh-folder-updating 'lisp-indent-hook 1) | |
| 575 | |
| 576 (defmacro mh-in-show-buffer (show-buffer &rest body) | |
| 577 "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY). | |
| 578 Display buffer SHOW-BUFFER in other window and execute BODY in it. | |
| 579 Stronger than `save-excursion', weaker than `save-window-excursion'." | |
| 580 (setq show-buffer (car show-buffer)) ; CL style | |
| 581 `(let ((mh-in-show-buffer-saved-window (selected-window))) | |
| 582 (switch-to-buffer-other-window ,show-buffer) | |
| 583 (if mh-bury-show-buffer-flag (bury-buffer (current-buffer))) | |
| 584 (unwind-protect | |
| 585 (progn | |
| 586 ,@body) | |
| 587 (select-window mh-in-show-buffer-saved-window)))) | |
| 588 | |
| 589 (put 'mh-in-show-buffer 'lisp-indent-hook 1) | |
| 590 | |
| 591 (defmacro mh-make-seq (name msgs) | |
| 592 "Create sequence NAME with the given MSGS." | |
| 593 (list 'cons name msgs)) | |
| 594 | |
| 595 (defmacro mh-seq-name (sequence) | |
| 596 "Extract sequence name from the given SEQUENCE." | |
| 597 (list 'car sequence)) | |
| 598 | |
| 599 (defmacro mh-seq-msgs (sequence) | |
| 600 "Extract messages from the given SEQUENCE." | |
| 601 (list 'cdr sequence)) | |
| 602 | |
| 603 (defun mh-recenter (arg) | |
| 604 "Like recenter but with three improvements: | |
| 605 - At the end of the buffer it tries to show fewer empty lines. | |
| 606 - operates only if the current buffer is in the selected window. | |
| 607 (Commands like `save-some-buffers' can make this false.) | |
| 608 - nil ARG means recenter as if prefix argument had been given." | |
| 609 (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) | |
| 610 nil) | |
| 611 ((= (point-max) (save-excursion | |
| 612 (forward-line (- (/ (window-height) 2) 2)) | |
| 613 (point))) | |
| 614 (let ((lines-from-end 2)) | |
| 615 (save-excursion | |
| 616 (while (> (point-max) (progn (forward-line) (point))) | |
| 617 (incf lines-from-end))) | |
| 618 (recenter (- lines-from-end)))) | |
| 619 ;; '(4) is the same as C-u prefix argument. | |
| 620 (t (recenter (or arg '(4)))))) | |
| 621 | |
| 622 (defun mh-start-of-uncleaned-message () | |
| 623 "Position uninteresting headers off the top of the window." | |
| 624 (let ((case-fold-search t)) | |
| 625 (re-search-forward | |
| 626 "^To:\\|^Cc:\\|^From:\\|^Subject:\\|^Date:" nil t) | |
| 627 (beginning-of-line) | |
| 628 (mh-recenter 0))) | |
| 629 | |
| 630 (defun mh-invalidate-show-buffer () | |
| 631 "Invalidate the show buffer so we must update it to use it." | |
| 632 (if (get-buffer mh-show-buffer) | |
| 633 (save-excursion | |
| 634 (set-buffer mh-show-buffer) | |
| 635 (mh-unvisit-file)))) | |
| 636 | |
| 637 (defun mh-unvisit-file () | |
| 638 "Separate current buffer from the message file it was visiting." | |
| 639 (or (not (buffer-modified-p)) | |
| 640 (null buffer-file-name) ;we've been here before | |
| 641 (yes-or-no-p (format "Message %s modified; flush changes? " | |
| 642 (file-name-nondirectory buffer-file-name))) | |
| 643 (error "Flushing changes not confirmed")) | |
| 644 (clear-visited-file-modtime) | |
| 645 (unlock-buffer) | |
| 646 (setq buffer-file-name nil)) | |
| 647 | |
| 648 ;;;###mh-autoload | |
| 649 (defun mh-get-msg-num (error-if-no-message) | |
| 650 "Return the message number of the displayed message. | |
| 651 If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is | |
| 652 not pointing to a message." | |
| 653 (save-excursion | |
| 654 (beginning-of-line) | |
| 655 (cond ((looking-at mh-scan-msg-number-regexp) | |
| 656 (string-to-int (buffer-substring (match-beginning 1) | |
| 657 (match-end 1)))) | |
| 658 (error-if-no-message | |
| 659 (error "Cursor not pointing to message")) | |
| 660 (t nil)))) | |
| 661 | |
| 662 (defun mh-folder-name-p (name) | |
| 663 "Return non-nil if NAME is the name of a folder. | |
| 664 A name (a string or symbol) can be a folder name if it begins with \"+\"." | |
| 665 (if (symbolp name) | |
| 666 (eq (aref (symbol-name name) 0) ?+) | |
| 667 (and (> (length name) 0) | |
| 668 (eq (aref name 0) ?+)))) | |
| 669 | |
| 670 | |
| 671 (defun mh-expand-file-name (filename &optional default) | |
| 672 "Expand FILENAME like `expand-file-name', but also handle MH folder names. | |
| 673 Any filename that starts with '+' is treated as a folder name. | |
| 674 See `expand-file-name' for description of DEFAULT." | |
| 675 (if (mh-folder-name-p filename) | |
| 676 (expand-file-name (substring filename 1) mh-user-path) | |
| 677 (expand-file-name filename default))) | |
| 678 | |
| 679 | |
| 680 (defun mh-msg-filename (msg &optional folder) | |
| 681 "Return the file name of MSG in FOLDER (default current folder)." | |
| 682 (expand-file-name (int-to-string msg) | |
| 683 (if folder | |
| 684 (mh-expand-file-name folder) | |
| 685 mh-folder-filename))) | |
| 686 | |
| 687 ;;; Infrastructure to generate show-buffer functions from folder functions | |
| 688 ;;; XEmacs does not have deactivate-mark? What is the equivalent of | |
| 689 ;;; transient-mark-mode for XEmacs? Should we be restoring the mark in the | |
| 690 ;;; folder buffer after the operation has been carried out. | |
| 691 (defmacro mh-defun-show-buffer (function original-function | |
| 692 &optional dont-return) | |
| 693 "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. | |
| 694 If the buffer we start in is still visible and DONT-RETURN is nil then switch | |
| 695 to it after that." | |
| 696 `(defun ,function () | |
| 697 ,(format "Calls %s from the message's folder.\n%s\nSee `%s' for more info.\n" | |
| 698 original-function | |
| 699 (if dont-return "" | |
| 700 "When function completes, returns to the show buffer if it is | |
| 701 still visible.\n") | |
| 702 original-function) | |
| 703 (interactive) | |
| 704 (when (buffer-live-p (get-buffer mh-show-folder-buffer)) | |
| 705 (let ((config (current-window-configuration)) | |
| 706 (folder-buffer mh-show-folder-buffer) | |
| 707 (normal-exit nil) | |
| 708 ,@(if dont-return () '((cur-buffer-name (buffer-name))))) | |
| 709 (pop-to-buffer mh-show-folder-buffer nil) | |
| 710 (unless (equal (buffer-name | |
| 711 (window-buffer (frame-first-window (selected-frame)))) | |
| 712 folder-buffer) | |
| 713 (delete-other-windows)) | |
| 714 (mh-goto-cur-msg t) | |
| 715 (and (fboundp 'deactivate-mark) (deactivate-mark)) | |
| 716 (unwind-protect | |
| 717 (prog1 (call-interactively (function ,original-function)) | |
| 718 (setq normal-exit t)) | |
| 719 (and (fboundp 'deactivate-mark) (deactivate-mark)) | |
| 720 (cond ((not normal-exit) | |
| 721 (set-window-configuration config)) | |
| 722 ,(if dont-return | |
| 723 `(t (setq mh-previous-window-config config)) | |
| 724 `((and (get-buffer cur-buffer-name) | |
| 725 (window-live-p (get-buffer-window | |
| 726 (get-buffer cur-buffer-name)))) | |
| 727 (pop-to-buffer (get-buffer cur-buffer-name) nil))))))))) | |
| 728 | |
| 729 ;;; Generate interactive functions for the show buffer from the corresponding | |
| 730 ;;; folder functions. | |
| 731 (mh-defun-show-buffer mh-show-previous-undeleted-msg | |
| 732 mh-previous-undeleted-msg) | |
| 733 (mh-defun-show-buffer mh-show-next-undeleted-msg | |
| 734 mh-next-undeleted-msg) | |
| 735 (mh-defun-show-buffer mh-show-quit mh-quit) | |
| 736 (mh-defun-show-buffer mh-show-delete-msg mh-delete-msg) | |
| 737 (mh-defun-show-buffer mh-show-refile-msg mh-refile-msg) | |
| 738 (mh-defun-show-buffer mh-show-undo mh-undo) | |
| 739 (mh-defun-show-buffer mh-show-execute-commands mh-execute-commands) | |
| 740 (mh-defun-show-buffer mh-show-reply mh-reply t) | |
| 741 (mh-defun-show-buffer mh-show-redistribute mh-redistribute) | |
| 742 (mh-defun-show-buffer mh-show-forward mh-forward t) | |
| 743 (mh-defun-show-buffer mh-show-header-display mh-header-display) | |
| 744 (mh-defun-show-buffer mh-show-refile-or-write-again | |
| 745 mh-refile-or-write-again) | |
| 746 (mh-defun-show-buffer mh-show-show mh-show) | |
| 747 (mh-defun-show-buffer mh-show-write-message-to-file | |
| 748 mh-write-msg-to-file) | |
| 749 (mh-defun-show-buffer mh-show-extract-rejected-mail | |
| 750 mh-extract-rejected-mail t) | |
| 751 (mh-defun-show-buffer mh-show-delete-msg-no-motion | |
| 752 mh-delete-msg-no-motion) | |
| 753 (mh-defun-show-buffer mh-show-first-msg mh-first-msg) | |
| 754 (mh-defun-show-buffer mh-show-last-msg mh-last-msg) | |
| 755 (mh-defun-show-buffer mh-show-copy-msg mh-copy-msg) | |
| 756 (mh-defun-show-buffer mh-show-edit-again mh-edit-again t) | |
| 757 (mh-defun-show-buffer mh-show-goto-msg mh-goto-msg) | |
| 758 (mh-defun-show-buffer mh-show-inc-folder mh-inc-folder) | |
| 759 (mh-defun-show-buffer mh-show-delete-subject-or-thread | |
| 760 mh-delete-subject-or-thread) | |
| 761 (mh-defun-show-buffer mh-show-delete-subject mh-delete-subject) | |
| 762 (mh-defun-show-buffer mh-show-print-msg mh-print-msg) | |
| 763 (mh-defun-show-buffer mh-show-send mh-send t) | |
| 764 (mh-defun-show-buffer mh-show-toggle-showing mh-toggle-showing t) | |
| 765 (mh-defun-show-buffer mh-show-pipe-msg mh-pipe-msg t) | |
| 766 (mh-defun-show-buffer mh-show-sort-folder mh-sort-folder) | |
| 767 (mh-defun-show-buffer mh-show-visit-folder mh-visit-folder t) | |
| 768 (mh-defun-show-buffer mh-show-rescan-folder mh-rescan-folder) | |
| 769 (mh-defun-show-buffer mh-show-pack-folder mh-pack-folder) | |
| 770 (mh-defun-show-buffer mh-show-kill-folder mh-kill-folder t) | |
| 771 (mh-defun-show-buffer mh-show-list-folders mh-list-folders t) | |
| 772 (mh-defun-show-buffer mh-show-search-folder mh-search-folder t) | |
| 773 (mh-defun-show-buffer mh-show-undo-folder mh-undo-folder) | |
| 774 (mh-defun-show-buffer mh-show-delete-msg-from-seq | |
| 775 mh-delete-msg-from-seq) | |
| 776 (mh-defun-show-buffer mh-show-delete-seq mh-delete-seq) | |
| 777 (mh-defun-show-buffer mh-show-list-sequences mh-list-sequences) | |
| 778 (mh-defun-show-buffer mh-show-narrow-to-seq mh-narrow-to-seq) | |
| 779 (mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq) | |
| 780 (mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq) | |
| 781 (mh-defun-show-buffer mh-show-widen mh-widen) | |
| 782 (mh-defun-show-buffer mh-show-narrow-to-subject | |
| 783 mh-narrow-to-subject) | |
| 784 (mh-defun-show-buffer mh-show-store-msg mh-store-msg) | |
| 785 (mh-defun-show-buffer mh-show-page-digest mh-page-digest) | |
| 786 (mh-defun-show-buffer mh-show-page-digest-backwards | |
| 787 mh-page-digest-backwards) | |
| 788 (mh-defun-show-buffer mh-show-burst-digest mh-burst-digest) | |
| 789 (mh-defun-show-buffer mh-show-page-msg mh-page-msg) | |
| 790 (mh-defun-show-buffer mh-show-previous-page mh-previous-page) | |
| 791 (mh-defun-show-buffer mh-show-modify mh-modify t) | |
| 792 (mh-defun-show-buffer mh-show-next-button mh-next-button) | |
| 793 (mh-defun-show-buffer mh-show-prev-button mh-prev-button) | |
| 794 (mh-defun-show-buffer mh-show-toggle-mime-part mh-folder-toggle-mime-part) | |
| 795 (mh-defun-show-buffer mh-show-save-mime-part mh-folder-save-mime-part) | |
| 796 (mh-defun-show-buffer mh-show-inline-mime-part mh-folder-inline-mime-part) | |
| 797 (mh-defun-show-buffer mh-show-toggle-threads mh-toggle-threads) | |
| 798 (mh-defun-show-buffer mh-show-thread-delete mh-thread-delete) | |
| 799 (mh-defun-show-buffer mh-show-thread-refile mh-thread-refile) | |
| 800 (mh-defun-show-buffer mh-show-update-sequences mh-update-sequences) | |
| 801 (mh-defun-show-buffer mh-show-next-unread-msg mh-next-unread-msg) | |
| 802 (mh-defun-show-buffer mh-show-previous-unread-msg mh-previous-unread-msg) | |
| 803 (mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor) | |
| 804 (mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling) | |
| 805 (mh-defun-show-buffer mh-show-thread-previous-sibling | |
| 806 mh-thread-previous-sibling) | |
| 807 (mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t) | |
| 808 | |
| 809 ;;; Populate mh-show-mode-map | |
| 810 (gnus-define-keys mh-show-mode-map | |
| 811 " " mh-show-page-msg | |
| 812 "!" mh-show-refile-or-write-again | |
| 813 "," mh-show-header-display | |
| 814 "." mh-show-show | |
| 815 ">" mh-show-write-message-to-file | |
| 816 "?" mh-help | |
| 817 "E" mh-show-extract-rejected-mail | |
| 818 "M" mh-show-modify | |
| 819 "\177" mh-show-previous-page | |
| 820 "\C-d" mh-show-delete-msg-no-motion | |
| 821 "\t" mh-show-next-button | |
| 822 [backtab] mh-show-prev-button | |
| 823 "\M-\t" mh-show-prev-button | |
| 824 "\ed" mh-show-redistribute | |
| 825 "^" mh-show-refile-msg | |
| 826 "c" mh-show-copy-msg | |
| 827 "d" mh-show-delete-msg | |
| 828 "e" mh-show-edit-again | |
| 829 "f" mh-show-forward | |
| 830 "g" mh-show-goto-msg | |
| 831 "i" mh-show-inc-folder | |
| 832 "k" mh-show-delete-subject-or-thread | |
| 833 "l" mh-show-print-msg | |
| 834 "m" mh-show-send | |
| 835 "n" mh-show-next-undeleted-msg | |
| 836 "\M-n" mh-show-next-unread-msg | |
| 837 "o" mh-show-refile-msg | |
| 838 "p" mh-show-previous-undeleted-msg | |
| 839 "\M-p" mh-show-previous-unread-msg | |
| 840 "q" mh-show-quit | |
| 841 "r" mh-show-reply | |
| 842 "s" mh-show-send | |
| 843 "t" mh-show-toggle-showing | |
| 844 "u" mh-show-undo | |
| 845 "x" mh-show-execute-commands | |
| 846 "v" mh-show-index-visit-folder | |
| 847 "|" mh-show-pipe-msg) | |
| 848 | |
| 849 (gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) | |
| 850 "?" mh-prefix-help | |
| 851 "S" mh-show-sort-folder | |
| 852 "f" mh-show-visit-folder | |
| 853 "i" mh-index-search | |
| 854 "k" mh-show-kill-folder | |
| 855 "l" mh-show-list-folders | |
| 856 "o" mh-show-visit-folder | |
| 857 "r" mh-show-rescan-folder | |
| 858 "s" mh-show-search-folder | |
| 859 "t" mh-show-toggle-threads | |
| 860 "u" mh-show-undo-folder | |
| 861 "v" mh-show-visit-folder) | |
| 862 | |
| 863 (gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map) | |
| 864 "?" mh-prefix-help | |
| 865 "d" mh-show-delete-msg-from-seq | |
| 866 "k" mh-show-delete-seq | |
| 867 "l" mh-show-list-sequences | |
| 868 "n" mh-show-narrow-to-seq | |
| 869 "p" mh-show-put-msg-in-seq | |
| 870 "s" mh-show-msg-is-in-seq | |
| 871 "w" mh-show-widen) | |
| 872 | |
| 873 (gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) | |
| 874 "?" mh-prefix-help | |
| 875 "u" mh-show-thread-ancestor | |
| 876 "p" mh-show-thread-previous-sibling | |
| 877 "n" mh-show-thread-next-sibling | |
| 878 "t" mh-show-toggle-threads | |
| 879 "d" mh-show-thread-delete | |
| 880 "o" mh-show-thread-refile) | |
| 881 | |
| 882 (gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) | |
| 883 "?" mh-prefix-help | |
| 884 "s" mh-show-narrow-to-subject | |
| 885 "w" mh-show-widen) | |
| 886 | |
| 887 (gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) | |
| 888 "?" mh-prefix-help | |
| 889 "s" mh-show-store-msg | |
| 890 "u" mh-show-store-msg) | |
| 891 | |
| 892 ;; Untested... | |
| 893 (gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map) | |
| 894 "?" mh-prefix-help | |
| 895 " " mh-show-page-digest | |
| 896 "\177" mh-show-page-digest-backwards | |
| 897 "b" mh-show-burst-digest) | |
| 898 | |
| 899 (gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) | |
| 900 "?" mh-prefix-help | |
| 901 "a" mh-mime-save-parts | |
| 902 "v" mh-show-toggle-mime-part | |
| 903 "o" mh-show-save-mime-part | |
| 904 "i" mh-show-inline-mime-part | |
| 905 "\t" mh-show-next-button | |
| 906 [backtab] mh-show-prev-button | |
| 907 "\M-\t" mh-show-prev-button) | |
| 908 | |
| 909 (easy-menu-define | |
| 910 mh-show-sequence-menu mh-show-mode-map "Menu for MH-E folder-sequence." | |
| 911 '("Sequence" | |
| 912 ["Add Message to Sequence..." mh-show-put-msg-in-seq t] | |
| 913 ["List Sequences for Message" mh-show-msg-is-in-seq t] | |
| 914 ["Delete Message from Sequence..." mh-show-delete-msg-from-seq t] | |
| 915 ["List Sequences in Folder..." mh-show-list-sequences t] | |
| 916 ["Delete Sequence..." mh-show-delete-seq t] | |
| 917 ["Narrow to Sequence..." mh-show-narrow-to-seq t] | |
| 918 ["Widen from Sequence" mh-show-widen t] | |
| 919 "--" | |
| 920 ["Narrow to Subject Sequence" mh-show-narrow-to-subject t] | |
| 921 ["Delete Rest of Same Subject" mh-show-delete-subject t] | |
| 922 "--" | |
| 923 ["Push State Out to MH" mh-show-update-sequences t])) | |
| 924 | |
| 925 (easy-menu-define | |
| 926 mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message." | |
| 927 '("Message" | |
| 928 ["Show Message" mh-show-show t] | |
| 929 ["Show Message with Header" mh-show-header-display t] | |
| 930 ["Next Message" mh-show-next-undeleted-msg t] | |
| 931 ["Previous Message" mh-show-previous-undeleted-msg t] | |
| 932 ["Go to First Message" mh-show-first-msg t] | |
| 933 ["Go to Last Message" mh-show-last-msg t] | |
| 934 ["Go to Message by Number..." mh-show-goto-msg t] | |
| 935 ["Modify Message" mh-show-modify t] | |
| 936 ["Delete Message" mh-show-delete-msg t] | |
| 937 ["Refile Message" mh-show-refile-msg t] | |
| 938 ["Undo Delete/Refile" mh-show-undo t] | |
| 939 ["Process Delete/Refile" mh-show-execute-commands t] | |
| 940 "--" | |
| 941 ["Compose a New Message" mh-send t] | |
| 942 ["Reply to Message..." mh-show-reply t] | |
| 943 ["Forward Message..." mh-show-forward t] | |
| 944 ["Redistribute Message..." mh-show-redistribute t] | |
| 945 ["Edit Message Again" mh-show-edit-again t] | |
| 946 ["Re-edit a Bounced Message" mh-show-extract-rejected-mail t] | |
| 947 "--" | |
| 948 ["Copy Message to Folder..." mh-show-copy-msg t] | |
| 949 ["Print Message" mh-show-print-msg t] | |
| 950 ["Write Message to File..." mh-show-write-msg-to-file t] | |
| 951 ["Pipe Message to Command..." mh-show-pipe-msg t] | |
| 952 ["Unpack Uuencoded Message..." mh-show-store-msg t] | |
| 953 ["Burst Digest Message" mh-show-burst-digest t])) | |
| 954 | |
| 955 (easy-menu-define | |
| 956 mh-show-folder-menu mh-show-mode-map "Menu for MH-E folder." | |
| 957 '("Folder" | |
| 958 ["Incorporate New Mail" mh-show-inc-folder t] | |
| 959 ["Toggle Show/Folder" mh-show-toggle-showing t] | |
| 960 ["Execute Delete/Refile" mh-show-execute-commands t] | |
| 961 ["Rescan Folder" mh-show-rescan-folder t] | |
| 962 ["Thread Folder" mh-show-toggle-threads t] | |
| 963 ["Pack Folder" mh-show-pack-folder t] | |
| 964 ["Sort Folder" mh-show-sort-folder t] | |
| 965 "--" | |
| 966 ["List Folders" mh-show-list-folders t] | |
| 967 ["Visit a Folder..." mh-show-visit-folder t] | |
| 968 ["Search a Folder..." mh-show-search-folder t] | |
| 969 ["Indexed Search..." mh-index-search t] | |
| 970 "--" | |
| 971 ["Quit MH-E" mh-quit t])) | |
| 972 | |
| 973 | |
| 974 ;;; Ensure new buffers won't get this mode if default-major-mode is nil. | |
| 975 (put 'mh-show-mode 'mode-class 'special) | |
| 976 | |
| 977 (define-derived-mode mh-show-mode text-mode "MH-Show" | |
| 978 "Major mode for showing messages in MH-E.\\<mh-show-mode-map> | |
| 979 The value of `mh-show-mode-hook' is a list of functions to | |
| 980 be called, with no arguments, upon entry to this mode." | |
| 981 (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) | |
| 982 (setq paragraph-start (default-value 'paragraph-start)) | |
| 983 (mh-show-unquote-From) | |
| 984 (mh-show-xface) | |
| 985 (mh-show-addr) | |
| 986 (make-local-variable 'font-lock-defaults) | |
| 987 ;;(set (make-local-variable 'font-lock-support-mode) nil) | |
| 988 (cond | |
| 989 ((equal mh-highlight-citation-p 'font-lock) | |
| 990 (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) | |
| 991 ((equal mh-highlight-citation-p 'gnus) | |
| 992 (setq font-lock-defaults '((mh-show-font-lock-keywords) | |
| 993 t nil nil nil | |
| 994 (font-lock-fontify-region-function | |
| 995 . mh-show-font-lock-fontify-region))) | |
| 996 (mh-gnus-article-highlight-citation)) | |
| 997 (t | |
| 998 (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) | |
| 999 (if (and mh-xemacs-flag | |
| 1000 font-lock-auto-fontify) | |
| 1001 (turn-on-font-lock)) | |
| 1002 (if (and (boundp 'tool-bar-mode) tool-bar-mode) | |
| 1003 (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)) | |
| 1004 (when mh-decode-mime-flag | |
| 1005 (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t)) | |
| 1006 (easy-menu-add mh-show-sequence-menu) | |
| 1007 (easy-menu-add mh-show-message-menu) | |
| 1008 (easy-menu-add mh-show-folder-menu) | |
| 1009 (make-local-variable 'mh-show-folder-buffer) | |
| 1010 (buffer-disable-undo) | |
| 1011 (setq buffer-read-only t) | |
| 1012 (use-local-map mh-show-mode-map) | |
| 1013 (run-hooks 'mh-show-mode-hook)) | |
| 1014 | |
| 1015 (defun mh-show-addr () | |
| 1016 "Use `goto-address'." | |
| 1017 (when mh-show-use-goto-addr-flag | |
| 1018 (if (not (featurep 'goto-addr)) | |
| 1019 (load "goto-addr" t t)) | |
| 1020 (if (fboundp 'goto-address) | |
| 1021 (goto-address)))) | |
| 1022 | |
| 1023 (defvar mh-show-xface-function | |
| 1024 (cond ((and mh-xemacs-flag (locate-library "x-face")) | |
| 1025 (load "x-face" t t) | |
| 1026 (if (fboundp 'x-face-xmas-wl-display-x-face) | |
| 1027 #'x-face-xmas-wl-display-x-face | |
| 1028 #'ignore)) | |
| 1029 ((and (not mh-xemacs-flag) (>= emacs-major-version 21)) | |
| 1030 (load "x-face-e21" t t) | |
| 1031 (if (fboundp 'x-face-decode-message-header) | |
| 1032 #'x-face-decode-message-header | |
| 1033 #'ignore)) | |
| 1034 (t #'ignore)) | |
| 1035 "Determine at run time what function should be called to display X-Face.") | |
| 1036 | |
| 1037 (defun mh-show-xface () | |
| 1038 "Display X-Face." | |
| 1039 (when (and mh-show-use-xface-flag | |
| 1040 (or mh-decode-mime-flag mhl-formfile | |
| 1041 mh-clean-message-header-flag)) | |
| 1042 (funcall mh-show-xface-function))) | |
| 1043 | |
| 1044 (defun mh-maybe-show (&optional msg) | |
| 1045 "Display message at cursor, but only if in show mode. | |
| 1046 If optional arg MSG is non-nil, display that message instead." | |
| 1047 (if mh-showing-mode (mh-show msg))) | |
| 1048 | |
| 1049 (defun mh-show (&optional message) | |
| 1050 "Show message at cursor. | |
| 1051 If optional argument MESSAGE is non-nil, display that message instead. | |
| 1052 Force a two-window display with the folder window on top (size | |
| 1053 `mh-summary-height') and the show buffer below it. | |
| 1054 If the message is already visible, display the start of the message. | |
| 1055 | |
| 1056 Display of the message is controlled by setting the variables | |
| 1057 `mh-clean-message-header-flag' and `mhl-formfile'. The default behavior is | |
| 1058 to scroll uninteresting headers off the top of the window. | |
| 1059 Type \"\\[mh-header-display]\" to see the message with all its headers." | |
| 1060 (interactive) | |
| 1061 (and mh-showing-with-headers | |
| 1062 (or mhl-formfile mh-clean-message-header-flag) | |
| 1063 (mh-invalidate-show-buffer)) | |
| 1064 (mh-show-msg message)) | |
| 1065 | |
| 1066 (defun mh-show-mouse (EVENT) | |
| 1067 "Move point to mouse EVENT and show message." | |
| 1068 (interactive "e") | |
| 1069 (mouse-set-point EVENT) | |
| 1070 (mh-show)) | |
| 1071 | |
| 1072 (defun mh-show-msg (msg) | |
| 1073 "Show MSG. | |
| 1074 The value of `mh-show-hook' is a list of functions to be called, with no | |
| 1075 arguments, after the message has been displayed." | |
| 1076 (if (not msg) | |
| 1077 (setq msg (mh-get-msg-num t))) | |
| 1078 (mh-showing-mode t) | |
| 1079 (setq mh-page-to-next-msg-flag nil) | |
| 1080 (let ((folder mh-current-folder) | |
| 1081 (clean-message-header mh-clean-message-header-flag) | |
| 1082 (show-window (get-buffer-window mh-show-buffer))) | |
| 1083 (if (not (eq (next-window (minibuffer-window)) (selected-window))) | |
| 1084 (delete-other-windows)) ; force ourself to the top window | |
| 1085 (mh-in-show-buffer (mh-show-buffer) | |
| 1086 (if (and show-window | |
| 1087 (equal (mh-msg-filename msg folder) buffer-file-name)) | |
| 1088 (progn ;just back up to start | |
| 1089 (goto-char (point-min)) | |
| 1090 (if (not clean-message-header) | |
| 1091 (mh-start-of-uncleaned-message))) | |
| 1092 (mh-display-msg msg folder)))) | |
| 1093 (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split | |
| 1094 (shrink-window (- (window-height) mh-summary-height))) | |
| 1095 (mh-recenter nil) | |
| 1096 (if (not (memq msg mh-seen-list)) | |
| 1097 (setq mh-seen-list (cons msg mh-seen-list))) | |
| 1098 (when mh-update-sequences-after-mh-show-flag | |
| 1099 (mh-update-sequences)) | |
| 1100 (run-hooks 'mh-show-hook)) | |
| 1101 | |
| 1102 (defun mh-modify (&optional message) | |
| 1103 "Edit message at cursor. | |
| 1104 If optional argument MESSAGE is non-nil, edit that message instead. | |
| 1105 Force a two-window display with the folder window on top (size | |
| 1106 `mh-summary-height') and the message editing buffer below it. | |
| 1107 | |
| 1108 The message is displayed in raw form." | |
| 1109 (interactive) | |
| 1110 (let* ((message (or message (mh-get-msg-num t))) | |
| 1111 (msg-filename (mh-msg-filename message)) | |
| 1112 edit-buffer) | |
| 1113 (when (not (file-exists-p msg-filename)) | |
| 1114 (error "Message %d does not exist" message)) | |
| 1115 | |
| 1116 ;; Invalidate the show buffer if it is showing the same message that is | |
| 1117 ;; to be edited. | |
| 1118 (when (and (buffer-live-p (get-buffer mh-show-buffer)) | |
| 1119 (equal (save-excursion (set-buffer mh-show-buffer) | |
| 1120 buffer-file-name) | |
| 1121 msg-filename)) | |
| 1122 (mh-invalidate-show-buffer)) | |
| 1123 | |
| 1124 ;; Edit message | |
| 1125 (find-file msg-filename) | |
| 1126 (setq edit-buffer (current-buffer)) | |
| 1127 | |
| 1128 ;; Set buffer properties | |
| 1129 (mh-letter-mode) | |
| 1130 (use-local-map text-mode-map) | |
| 1131 | |
| 1132 ;; Just show the edit buffer... | |
| 1133 (delete-other-windows) | |
| 1134 (switch-to-buffer edit-buffer))) | |
| 1135 | |
| 1136 (defun mh-decode-quoted-printable () | |
| 1137 "Run mimedecode on current buffer, replacing its contents." | |
| 1138 (let ((case-fold-search t)) | |
| 1139 (goto-char (point-min)) | |
| 1140 (when (and (re-search-forward | |
| 1141 "^content-transfer-encoding:[ \t]*quoted-printable" | |
| 1142 (if mh-decode-mime-flag (mail-header-end) nil) t) | |
| 1143 (search-forward "\n\n" nil t)) | |
| 1144 (message "Converting quoted-printable characters...") | |
| 1145 (let ((modified (buffer-modified-p)) | |
| 1146 (command "mimedecode")) | |
| 1147 (shell-command-on-region (point-min) (point-max) command t t) | |
| 1148 (if (fboundp 'deactivate-mark) | |
| 1149 (deactivate-mark)) | |
| 1150 (set-buffer-modified-p modified)) | |
| 1151 (message "Converting quoted-printable characters... done.")))) | |
| 1152 | |
| 1153 (defun mh-show-unquote-From () | |
| 1154 "Decode >From at beginning of lines for `mh-show-mode'." | |
| 1155 (save-excursion | |
| 1156 (let ((modified (buffer-modified-p)) | |
| 1157 (case-fold-search nil)) | |
| 1158 (goto-char (mail-header-end)) | |
| 1159 (while (re-search-forward "^>From" nil t) | |
| 1160 (replace-match "From")) | |
| 1161 (set-buffer-modified-p modified)))) | |
| 1162 | |
| 1163 (defun mh-msg-folder (folder-name) | |
| 1164 "Return the name of the buffer for FOLDER-NAME." | |
| 1165 folder-name) | |
| 1166 | |
| 1167 (defun mh-display-msg (msg-num folder-name) | |
| 1168 "Display MSG-NUM of FOLDER-NAME. | |
| 1169 Sets the current buffer to the show buffer." | |
| 1170 (let ((folder (mh-msg-folder folder-name))) | |
| 1171 (set-buffer folder) | |
| 1172 ;; When Gnus uses external displayers it has to keep handles longer. So | |
| 1173 ;; we will delete these handles when mh-quit is called on the folder. It | |
| 1174 ;; would be nicer if there are weak pointers in emacs lisp, then we could | |
| 1175 ;; get the garbage collector to do this for us. | |
| 1176 (unless (mh-buffer-data) | |
| 1177 (setf (mh-buffer-data) (mh-make-buffer-data))) | |
| 1178 ;; Bind variables in folder buffer in case they are local | |
| 1179 (let ((formfile mhl-formfile) | |
| 1180 (clean-message-header mh-clean-message-header-flag) | |
| 1181 (invisible-headers mh-invisible-headers) | |
| 1182 (visible-headers mh-visible-headers) | |
| 1183 (msg-filename (mh-msg-filename msg-num folder-name)) | |
| 1184 (show-buffer mh-show-buffer) | |
| 1185 (mm-inline-media-tests mh-mm-inline-media-tests)) | |
| 1186 (if (not (file-exists-p msg-filename)) | |
| 1187 (error "Message %d does not exist" msg-num)) | |
| 1188 (if (and (> mh-show-maximum-size 0) | |
| 1189 (> (elt (file-attributes msg-filename) 7) | |
| 1190 mh-show-maximum-size) | |
| 1191 (not (y-or-n-p | |
| 1192 (format | |
| 1193 "Message %d (%d bytes) exceeds %d bytes. Display it? " | |
| 1194 msg-num (elt (file-attributes msg-filename) 7) | |
| 1195 mh-show-maximum-size)))) | |
| 1196 (error "Message %d not displayed" msg-num)) | |
| 1197 (set-buffer show-buffer) | |
| 1198 (cond ((not (equal msg-filename buffer-file-name)) | |
| 1199 (mh-unvisit-file) | |
| 1200 (setq buffer-read-only nil) | |
| 1201 (erase-buffer) | |
| 1202 ;; Changing contents, so this hook needs to be reinitialized. | |
| 1203 ;; pgp.el uses this. | |
| 1204 (if (boundp 'write-contents-hooks) ;Emacs 19 | |
| 1205 (kill-local-variable 'write-contents-hooks)) | |
| 1206 (if formfile | |
| 1207 (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" | |
| 1208 (if (stringp formfile) | |
| 1209 (list "-form" formfile)) | |
| 1210 msg-filename) | |
| 1211 (insert-file-contents msg-filename)) | |
| 1212 (if mh-decode-quoted-printable-flag | |
| 1213 (mh-decode-quoted-printable)) | |
| 1214 ;; Cleanup old mime handles | |
| 1215 (mh-mime-cleanup) | |
| 1216 ;; Use mm to display buffer | |
| 1217 (when (and mh-decode-mime-flag (not formfile)) | |
| 1218 (mh-add-missing-mime-version-header) | |
| 1219 (setf (mh-buffer-data) (mh-make-buffer-data)) | |
| 1220 (mh-mime-display)) | |
| 1221 ;; Header cleanup | |
| 1222 (goto-char (point-min)) | |
| 1223 (cond (clean-message-header | |
| 1224 (mh-clean-msg-header (point-min) | |
| 1225 invisible-headers | |
| 1226 visible-headers) | |
| 1227 (goto-char (point-min))) | |
| 1228 (t | |
| 1229 (mh-start-of-uncleaned-message))) | |
| 1230 ;; the parts of visiting we want to do (no locking) | |
| 1231 (or (eq buffer-undo-list t) ;don't save undo info for prev msgs | |
| 1232 (setq buffer-undo-list nil)) | |
| 1233 (set-buffer-auto-saved) | |
| 1234 ;; the parts of set-visited-file-name we want to do (no locking) | |
| 1235 (setq buffer-file-name msg-filename) | |
| 1236 (setq buffer-backed-up nil) | |
| 1237 (auto-save-mode 1) | |
| 1238 (set-mark nil) | |
| 1239 (mh-show-mode) | |
| 1240 (unwind-protect | |
| 1241 (when (and mh-decode-mime-flag (not formfile)) | |
| 1242 (setq buffer-read-only nil) | |
| 1243 (mh-display-smileys) | |
| 1244 (mh-display-emphasis)) | |
| 1245 (setq buffer-read-only t)) | |
| 1246 (set-buffer-modified-p nil) | |
| 1247 (setq mh-show-folder-buffer folder) | |
| 1248 (setq mode-line-buffer-identification | |
| 1249 (list (format mh-show-buffer-mode-line-buffer-id | |
| 1250 folder-name msg-num))) | |
| 1251 (set-buffer folder) | |
| 1252 (setq mh-showing-with-headers nil)))))) | |
| 1253 | |
| 1254 (defun mh-clean-msg-header (start invisible-headers visible-headers) | |
| 1255 "Flush extraneous lines in message header. | |
| 1256 Header is cleaned from START to the end of the message header. | |
| 1257 INVISIBLE-HEADERS contains a regular expression specifying lines to delete | |
| 1258 from the header. VISIBLE-HEADERS contains a regular expression specifying the | |
| 1259 lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil." | |
| 1260 (let ((case-fold-search t) | |
| 1261 (after-change-functions nil)) ;Work around emacs-20 font-lock bug | |
| 1262 ;causing an endless loop. | |
| 1263 (save-restriction | |
| 1264 (goto-char start) | |
| 1265 (if (search-forward "\n\n" nil 'move) | |
| 1266 (backward-char 1)) | |
| 1267 (narrow-to-region start (point)) | |
| 1268 (goto-char (point-min)) | |
| 1269 (if visible-headers | |
| 1270 (while (< (point) (point-max)) | |
| 1271 (cond ((looking-at visible-headers) | |
| 1272 (forward-line 1) | |
| 1273 (while (looking-at "[ \t]") (forward-line 1))) | |
| 1274 (t | |
| 1275 (mh-delete-line 1) | |
| 1276 (while (looking-at "[ \t]") | |
| 1277 (mh-delete-line 1))))) | |
| 1278 (while (re-search-forward invisible-headers nil t) | |
| 1279 (beginning-of-line) | |
| 1280 (mh-delete-line 1) | |
| 1281 (while (looking-at "[ \t]") | |
| 1282 (mh-delete-line 1)))) | |
| 1283 (unlock-buffer)))) | |
| 1284 | |
| 1285 (defun mh-delete-line (lines) | |
| 1286 "Delete the next LINES lines." | |
| 1287 (delete-region (point) (progn (forward-line lines) (point)))) | |
| 1288 | |
| 1289 (defun mh-notate (msg notation offset) | |
| 1290 "Mark MSG with the character NOTATION at position OFFSET. | |
| 1291 Null MSG means the message at cursor." | |
| 1292 (save-excursion | |
| 1293 (if (or (null msg) | |
| 1294 (mh-goto-msg msg t t)) | |
| 1295 (with-mh-folder-updating (t) | |
| 1296 (beginning-of-line) | |
| 1297 (forward-char offset) | |
| 1298 (delete-char 1) | |
| 1299 (insert notation))))) | |
| 1300 | |
| 1301 (defun mh-find-msg-get-num (step) | |
| 1302 "Return the message number of the message nearest the cursor. | |
| 1303 Jumps over non-message lines, such as inc errors. | |
| 1304 If we have to search, STEP tells whether to search forward or backward." | |
| 1305 (or (mh-get-msg-num nil) | |
| 1306 (let ((msg-num nil) | |
| 1307 (nreverses 0)) | |
| 1308 (while (and (not msg-num) | |
| 1309 (< nreverses 2)) | |
| 1310 (cond ((eobp) | |
| 1311 (setq step -1) | |
| 1312 (setq nreverses (1+ nreverses))) | |
| 1313 ((bobp) | |
| 1314 (setq step 1) | |
| 1315 (setq nreverses (1+ nreverses)))) | |
| 1316 (forward-line step) | |
| 1317 (setq msg-num (mh-get-msg-num nil))) | |
| 1318 msg-num))) | |
| 1319 | |
| 1320 (defun mh-goto-msg (number &optional no-error-if-no-message dont-show) | |
| 1321 "Position the cursor at message NUMBER. | |
| 1322 Optional non-nil second argument NO-ERROR-IF-NO-MESSAGE means return nil | |
| 1323 instead of signaling an error if message does not exist; in this case, the | |
| 1324 cursor is positioned near where the message would have been. | |
| 1325 Non-nil third argument DONT-SHOW means not to show the message." | |
| 1326 (interactive "NGo to message: ") | |
| 1327 (setq number (prefix-numeric-value number)) | |
| 1328 (let ((point (point)) | |
| 1329 (return-value t)) | |
| 1330 (goto-char (point-min)) | |
| 1331 (unless (re-search-forward (format "^[ ]*%s[^0-9]+" number) nil t) | |
| 1332 (goto-char point) | |
| 1333 (unless no-error-if-no-message | |
| 1334 (error "No message %d" number)) | |
| 1335 (setq return-value nil)) | |
| 1336 (beginning-of-line) | |
| 1337 (or dont-show (not return-value) (mh-maybe-show number)) | |
| 1338 return-value)) | |
| 1339 | |
| 1340 (defun mh-msg-search-pat (n) | |
| 1341 "Return a search pattern for message N in the scan listing." | |
| 1342 (format mh-scan-msg-search-regexp n)) | |
| 1343 | |
| 1344 (defun mh-get-profile-field (field) | |
| 1345 "Find and return the value of FIELD in the current buffer. | |
| 1346 Returns nil if the field is not in the buffer." | |
| 1347 (let ((case-fold-search t)) | |
| 1348 (goto-char (point-min)) | |
| 1349 (cond ((not (re-search-forward (format "^%s" field) nil t)) nil) | |
| 1350 ((looking-at "[\t ]*$") nil) | |
| 1351 (t | |
| 1352 (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t) | |
| 1353 (let ((start (match-beginning 1))) | |
| 1354 (end-of-line) | |
| 1355 (buffer-substring start (point))))))) | |
| 1356 | |
| 1357 (defvar mail-user-agent) | |
| 1358 (defvar read-mail-command) | |
| 1359 | |
| 1360 (defvar mh-find-path-run nil | |
| 1361 "Non-nil if `mh-find-path' has been run already.") | |
| 1362 | |
| 1363 (defun mh-find-path () | |
| 1364 "Set `mh-progs', `mh-lib', and `mh-lib-progs' variables. | |
| 1365 Set `mh-user-path', `mh-draft-folder', `mh-unseen-seq', `mh-previous-seq', | |
| 1366 `mh-inbox' from user's MH profile. | |
| 1367 The value of `mh-find-path-hook' is a list of functions to be called, with no | |
| 1368 arguments, after these variable have been set." | |
| 1369 (mh-find-progs) | |
| 1370 (unless mh-find-path-run | |
| 1371 (setq mh-find-path-run t) | |
| 1372 (setq read-mail-command 'mh-rmail) | |
| 1373 (setq mail-user-agent 'mh-e-user-agent)) | |
| 1374 (save-excursion | |
| 1375 ;; Be sure profile is fully expanded before switching buffers | |
| 1376 (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile")))) | |
| 1377 (set-buffer (get-buffer-create mh-temp-buffer)) | |
| 1378 (setq buffer-offer-save nil) ;for people who set default to t | |
| 1379 (erase-buffer) | |
| 1380 (condition-case err | |
| 1381 (insert-file-contents profile) | |
| 1382 (file-error | |
| 1383 (mh-install profile err))) | |
| 1384 (setq mh-user-path (mh-get-profile-field "Path:")) | |
| 1385 (if (not mh-user-path) | |
| 1386 (setq mh-user-path "Mail")) | |
| 1387 (setq mh-user-path | |
| 1388 (file-name-as-directory | |
| 1389 (expand-file-name mh-user-path (expand-file-name "~")))) | |
| 1390 (setq mh-draft-folder (mh-get-profile-field "Draft-Folder:")) | |
| 1391 (if mh-draft-folder | |
| 1392 (progn | |
| 1393 (if (not (mh-folder-name-p mh-draft-folder)) | |
| 1394 (setq mh-draft-folder (format "+%s" mh-draft-folder))) | |
| 1395 (if (not (file-exists-p (mh-expand-file-name mh-draft-folder))) | |
| 1396 (error "Draft folder \"%s\" not found. Create it and try again" | |
| 1397 (mh-expand-file-name mh-draft-folder))))) | |
| 1398 (setq mh-inbox (mh-get-profile-field "Inbox:")) | |
| 1399 (cond ((not mh-inbox) | |
| 1400 (setq mh-inbox "+inbox")) | |
| 1401 ((not (mh-folder-name-p mh-inbox)) | |
| 1402 (setq mh-inbox (format "+%s" mh-inbox)))) | |
| 1403 (setq mh-unseen-seq (mh-get-profile-field "Unseen-Sequence:")) | |
| 1404 (if mh-unseen-seq | |
| 1405 (setq mh-unseen-seq (intern mh-unseen-seq)) | |
| 1406 (setq mh-unseen-seq 'unseen)) ;old MH default? | |
| 1407 (setq mh-previous-seq (mh-get-profile-field "Previous-Sequence:")) | |
| 1408 (if mh-previous-seq | |
| 1409 (setq mh-previous-seq (intern mh-previous-seq))) | |
| 1410 (run-hooks 'mh-find-path-hook))) | |
| 1411 (and mh-auto-folder-collect-flag | |
| 1412 (let ((mh-no-install t)) ;only get folders if MH installed | |
| 1413 (condition-case err | |
| 1414 (mh-make-folder-list-background) | |
| 1415 (file-error))))) ;so don't complain if not installed | |
| 1416 | |
| 1417 (defun mh-file-command-p (file) | |
| 1418 "Return t if file FILE is the name of a executable regular file." | |
| 1419 (and (file-regular-p file) (file-executable-p file))) | |
| 1420 | |
| 1421 (defun mh-find-progs () | |
| 1422 "Find the directories for the installed MH/nmh binaries and config files. | |
| 1423 Set the `mh-progs' and `mh-lib', and `mh-lib-progs' variables to the | |
| 1424 directory names and set `mh-nmh-flag' if we detect nmh instead of MH." | |
| 1425 (unless (and mh-progs mh-lib mh-lib-progs) | |
| 1426 (let ((path (or (mh-path-search exec-path "mhparam") | |
| 1427 (mh-path-search '("/usr/local/nmh/bin" ; nmh default | |
| 1428 "/usr/local/bin/mh/" | |
| 1429 "/usr/local/mh/" | |
| 1430 "/usr/bin/mh/" ;Ultrix 4.2, Linux | |
| 1431 "/usr/new/mh/" ;Ultrix <4.2 | |
| 1432 "/usr/contrib/mh/bin/" ;BSDI | |
| 1433 "/usr/pkg/bin/" ; NetBSD | |
| 1434 "/usr/local/bin/" | |
| 1435 ) | |
| 1436 "mhparam")))) | |
| 1437 (if (not path) | |
| 1438 (error "Unable to find the `mhparam' command")) | |
| 1439 (save-excursion | |
| 1440 (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) | |
| 1441 (set-buffer tmp-buffer) | |
| 1442 (unwind-protect | |
| 1443 (progn | |
| 1444 (call-process (expand-file-name "mhparam" path) | |
| 1445 nil '(t nil) nil "libdir" "etcdir") | |
| 1446 (goto-char (point-min)) | |
| 1447 (if (search-forward-regexp "^libdir:\\s-\\(\\S-+\\)\\s-*$" | |
| 1448 nil t) | |
| 1449 (setq mh-lib-progs (match-string 1) | |
| 1450 mh-lib mh-lib-progs | |
| 1451 mh-progs path)) | |
| 1452 (goto-char (point-min)) | |
| 1453 (if (search-forward-regexp "^etcdir:\\s-\\(\\S-+\\)\\s-*$" | |
| 1454 nil t) | |
| 1455 (setq mh-lib (match-string 1) | |
| 1456 mh-nmh-flag t))) | |
| 1457 (kill-buffer tmp-buffer)))) | |
| 1458 (unless (and mh-progs mh-lib mh-lib-progs) | |
| 1459 (error "Unable to determine paths from `mhparam' command"))))) | |
| 1460 | |
| 1461 (defun mh-path-search (path file) | |
| 1462 "Search PATH, a list of directory names, for FILE. | |
| 1463 Returns the element of PATH that contains FILE, or nil if not found." | |
| 1464 (while (and path | |
| 1465 (not (funcall 'mh-file-command-p | |
| 1466 (expand-file-name file (car path))))) | |
| 1467 (setq path (cdr path))) | |
| 1468 (car path)) | |
| 1469 | |
| 1470 (defvar mh-no-install nil) ;do not run install-mh | |
| 1471 | |
| 1472 (defun mh-install (profile error-val) | |
| 1473 "Initialize the MH environment. | |
| 1474 This is called if we fail to read the PROFILE file. ERROR-VAL is the error | |
| 1475 that made this call necessary." | |
| 1476 (if (or (getenv "MH") | |
| 1477 (file-exists-p profile) | |
| 1478 mh-no-install) | |
| 1479 (signal (car error-val) | |
| 1480 (list (format "Cannot read MH profile \"%s\"" profile) | |
| 1481 (car (cdr (cdr error-val)))))) | |
| 1482 ;; The "install-mh" command will output a short note which | |
| 1483 ;; mh-exec-cmd will display to the user. | |
| 1484 ;; The MH 5 version of install-mh might try prompt the user | |
| 1485 ;; for information, which would fail here. | |
| 1486 (mh-exec-cmd (expand-file-name "install-mh" mh-lib-progs) "-auto") | |
| 1487 ;; now try again to read the profile file | |
| 1488 (erase-buffer) | |
| 1489 (condition-case err | |
| 1490 (insert-file-contents profile) | |
| 1491 (file-error | |
| 1492 (signal (car err) ;re-signal with more specific msg | |
| 1493 (list (format "Cannot read MH profile \"%s\"" profile) | |
| 1494 (car (cdr (cdr err)))))))) | |
| 1495 | |
| 1496 (defun mh-set-folder-modified-p (flag) | |
| 1497 "Mark current folder as modified or unmodified according to FLAG." | |
| 1498 (set-buffer-modified-p flag)) | |
| 1499 | |
| 1500 (defun mh-find-seq (name) | |
| 1501 "Return sequence NAME." | |
| 1502 (assoc name mh-seq-list)) | |
| 1503 | |
| 1504 (defun mh-seq-to-msgs (seq) | |
| 1505 "Return a list of the messages in SEQ." | |
| 1506 (mh-seq-msgs (mh-find-seq seq))) | |
| 1507 | |
| 1508 (defun mh-update-scan-format (fmt width) | |
| 1509 "Return a scan format with the (msg) width in the FMT replaced with WIDTH. | |
| 1510 | |
| 1511 The message number width portion of the format is discovered using | |
| 1512 `mh-scan-msg-format-regexp'. Its replacement is controlled with | |
| 1513 `mh-scan-msg-format-string'." | |
| 1514 (or (and | |
| 1515 (string-match mh-scan-msg-format-regexp fmt) | |
| 1516 (let ((begin (match-beginning 1)) | |
| 1517 (end (match-end 1))) | |
| 1518 (concat (substring fmt 0 begin) | |
| 1519 (format mh-scan-msg-format-string width) | |
| 1520 (substring fmt end)))) | |
| 1521 fmt)) | |
| 1522 | |
| 1523 (defun mh-message-number-width (folder) | |
| 1524 "Return the widest message number in this FOLDER." | |
| 1525 (or mh-progs (mh-find-path)) | |
| 1526 (let ((tmp-buffer (get-buffer-create mh-temp-buffer)) | |
| 1527 (width 0)) | |
| 1528 (save-excursion | |
| 1529 (set-buffer tmp-buffer) | |
| 1530 (erase-buffer) | |
| 1531 (apply 'call-process | |
| 1532 (expand-file-name "scan" mh-progs) nil '(t nil) nil | |
| 1533 (list folder "last" "-format" "%(msg)")) | |
| 1534 (goto-char (point-min)) | |
| 1535 (if (re-search-forward mh-scan-msg-number-regexp nil 0 1) | |
| 1536 (setq width (length (buffer-substring | |
| 1537 (match-beginning 1) (match-end 1)))))) | |
| 1538 width)) | |
| 1539 | |
| 1540 (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) | |
| 1541 "Add MSGS to SEQ. | |
| 1542 Remove duplicates and keep sequence sorted. If optional INTERNAL-FLAG is | |
| 1543 non-nil, do not mark the message in the scan listing or inform MH of the | |
| 1544 addition." | |
| 1545 (let ((entry (mh-find-seq seq))) | |
| 1546 (if (and msgs (atom msgs)) (setq msgs (list msgs))) | |
| 1547 (if (null entry) | |
| 1548 (setq mh-seq-list | |
| 1549 (cons (mh-make-seq seq (mh-canonicalize-sequence msgs)) | |
| 1550 mh-seq-list)) | |
| 1551 (if msgs (setcdr entry (mh-canonicalize-sequence | |
| 1552 (append msgs (mh-seq-msgs entry)))))) | |
| 1553 (cond ((not internal-flag) | |
| 1554 (mh-add-to-sequence seq msgs) | |
| 1555 (mh-notate-seq seq mh-note-seq (1+ mh-cmd-note)))))) | |
| 1556 | |
| 1557 (defun mh-canonicalize-sequence (msgs) | |
| 1558 "Sort MSGS in decreasing order and remove duplicates." | |
| 1559 (let* ((sorted-msgs (sort (copy-sequence msgs) '>)) | |
| 1560 (head sorted-msgs)) | |
| 1561 (while (cdr head) | |
| 1562 (if (= (car head) (cadr head)) | |
| 1563 (setcdr head (cddr head)) | |
| 1564 (setq head (cdr head)))) | |
| 1565 sorted-msgs)) | |
| 1566 | |
| 1567 (defvar mh-folder-hist nil) | |
| 1568 (defvar mh-speed-folder-map) | |
| 1569 | |
| 1570 (defun mh-prompt-for-folder (prompt default can-create | |
| 1571 &optional default-string) | |
| 1572 "Prompt for a folder name with PROMPT. | |
| 1573 Returns the folder's name as a string. DEFAULT is used if the folder exists | |
| 1574 and the user types return. If the CAN-CREATE flag is t, then a folder is | |
| 1575 created if it doesn't already exist. If optional argument DEFAULT-STRING is | |
| 1576 non-nil, use it in the prompt instead of DEFAULT. | |
| 1577 The value of `mh-folder-list-change-hook' is a list of functions to be called, | |
| 1578 with no arguments, whenever the cached folder list `mh-folder-list' is | |
| 1579 changed." | |
| 1580 (if (null default) | |
| 1581 (setq default "")) | |
| 1582 (let* ((default-string (cond (default-string (format " [%s]? " | |
| 1583 default-string)) | |
| 1584 ((equal "" default) "? ") | |
| 1585 (t (format " [%s]? " default)))) | |
| 1586 (prompt (format "%s folder%s" prompt default-string)) | |
| 1587 read-name folder-name) | |
| 1588 (if (null mh-folder-list) | |
| 1589 (mh-set-folder-list)) | |
| 1590 (while (and (setq read-name (completing-read prompt mh-folder-list nil nil | |
| 1591 "+" 'mh-folder-hist)) | |
| 1592 (equal read-name "") | |
| 1593 (equal default ""))) | |
| 1594 (cond ((or (equal read-name "") (equal read-name "+")) | |
| 1595 (setq read-name default)) | |
| 1596 ((not (mh-folder-name-p read-name)) | |
| 1597 (setq read-name (format "+%s" read-name)))) | |
| 1598 (if (or (not read-name) (equal "" read-name)) | |
| 1599 (error "No folder specified")) | |
| 1600 (setq folder-name read-name) | |
| 1601 (cond ((and (> (length folder-name) 0) | |
| 1602 (eq (aref folder-name (1- (length folder-name))) ?/)) | |
| 1603 (setq folder-name (substring folder-name 0 -1)))) | |
| 1604 (let ((new-file-flag | |
| 1605 (not (file-exists-p (mh-expand-file-name folder-name))))) | |
| 1606 (cond ((and new-file-flag | |
| 1607 (y-or-n-p | |
| 1608 (format "Folder %s does not exist. Create it? " | |
| 1609 folder-name))) | |
| 1610 (message "Creating %s" folder-name) | |
| 1611 (mh-exec-cmd-error nil "folder" folder-name) | |
| 1612 (when (boundp 'mh-speed-folder-map) | |
| 1613 (mh-speed-add-folder folder-name)) | |
| 1614 (message "Creating %s...done" folder-name) | |
| 1615 (setq mh-folder-list (cons (list read-name) mh-folder-list)) | |
| 1616 (run-hooks 'mh-folder-list-change-hook)) | |
| 1617 (new-file-flag | |
| 1618 (error "Folder %s is not created" folder-name)) | |
| 1619 ((not (file-directory-p (mh-expand-file-name folder-name))) | |
| 1620 (error "\"%s\" is not a directory" | |
| 1621 (mh-expand-file-name folder-name))) | |
| 1622 ((and (null (assoc read-name mh-folder-list)) | |
| 1623 (null (assoc (concat read-name "/") mh-folder-list))) | |
| 1624 (setq mh-folder-list (cons (list read-name) mh-folder-list)) | |
| 1625 (run-hooks 'mh-folder-list-change-hook)))) | |
| 1626 folder-name)) | |
| 1627 | |
| 1628 (defvar mh-make-folder-list-process nil) ;The background process collecting | |
| 1629 ;the folder list. | |
| 1630 | |
| 1631 (defvar mh-folder-list-temp nil) ;mh-folder-list as it is being built. | |
| 1632 | |
| 1633 (defvar mh-folder-list-partial-line "") ;Start of last incomplete line from | |
| 1634 ;folder process. | |
| 1635 | |
| 1636 (defun mh-set-folder-list () | |
| 1637 "Set `mh-folder-list' correctly. | |
| 1638 A useful function for the command line or for when you need to | |
| 1639 sync by hand. Format is in a form suitable for completing read. | |
| 1640 The value of `mh-folder-list-change-hook' is a list of functions to be called, | |
| 1641 with no arguments, once the list of folders has been created." | |
| 1642 (message "Collecting folder names...") | |
| 1643 (if (not mh-make-folder-list-process) | |
| 1644 (mh-make-folder-list-background)) | |
| 1645 (while (eq (process-status mh-make-folder-list-process) 'run) | |
| 1646 (accept-process-output mh-make-folder-list-process)) | |
| 1647 (setq mh-folder-list mh-folder-list-temp) | |
| 1648 (run-hooks 'mh-folder-list-change-hook) | |
| 1649 (setq mh-folder-list-temp nil) | |
| 1650 (delete-process mh-make-folder-list-process) | |
| 1651 (setq mh-make-folder-list-process nil) | |
| 1652 (message "Collecting folder names...done")) | |
| 1653 | |
| 1654 (defun mh-make-folder-list-background () | |
| 1655 "Start a background process to compute a list of the user's folders. | |
| 1656 Call `mh-set-folder-list' to wait for the result." | |
| 1657 (cond | |
| 1658 ((not mh-make-folder-list-process) | |
| 1659 (unless mh-inbox | |
| 1660 (mh-find-path)) | |
| 1661 (let ((process-connection-type nil)) | |
| 1662 (setq mh-make-folder-list-process | |
| 1663 (start-process "folders" nil (expand-file-name "folders" mh-progs) | |
| 1664 "-fast" | |
| 1665 (if mh-recursive-folders-flag | |
| 1666 "-recurse" | |
| 1667 "-norecurse"))) | |
| 1668 (set-process-filter mh-make-folder-list-process | |
| 1669 'mh-make-folder-list-filter) | |
| 1670 (process-kill-without-query mh-make-folder-list-process))))) | |
| 1671 | |
| 1672 (defun mh-make-folder-list-filter (process output) | |
| 1673 "Given the PROCESS \"folders -fast\", parse OUTPUT. | |
| 1674 See also `set-process-filter'." | |
| 1675 (let ((position 0) | |
| 1676 line-end | |
| 1677 new-folder | |
| 1678 (prevailing-match-data (match-data))) | |
| 1679 (unwind-protect | |
| 1680 ;; make sure got complete line | |
| 1681 (while (setq line-end (string-match "\n" output position)) | |
| 1682 (setq new-folder (format "+%s%s" | |
| 1683 mh-folder-list-partial-line | |
| 1684 (substring output position line-end))) | |
| 1685 (setq mh-folder-list-partial-line "") | |
| 1686 ;; is new folder a subfolder of previous? | |
| 1687 (if (and mh-folder-list-temp | |
| 1688 (string-match | |
| 1689 (regexp-quote | |
| 1690 (concat (car (car mh-folder-list-temp)) "/")) | |
| 1691 new-folder)) | |
| 1692 ;; append slash to parent folder for better completion | |
| 1693 ;; (undone by mh-prompt-for-folder) | |
| 1694 (setq mh-folder-list-temp | |
| 1695 (cons | |
| 1696 (list new-folder) | |
| 1697 (cons | |
| 1698 (list (concat (car (car mh-folder-list-temp)) "/")) | |
| 1699 (cdr mh-folder-list-temp)))) | |
| 1700 (setq mh-folder-list-temp | |
| 1701 (cons (list new-folder) | |
| 1702 mh-folder-list-temp))) | |
| 1703 (setq position (1+ line-end))) | |
| 1704 (set-match-data prevailing-match-data)) | |
| 1705 (setq mh-folder-list-partial-line (substring output position)))) | |
| 1706 | |
| 1707 ;;; Issue commands to MH. | |
| 1708 | |
| 1709 (defun mh-exec-cmd (command &rest args) | |
| 1710 "Execute mh-command COMMAND with ARGS. | |
| 1711 The side effects are what is desired. | |
| 1712 Any output is assumed to be an error and is shown to the user. | |
| 1713 The output is not read or parsed by MH-E." | |
| 1714 (save-excursion | |
| 1715 (set-buffer (get-buffer-create mh-temp-buffer)) | |
| 1716 (erase-buffer) | |
| 1717 (apply 'call-process | |
| 1718 (expand-file-name command mh-progs) nil t nil | |
| 1719 (mh-list-to-string args)) | |
| 1720 (if (> (buffer-size) 0) | |
| 1721 (save-window-excursion | |
| 1722 (switch-to-buffer-other-window mh-temp-buffer) | |
| 1723 (sit-for 5))))) | |
| 1724 | |
| 1725 (defun mh-exec-cmd-error (env command &rest args) | |
| 1726 "In environment ENV, execute mh-command COMMAND with ARGS. | |
| 1727 ENV is nil or a string of space-separated \"var=value\" elements. | |
| 1728 Signals an error if process does not complete successfully." | |
| 1729 (save-excursion | |
| 1730 (set-buffer (get-buffer-create mh-temp-buffer)) | |
| 1731 (erase-buffer) | |
| 1732 (let ((status | |
| 1733 (if env | |
| 1734 ;; the shell hacks necessary here shows just how broken Unix is | |
| 1735 (apply 'call-process "/bin/sh" nil t nil "-c" | |
| 1736 (format "%s %s ${1+\"$@\"}" | |
| 1737 env | |
| 1738 (expand-file-name command mh-progs)) | |
| 1739 command | |
| 1740 (mh-list-to-string args)) | |
| 1741 (apply 'call-process | |
| 1742 (expand-file-name command mh-progs) nil t nil | |
| 1743 (mh-list-to-string args))))) | |
| 1744 (mh-handle-process-error command status)))) | |
| 1745 | |
| 1746 (defun mh-exec-cmd-daemon (command &rest args) | |
| 1747 "Execute MH command COMMAND with ARGS in the background. | |
| 1748 Any output from command is displayed in an asynchronous pop-up window." | |
| 1749 (save-excursion | |
| 1750 (set-buffer (get-buffer-create mh-temp-buffer)) | |
| 1751 (erase-buffer)) | |
| 1752 (let* ((process-connection-type nil) | |
| 1753 (process (apply 'start-process | |
| 1754 command nil | |
| 1755 (expand-file-name command mh-progs) | |
| 1756 (mh-list-to-string args)))) | |
| 1757 (set-process-filter process 'mh-process-daemon))) | |
| 1758 | |
| 1759 (defun mh-process-daemon (process output) | |
| 1760 "PROCESS daemon that puts OUTPUT into a temporary buffer." | |
| 1761 (set-buffer (get-buffer-create mh-temp-buffer)) | |
| 1762 (insert-before-markers output) | |
| 1763 (display-buffer mh-temp-buffer)) | |
| 1764 | |
| 1765 (defun mh-exec-cmd-quiet (raise-error command &rest args) | |
| 1766 "Signal RAISE-ERROR if COMMAND with ARGS fails. | |
| 1767 Execute MH command COMMAND with ARGS. ARGS is a list of strings. | |
| 1768 Return at start of mh-temp buffer, where output can be parsed and used. | |
| 1769 Returns value of `call-process', which is 0 for success, unless RAISE-ERROR is | |
| 1770 non-nil, in which case an error is signaled if `call-process' returns non-0." | |
| 1771 (set-buffer (get-buffer-create mh-temp-buffer)) | |
| 1772 (erase-buffer) | |
| 1773 (let ((value | |
| 1774 (apply 'call-process | |
| 1775 (expand-file-name command mh-progs) nil t nil | |
| 1776 args))) | |
| 1777 (goto-char (point-min)) | |
| 1778 (if raise-error | |
| 1779 (mh-handle-process-error command value) | |
| 1780 value))) | |
| 1781 | |
| 1782 (defun mh-profile-component (component) | |
| 1783 "Return COMPONENT value from mhparam, or nil if unset." | |
| 1784 (save-excursion | |
| 1785 (mh-exec-cmd-quiet nil "mhparam" "-components" component) | |
| 1786 (mh-get-profile-field (concat component ":")))) | |
| 1787 | |
| 1788 (defun mh-exchange-point-and-mark-preserving-active-mark () | |
| 1789 "Put the mark where point is now, and point where the mark is now. | |
| 1790 This command works even when the mark is not active, and preserves whether the | |
| 1791 mark is active or not." | |
| 1792 (interactive nil) | |
| 1793 (let ((is-active (and (boundp 'mark-active) mark-active))) | |
| 1794 (let ((omark (mark t))) | |
| 1795 (if (null omark) | |
| 1796 (error "No mark set in this buffer")) | |
| 1797 (set-mark (point)) | |
| 1798 (goto-char omark) | |
| 1799 (if (boundp 'mark-active) | |
| 1800 (setq mark-active is-active)) | |
| 1801 nil))) | |
| 1802 | |
| 1803 (defun mh-exec-cmd-output (command display &rest args) | |
| 1804 "Execute MH command COMMAND with DISPLAY flag and ARGS. | |
| 1805 Put the output into buffer after point. Set mark after inserted text. | |
| 1806 Output is expected to be shown to user, not parsed by MH-E." | |
| 1807 (push-mark (point) t) | |
| 1808 (apply 'call-process | |
| 1809 (expand-file-name command mh-progs) nil t display | |
| 1810 (mh-list-to-string args)) | |
| 1811 | |
| 1812 ;; The following is used instead of 'exchange-point-and-mark because the | |
| 1813 ;; latter activates the current region (between point and mark), which | |
| 1814 ;; turns on highlighting. So prior to this bug fix, doing "inc" would | |
| 1815 ;; highlight a region containing the new messages, which is undesirable. | |
| 1816 ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4. | |
| 1817 (mh-exchange-point-and-mark-preserving-active-mark)) | |
| 1818 | |
| 1819 (defun mh-exec-lib-cmd-output (command &rest args) | |
| 1820 "Execute MH library command COMMAND with ARGS. | |
| 1821 Put the output into buffer after point. Set mark after inserted text." | |
| 1822 (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args)) | |
| 1823 | |
| 1824 (defun mh-handle-process-error (command status) | |
| 1825 "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS. | |
| 1826 STATUS is return value from `call-process'. | |
| 1827 Program output is in current buffer. | |
| 1828 If output is too long to include in error message, display the buffer." | |
| 1829 (cond ((eq status 0) ;success | |
| 1830 status) | |
| 1831 ((stringp status) ;kill string | |
| 1832 (error "%s: %s" command status)) | |
| 1833 (t ;exit code | |
| 1834 (cond | |
| 1835 ((= (buffer-size) 0) ;program produced no error message | |
| 1836 (error "%s: exit code %d" command status)) | |
| 1837 (t | |
| 1838 ;; will error message fit on one line? | |
| 1839 (goto-line 2) | |
| 1840 (if (and (< (buffer-size) (frame-width)) | |
| 1841 (eobp)) | |
| 1842 (error "%s" | |
| 1843 (buffer-substring 1 (progn (goto-char 1) | |
| 1844 (end-of-line) | |
| 1845 (point)))) | |
| 1846 (display-buffer (current-buffer)) | |
| 1847 (error "%s failed with status %d. See error message in other window" | |
| 1848 command status))))))) | |
| 1849 | |
| 1850 (defun mh-list-to-string (l) | |
| 1851 "Flatten the list L and make every element of the new list into a string." | |
| 1852 (nreverse (mh-list-to-string-1 l))) | |
| 1853 | |
| 1854 (defun mh-list-to-string-1 (l) | |
| 1855 "Flatten the list L and make every element of the new list into a string." | |
| 1856 (let ((new-list nil)) | |
| 1857 (while l | |
| 1858 (cond ((null (car l))) | |
| 1859 ((symbolp (car l)) | |
| 1860 (setq new-list (cons (symbol-name (car l)) new-list))) | |
| 1861 ((numberp (car l)) | |
| 1862 (setq new-list (cons (int-to-string (car l)) new-list))) | |
| 1863 ((equal (car l) "")) | |
| 1864 ((stringp (car l)) (setq new-list (cons (car l) new-list))) | |
| 1865 ((listp (car l)) | |
| 1866 (setq new-list (nconc (mh-list-to-string-1 (car l)) | |
| 1867 new-list))) | |
| 1868 (t (error "Bad element in mh-list-to-string: %s" (car l)))) | |
| 1869 (setq l (cdr l))) | |
| 1870 new-list)) | |
| 1871 | |
| 1872 (provide 'mh-utils) | |
| 1873 | |
| 1874 ;;; Local Variables: | |
| 1875 ;;; indent-tabs-mode: nil | |
| 1876 ;;; sentence-end-double-space: nil | |
| 1877 ;;; End: | |
| 1878 | |
| 1879 ;;; mh-utils.el ends here |