lisp/mail/pmailout.el

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