code.delx.au - gnu-emacs/blob - lisp/mail/rmailout.el

   1 ;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file
   2
   3 ;; Copyright (C) 1985, 1987, 1993, 1994, 2001, 2002, 2003, 2004, 2005,
   4 ;;   2006, 2007, 2008, 2009  Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'rmail)
  29 (provide 'rmailout)
  30
  31 (defcustom rmail-output-decode-coding nil
  32   "If non-nil, do coding system decoding when outputting message as Babyl."
  33   :type '(choice (const :tag "on" t)
  34                  (const :tag "off" nil))
  35   :group 'rmail)
  36
  37 (defcustom rmail-output-file-alist nil
  38   "Alist matching regexps to suggested output Rmail files.
  39 This is a list of elements of the form (REGEXP . NAME-EXP).
  40 The suggestion is taken if REGEXP matches anywhere in the message buffer.
  41 NAME-EXP may be a string constant giving the file name to use,
  42 or more generally it may be any kind of expression that returns
  43 a file name as a string."
  44   :type '(repeat (cons regexp
  45                        (choice :value ""
  46                                (string :tag "File Name")
  47                                sexp)))
  48   :group 'rmail-output)
  49
  50 (defun rmail-output-read-file-name ()
  51   "Read the file name to use for `rmail-output'.
  52 Set `rmail-default-file' to this name as well as returning it."
  53   (let ((default-file
  54           (let (answer tail)
  55             (setq tail rmail-output-file-alist)
  56             ;; Suggest a file based on a pattern match.
  57             (while (and tail (not answer))
  58               (save-excursion
  59                 (goto-char (point-min))
  60                 (if (re-search-forward (car (car tail)) nil t)
  61                     (setq answer (eval (cdr (car tail)))))
  62                 (setq tail (cdr tail))))
  63             ;; If no suggestion, use same file as last time.
  64             (or answer rmail-default-file))))
  65     (let ((read-file
  66            (expand-file-name
  67             (read-file-name
  68              (concat "Output message to mail file (default "
  69                      (file-name-nondirectory default-file)
  70                      "): ")
  71              (file-name-directory default-file)
  72              (abbreviate-file-name default-file))
  73             (file-name-directory default-file))))
  74       (setq rmail-default-file
  75             (if (file-directory-p read-file)
  76                 (expand-file-name (file-name-nondirectory default-file)
  77                                   read-file)
  78               (expand-file-name
  79                (or read-file (file-name-nondirectory default-file))
  80                (file-name-directory default-file)))))))
  81
  82 (defcustom rmail-fields-not-to-output nil
  83   "Regexp describing fields to exclude when outputting a message to a file."
  84   :type '(choice (const :tag "None" nil)
  85                  regexp)
  86   :group 'rmail-output)
  87
  88 ;; Delete from the buffer header fields we don't want output.
  89 ;; Buffer should be pre-narrowed to the header.
  90 ;; PRESERVE is a regexp for fields NEVER to delete.
  91 (defun rmail-delete-unwanted-fields (preserve)
  92   (if rmail-fields-not-to-output
  93       (save-excursion
  94         (goto-char (point-min))
  95         (while (re-search-forward rmail-fields-not-to-output nil t)
  96           (beginning-of-line)
  97           (unless (looking-at preserve)
  98             (delete-region (point)
  99                            (progn (forward-line 1) (point))))))))
 100 \f
 101 (defun rmail-output-as-babyl (file-name nomsg)
 102   "Convert the current buffer's text to Babyl and output to FILE-NAME.
 103 It alters the current buffer's text, so it should be a temp buffer."
 104   (let ((coding-system-for-write
 105          'emacs-mule-unix))
 106     (save-restriction
 107       (goto-char (point-min))
 108       (search-forward "\n\n" nil 'move)
 109       (narrow-to-region (point-min) (point))
 110       (if rmail-fields-not-to-output
 111           (rmail-delete-unwanted-fields nil)))
 112
 113     ;; Convert to Babyl format.
 114     (rmail-convert-to-babyl-format)
 115     ;; Write it into the file, or its buffer.
 116     (let ((buf (find-buffer-visiting file-name))
 117           (tembuf (current-buffer)))
 118       (if (null buf)
 119           (write-region (point-min) (point-max) file-name t nomsg)
 120         (if (eq buf (current-buffer))
 121             (error "Can't output message to same file it's already in"))
 122         ;; File has been visited, in buffer BUF.
 123         (set-buffer buf)
 124         (let ((inhibit-read-only t)
 125               (msg (with-no-warnings
 126                      (and (boundp 'rmail-current-message)
 127                           rmail-current-message))))
 128           ;; If MSG is non-nil, buffer is in RMAIL mode.
 129           (if msg
 130               (rmail-output-to-babyl-buffer tembuf msg)
 131             ;; Output file not in rmail mode => just insert at the end.
 132             (narrow-to-region (point-min) (1+ (buffer-size)))
 133             (goto-char (point-max))
 134             (insert-buffer-substring tembuf)))))))
 135
 136 (defun rmail-output-to-babyl-buffer (tembuf msg)
 137   "Copy msg in TEMBUF from BEG to END into this old R-mail BABYL buffer.
 138 Do what is necessary to make babyl R-mail know about the new message.
 139 Then display message number MSG."
 140   (with-no-warnings
 141     ;; Turn on Auto Save mode, if it's off in this
 142     ;; buffer but enabled by default.
 143     (and (not buffer-auto-save-file-name)
 144          auto-save-default
 145          (auto-save-mode t))
 146     (rmail-maybe-set-message-counters)
 147     (widen)
 148     (narrow-to-region (point-max) (point-max))
 149     (insert-buffer-substring tembuf)
 150     (goto-char (point-min))
 151     (widen)
 152     (search-backward "\n\^_")
 153     (narrow-to-region (point) (point-max))
 154     (rmail-count-new-messages t)
 155     (if (rmail-summary-exists)
 156         (rmail-select-summary
 157          (rmail-update-summary)))
 158     (rmail-show-message msg)))
 159 \f
 160 (defun rmail-convert-to-babyl-format ()
 161   (let ((count 0) (start (point-min))
 162         (case-fold-search nil)
 163         (buffer-undo-list t))
 164     (goto-char (point-min))
 165     (save-restriction
 166       (unless (looking-at "^From ")
 167         (error "Invalid mbox message"))
 168       (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
 169       (rmail-nuke-pinhead-header)
 170       ;; Decode base64 or quoted printable contents, Rmail style.
 171       (let* ((header-end (save-excursion
 172                            (and (re-search-forward "\n\n" nil t)
 173                                 (1- (point)))))
 174              (case-fold-search t)
 175              (quoted-printable-header-field-end
 176               (save-excursion
 177                 (re-search-forward
 178                  "^content-transfer-encoding:\\(\n?[\t ]\\)*quoted-printable\\(\n?[\t ]\\)*"
 179                  header-end t)))
 180              (base64-header-field-end
 181               (and
 182                ;; Don't decode non-text data.
 183                (save-excursion
 184                  (re-search-forward
 185                   "^content-type:\\(\n?[\t ]\\)\\(text\\|message\\)/"
 186                   header-end t))
 187                (save-excursion
 188                  (re-search-forward
 189                   "^content-transfer-encoding:\\(\n?[\t ]\\)*base64\\(\n?[\t ]\\)*"
 190                   header-end t)))))
 191
 192         (goto-char (point-max))
 193         (if quoted-printable-header-field-end
 194             (save-excursion
 195               (unless (mail-unquote-printable-region
 196                        header-end (point) nil t t)
 197                 (message "Malformed MIME quoted-printable message"))
 198               ;; Change "quoted-printable" to "8bit",
 199               ;; to reflect the decoding we just did.
 200               (goto-char quoted-printable-header-field-end)
 201               (delete-region (point) (search-backward ":"))
 202               (insert ": 8bit")))
 203         (if base64-header-field-end
 204             (save-excursion
 205               (when (condition-case nil
 206                         (progn
 207                           (base64-decode-region
 208                            (1+ header-end)
 209                            (save-excursion
 210                              ;; Prevent base64-decode-region
 211                              ;; from removing newline characters.
 212                              (skip-chars-backward "\n\t ")
 213                              (point)))
 214                           t)
 215                       (error nil))
 216                 ;; Change "base64" to "8bit", to reflect the
 217                 ;; decoding we just did.
 218                 (goto-char base64-header-field-end)
 219                 (delete-region (point) (search-backward ":"))
 220                 (insert ": 8bit")))))
 221       ;; Transform anything within the message text
 222       ;; that might appear to be the end of a Babyl-format message.
 223       (save-excursion
 224         (save-restriction
 225           (narrow-to-region start (point))
 226           (goto-char (point-min))
 227           (while (search-forward "\n\^_" nil t) ; single char
 228             (replace-match "\n^_"))))           ; 2 chars: "^" and "_"
 229       ;; This is for malformed messages that don't end in newline.
 230       ;; There shouldn't be any, but some users say occasionally
 231       ;; there are some.
 232       (or (bolp) (newline))
 233       (insert ?\^_)
 234       (setq last-coding-system-used nil)
 235       ;; Decode coding system, following specs in the message header,
 236       ;; and record what coding system was decoded.
 237       (if rmail-output-decode-coding
 238           (let ((mime-charset
 239                  (if (save-excursion
 240                        (goto-char start)
 241                        (search-forward "\n\n" nil t)
 242                        (let ((case-fold-search t))
 243                          (re-search-backward
 244                           rmail-mime-charset-pattern
 245                           start t)))
 246                      (intern (downcase (match-string 1))))))
 247             (rmail-decode-region start (point) mime-charset)))
 248       (save-excursion
 249         (goto-char start)
 250         (forward-line 3)
 251         (insert "X-Coding-System: "
 252                 (symbol-name last-coding-system-used)
 253                 "\n")))))
 254
 255 ;; Delete the "From ..." line, creating various other headers with
 256 ;; information from it if they don't already exist.  Now puts the
 257 ;; original line into a mail-from: header line for debugging and for
 258 ;; use by the rmail-output function.
 259 (defun rmail-nuke-pinhead-header ()
 260   (save-excursion
 261     (save-restriction
 262       (let ((start (point))
 263             (end (progn
 264                    (condition-case ()
 265                        (search-forward "\n\n")
 266                      (error
 267                       (goto-char (point-max))
 268                       (insert "\n\n")))
 269                    (point)))
 270             has-from has-date)
 271         (narrow-to-region start end)
 272         (let ((case-fold-search t))
 273           (goto-char start)
 274           (setq has-from (search-forward "\nFrom:" nil t))
 275           (goto-char start)
 276           (setq has-date (and (search-forward "\nDate:" nil t) (point)))
 277           (goto-char start))
 278         (let ((case-fold-search nil))
 279           (if (re-search-forward (concat "^" rmail-unix-mail-delimiter) nil t)
 280               (replace-match
 281                 (concat
 282                   "Mail-from: \\&"
 283                   ;; Keep and reformat the date if we don't
 284                   ;;  have a Date: field.
 285                   (if has-date
 286                       ""
 287                     (concat
 288                      "Date: \\2, \\4 \\3 \\9 \\5 "
 289
 290                      ;; The timezone could be matched by group 7 or group 10.
 291                      ;; If neither of them matched, assume EST, since only
 292                      ;; Easterners would be so sloppy.
 293                      ;; It's a shame the substitution can't use "\\10".
 294                      (cond
 295                       ((/= (match-beginning 7) (match-end 7)) "\\7")
 296                       ((/= (match-beginning 10) (match-end 10))
 297                        (buffer-substring (match-beginning 10)
 298                                          (match-end 10)))
 299                       (t "EST"))
 300                      "\n"))
 301                   ;; Keep and reformat the sender if we don't
 302                   ;; have a From: field.
 303                   (if has-from
 304                       ""
 305                     "From: \\1\n"))
 306                 t)))))))
 307 \f
 308 (defun rmail-output-as-mbox (file-name nomsg &optional as-seen)
 309   "Convert the current buffer's text to mbox Babyl and output to FILE-NAME.
 310 It alters the current buffer's text, so call with a temp buffer current.
 311 If FILE-NAME is visited, output into its buffer instead.
 312 AS-SEEN is non-nil if we are copying the message \"as seen\"."
 313   (let ((case-fold-search t)
 314         mail-from mime-version content-type)
 315
 316     ;; Preserve the Mail-From and MIME-Version fields
 317     ;; even if they have been pruned.
 318     (search-forward "\n\n" nil 'move)
 319     (narrow-to-region (point-min) (point))
 320
 321     (rmail-delete-unwanted-fields
 322      (if rmail-enable-mime "Mail-From"
 323        "Mail-From\\|MIME-Version\\|Content-type"))
 324
 325     (widen)
 326
 327     ;; Make sure message ends with blank line.
 328     (goto-char (point-max))
 329     (unless (bolp)
 330        (insert "\n"))
 331     (unless (looking-back "\n\n")
 332       (insert "\n"))
 333
 334     ;; Generate a From line from other header fields
 335     ;; if necessary.
 336     (goto-char (point-min))
 337     (unless (looking-at "From ")
 338       (insert "From "
 339               (mail-strip-quoted-names
 340                (save-excursion
 341                  (save-restriction
 342                    (goto-char (point-min))
 343                    (narrow-to-region
 344                     (point)
 345                     (or (search-forward "\n\n" nil)
 346                         (point-max)))
 347                    (or (mail-fetch-field "from")
 348                        (mail-fetch-field "really-from")
 349                        (mail-fetch-field "sender")
 350                        "unknown"))))
 351               " " (current-time-string) "\n"))
 352
 353     (let ((buf (find-buffer-visiting file-name))
 354           (tembuf (current-buffer)))
 355       (if (null buf)
 356           (let ((coding-system-for-write 'raw-text-unix))
 357             (write-region (point-min) (point-max) file-name t nomsg))
 358         (if (eq buf (current-buffer))
 359             (error "Can't output message to same file it's already in"))
 360         ;; File has been visited, in buffer BUF.
 361         (set-buffer buf)
 362         (let ((inhibit-read-only t)
 363               (msg (and (boundp 'rmail-current-message)
 364                         rmail-current-message)))
 365           (and msg as-seen
 366                (error "Can't output \"as seen\" to a visited Rmail file"))
 367           (if msg
 368               (rmail-output-to-rmail-buffer tembuf msg)
 369             ;; Output file not in Rmail mode => just insert at the end.
 370             (narrow-to-region (point-min) (1+ (buffer-size)))
 371             (goto-char (point-max))
 372             (insert-buffer-substring tembuf)))))))
 373
 374 ;; Called only if rmail-summary-exists, which means rmailsum is loaded.
 375 (declare-function rmail-update-summary "rmailsum" (&rest ignore))
 376
 377 (defun rmail-output-to-rmail-buffer (tembuf msg)
 378   "Copy msg in TEMBUF from BEG to END into this Rmail buffer.
 379 Do what is necessary to make Rmail know about the new message.
 380 Then display message number MSG."
 381   (save-excursion
 382     (rmail-swap-buffers-maybe)
 383     ;; Turn on Auto Save mode, if it's off in this
 384     ;; buffer but enabled by default.
 385     (and (not buffer-auto-save-file-name)
 386          auto-save-default
 387          (auto-save-mode t))
 388     (rmail-maybe-set-message-counters)
 389     (narrow-to-region (point-max) (point-max))
 390     (insert-buffer-substring tembuf)
 391     (rmail-count-new-messages t)
 392     (if (rmail-summary-exists)
 393         (rmail-select-summary
 394          (rmail-update-summary)))
 395     (rmail-show-message msg)))
 396 \f
 397 ;;; There are functions elsewhere in Emacs that use this function;
 398 ;;; look at them before you change the calling method.
 399 ;;;###autoload
 400 (defun rmail-output (file-name &optional count noattribute from-gnus)
 401   "Append this message to mail file FILE-NAME.
 402 This works with both mbox format and Babyl format files,
 403 outputting in the appropriate format for each.
 404 The default file name comes from `rmail-default-file',
 405 which is updated to the name you use in this command.
 406
 407 A prefix argument COUNT says to output that many consecutive messages,
 408 starting with the current one.  Deleted messages are skipped and don't count.
 409 When called from Lisp code, COUNT may be omitted and defaults to 1.
 410
 411 This command always outputs the complete message header,
 412 even if the header display is currently pruned.
 413
 414 The optional third argument NOATTRIBUTE, if non-nil, says not
 415 to set the `filed' attribute, and not to display a message.
 416
 417 The optional fourth argument FROM-GNUS is set when called from GNUS."
 418   (interactive
 419    (list (rmail-output-read-file-name)
 420          (prefix-numeric-value current-prefix-arg)))
 421   (or count (setq count 1))
 422   (setq file-name
 423         (expand-file-name file-name
 424                           (and rmail-default-file
 425                                (file-name-directory rmail-default-file))))
 426
 427   ;; Warn about creating new file.
 428   (or (find-buffer-visiting file-name)
 429       (file-exists-p file-name)
 430       (yes-or-no-p
 431        (concat "\"" file-name "\" does not exist, create it? "))
 432       (error "Output file does not exist"))
 433
 434   (set-buffer rmail-buffer)
 435
 436   (let ((orig-count count)
 437         (case-fold-search t)
 438         (tembuf (get-buffer-create " rmail-output"))
 439         (babyl-format
 440          (and (file-readable-p file-name) (mail-file-babyl-p file-name))))
 441
 442     (unwind-protect
 443         (while (> count 0)
 444           (with-current-buffer rmail-buffer
 445             (let (cur beg end)
 446               (setq beg (rmail-msgbeg rmail-current-message)
 447                     end (rmail-msgend rmail-current-message))
 448               ;; All access to the buffer's local variables is now finished...
 449               (save-excursion
 450                 ;; ... so it is ok to go to a different buffer.
 451                 (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer))
 452                 (setq cur (current-buffer))
 453                 (save-restriction
 454                   (widen)
 455                   (with-current-buffer tembuf
 456                     (insert-buffer-substring cur beg end)
 457                     ;; Convert the text to one format or another and output.
 458                     (if babyl-format
 459                         (rmail-output-as-babyl file-name (if noattribute 'nomsg))
 460                       (rmail-output-as-mbox file-name
 461                                             (if noattribute 'nomsg))))))))
 462
 463           ;; Mark message as "filed".
 464           (unless noattribute
 465             (rmail-set-attribute rmail-filed-attr-index t))
 466
 467           (setq count (1- count))
 468
 469           (or from-gnus
 470               (let ((next-message-p
 471                      (if rmail-delete-after-output
 472                          (rmail-delete-forward)
 473                        (if (> count 0)
 474                            (rmail-next-undeleted-message 1))))
 475                     (num-appended (- orig-count count)))
 476                 (if (and (> count 0) (not next-message-p))
 477                     (error "Only %d message%s appended" num-appended
 478                            (if (= num-appended 1) "" "s"))))))
 479       (kill-buffer tembuf))))
 480
 481 (defun rmail-output-as-seen (file-name &optional count noattribute from-gnus)
 482   "Append this message to system-inbox-format mail file named FILE-NAME.
 483 A prefix argument COUNT says to output that many consecutive messages,
 484 starting with the current one.  Deleted messages are skipped and don't count.
 485 When called from Lisp code, COUNT may be omitted and defaults to 1.
 486
 487 This outputs the message header as you see it.
 488
 489 The default file name comes from `rmail-default-file',
 490 which is updated to the name you use in this command.
 491
 492 The optional third argument NOATTRIBUTE, if non-nil, says not
 493 to set the `filed' attribute, and not to display a message.
 494
 495 The optional fourth argument FROM-GNUS is set when called from GNUS."
 496   (interactive
 497    (list (rmail-output-read-file-name)
 498          (prefix-numeric-value current-prefix-arg)))
 499   (or count (setq count 1))
 500   (setq file-name
 501         (expand-file-name file-name
 502                           (and rmail-default-file
 503                                (file-name-directory rmail-default-file))))
 504   (set-buffer rmail-buffer)
 505
 506   ;; Warn about creating new file.
 507   (or (find-buffer-visiting file-name)
 508       (file-exists-p file-name)
 509       (yes-or-no-p
 510        (concat "\"" file-name "\" does not exist, create it? "))
 511       (error "Output file does not exist"))
 512
 513     (if (and (file-readable-p file-name) (mail-file-babyl-p file-name))
 514         (error "Cannot output `as seen' to a Babyl file"))
 515
 516   (let ((orig-count count)
 517         (case-fold-search t)
 518         (tembuf (get-buffer-create " rmail-output")))
 519
 520     (unwind-protect
 521         (while (> count 0)
 522           (let (cur beg end)
 523             ;; If operating from whole-mbox buffer, get message bounds.
 524             (if (not (rmail-buffers-swapped-p))
 525                 (setq beg (rmail-msgbeg rmail-current-message)
 526                       end (rmail-msgend rmail-current-message)))
 527             ;; All access to the buffer's local variables is now finished...
 528             (save-excursion
 529               (setq cur (current-buffer))
 530               (save-restriction
 531                 (widen)
 532                 ;; If operating from the view buffer, get the bounds.
 533                 (unless beg
 534                   (setq beg (point-min)
 535                         end (point-max)))
 536
 537                 (with-current-buffer tembuf
 538                   (insert-buffer-substring cur beg end)
 539                   ;; Convert the text to one format or another and output.
 540                   (rmail-output-as-mbox file-name
 541                                         (if noattribute 'nomsg)
 542                                         t)))))
 543
 544           ;; Mark message as "filed".
 545           (unless noattribute
 546             (rmail-set-attribute rmail-filed-attr-index t))
 547
 548           (setq count (1- count))
 549
 550           (or from-gnus
 551               (let ((next-message-p
 552                      (if rmail-delete-after-output
 553                          (rmail-delete-forward)
 554                        (if (> count 0)
 555                            (rmail-next-undeleted-message 1))))
 556                     (num-appended (- orig-count count)))
 557                 (if (and (> count 0) (not next-message-p))
 558                     (error "Only %d message%s appended" num-appended
 559                            (if (= num-appended 1) "" "s"))))))
 560       (kill-buffer tembuf))))
 561
 562 \f
 563 ;;;###autoload
 564 (defun rmail-output-body-to-file (file-name)
 565   "Write this message body to the file FILE-NAME.
 566 FILE-NAME defaults, interactively, from the Subject field of the message."
 567   (interactive
 568    (let ((default-file
 569            (or (mail-fetch-field "Subject")
 570                rmail-default-body-file)))
 571      (list (setq rmail-default-body-file
 572                  (read-file-name
 573                   "Output message body to file: "
 574                   (and default-file (file-name-directory default-file))
 575                   default-file
 576                   nil default-file)))))
 577   (setq file-name
 578         (expand-file-name file-name
 579                           (and rmail-default-body-file
 580                                (file-name-directory rmail-default-body-file))))
 581   (save-excursion
 582     (goto-char (point-min))
 583     (search-forward "\n\n")
 584     (and (file-exists-p file-name)
 585          (not (y-or-n-p (format "File %s exists; overwrite? " file-name)))
 586          (error "Operation aborted"))
 587     (write-region (point) (point-max) file-name))
 588   (if rmail-delete-after-output
 589       (rmail-delete-forward)))
 590
 591 ;; arch-tag: 4059abf0-f249-4be4-8e0d-602d370d01d1
 592 ;;; rmailout.el ends here