code.delx.au - gnu-emacs/blob - 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, or its buffer.
 119     (let ((buf (find-buffer-visiting file-name))
 120           (tembuf (current-buffer)))
 121       (if (null buf)
 122           (write-region (point-min) (point-max) file-name t nomsg)
 123         (if (eq buf (current-buffer))
 124             (error "Can't output message to same file it's already in"))
 125         ;; File has been visited, in buffer BUF.
 126         (set-buffer buf)
 127         (let ((inhibit-read-only t)
 128               (msg (with-no-warnings
 129                      (and (boundp 'rmail-current-message)
 130                           rmail-current-message))))
 131           ;; If MSG is non-nil, buffer is in RMAIL mode.
 132           (if msg
 133               (pmail-output-to-r-mail-buffer tembuf msg)
 134             ;; Output file not in rmail mode => just insert at the end.
 135             (narrow-to-region (point-min) (1+ (buffer-size)))
 136             (goto-char (point-max))
 137             (insert-buffer-substring tembuf)))))))
 138
 139 ;; When Pmail is really installed, if we delete or rename the old Rmail
 140 ;; we should do likewise with this function.
 141
 142 (defun pmail-output-to-r-mail-buffer (tembuf msg)
 143   "Copy msg in TEMBUF from BEG to END into this old R-mail BABYL buffer.
 144 Do what is necessary to make babyl R-mail know about the new message.
 145 Then display message number MSG."
 146   (with-no-warnings
 147     ;; Turn on Auto Save mode, if it's off in this
 148     ;; buffer but enabled by default.
 149     (and (not buffer-auto-save-file-name)
 150          auto-save-default
 151          (auto-save-mode t))
 152     (rmail-maybe-set-message-counters)
 153     (widen)
 154     (narrow-to-region (point-max) (point-max))
 155     (insert-buffer-substring tembuf)
 156     (goto-char (point-min))
 157     (widen)
 158     (search-backward "\n\^_")
 159     (narrow-to-region (point) (point-max))
 160     (rmail-count-new-messages t)
 161     (if (rmail-summary-exists)
 162         (rmail-select-summary
 163          (rmail-update-summary)))
 164     (rmail-show-message msg)))
 165 \f
 166 (defun pmail-convert-to-babyl-format ()
 167   (let ((count 0) (start (point-min))
 168         (case-fold-search nil)
 169         (buffer-undo-list t))
 170     (goto-char (point-min))
 171     (save-restriction
 172       (unless (looking-at "^From ")
 173         (error "Invalid mbox message"))
 174       (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
 175       (pmail-nuke-pinhead-header)
 176       ;; Decode base64 or quoted printable contents, Rmail style.
 177       (let* ((header-end (save-excursion
 178                            (and (re-search-forward "\n\n" nil t)
 179                                 (1- (point)))))
 180              (case-fold-search t)
 181              (quoted-printable-header-field-end
 182               (save-excursion
 183                 (re-search-forward
 184                  "^content-transfer-encoding:\\(\n?[\t ]\\)*quoted-printable\\(\n?[\t ]\\)*"
 185                  header-end t)))
 186              (base64-header-field-end
 187               (and
 188                ;; Don't decode non-text data.
 189                (save-excursion
 190                  (re-search-forward
 191                   "^content-type:\\(\n?[\t ]\\)\\(text\\|message\\)/"
 192                   header-end t))
 193                (save-excursion
 194                  (re-search-forward
 195                   "^content-transfer-encoding:\\(\n?[\t ]\\)*base64\\(\n?[\t ]\\)*"
 196                   header-end t)))))
 197
 198         (goto-char (point-max))
 199         (if quoted-printable-header-field-end
 200             (save-excursion
 201               (unless (mail-unquote-printable-region
 202                        header-end (point) nil t t)
 203                 (message "Malformed MIME quoted-printable message"))
 204               ;; Change "quoted-printable" to "8bit",
 205               ;; to reflect the decoding we just did.
 206               (goto-char quoted-printable-header-field-end)
 207               (delete-region (point) (search-backward ":"))
 208               (insert ": 8bit")))
 209         (if base64-header-field-end
 210             (save-excursion
 211               (when (condition-case nil
 212                         (progn
 213                           (base64-decode-region
 214                            (1+ header-end)
 215                            (save-excursion
 216                              ;; Prevent base64-decode-region
 217                              ;; from removing newline characters.
 218                              (skip-chars-backward "\n\t ")
 219                              (point)))
 220                           t)
 221                       (error nil))
 222                 ;; Change "base64" to "8bit", to reflect the
 223                 ;; decoding we just did.
 224                 (goto-char base64-header-field-end)
 225                 (delete-region (point) (search-backward ":"))
 226                 (insert ": 8bit")))))
 227       ;; Transform anything within the message text
 228       ;; that might appear to be the end of a Babyl-format message.
 229       (save-excursion
 230         (save-restriction
 231           (narrow-to-region start (point))
 232           (goto-char (point-min))
 233           (while (search-forward "\n\^_" nil t) ; single char
 234             (replace-match "\n^_"))))           ; 2 chars: "^" and "_"
 235       ;; This is for malformed messages that don't end in newline.
 236       ;; There shouldn't be any, but some users say occasionally
 237       ;; there are some.
 238       (or (bolp) (newline))
 239       (insert ?\^_)
 240       (setq last-coding-system-used nil)
 241       ;; Decode coding system, following specs in the message header,
 242       ;; and record what coding system was decoded.
 243       (if pmail-output-decode-coding
 244           (let ((mime-charset
 245                  (if (save-excursion
 246                        (goto-char start)
 247                        (search-forward "\n\n" nil t)
 248                        (let ((case-fold-search t))
 249                          (re-search-backward
 250                           pmail-mime-charset-pattern
 251                           start t)))
 252                      (intern (downcase (match-string 1))))))
 253             (pmail-decode-region start (point) mime-charset)))
 254       (save-excursion
 255         (goto-char start)
 256         (forward-line 3)
 257         (insert "X-Coding-System: "
 258                 (symbol-name last-coding-system-used)
 259                 "\n")))))
 260
 261 ;; Delete the "From ..." line, creating various other headers with
 262 ;; information from it if they don't already exist.  Now puts the
 263 ;; original line into a mail-from: header line for debugging and for
 264 ;; use by the pmail-output function.
 265 (defun pmail-nuke-pinhead-header ()
 266   (save-excursion
 267     (save-restriction
 268       (let ((start (point))
 269             (end (progn
 270                    (condition-case ()
 271                        (search-forward "\n\n")
 272                      (error
 273                       (goto-char (point-max))
 274                       (insert "\n\n")))
 275                    (point)))
 276             has-from has-date)
 277         (narrow-to-region start end)
 278         (let ((case-fold-search t))
 279           (goto-char start)
 280           (setq has-from (search-forward "\nFrom:" nil t))
 281           (goto-char start)
 282           (setq has-date (and (search-forward "\nDate:" nil t) (point)))
 283           (goto-char start))
 284         (let ((case-fold-search nil))
 285           (if (re-search-forward (concat "^" pmail-unix-mail-delimiter) nil t)
 286               (replace-match
 287                 (concat
 288                   "Mail-from: \\&"
 289                   ;; Keep and reformat the date if we don't
 290                   ;;  have a Date: field.
 291                   (if has-date
 292                       ""
 293                     (concat
 294                      "Date: \\2, \\4 \\3 \\9 \\5 "
 295
 296                      ;; The timezone could be matched by group 7 or group 10.
 297                      ;; If neither of them matched, assume EST, since only
 298                      ;; Easterners would be so sloppy.
 299                      ;; It's a shame the substitution can't use "\\10".
 300                      (cond
 301                       ((/= (match-beginning 7) (match-end 7)) "\\7")
 302                       ((/= (match-beginning 10) (match-end 10))
 303                        (buffer-substring (match-beginning 10)
 304                                          (match-end 10)))
 305                       (t "EST"))
 306                      "\n"))
 307                   ;; Keep and reformat the sender if we don't
 308                   ;; have a From: field.
 309                   (if has-from
 310                       ""
 311                     "From: \\1\n"))
 312                 t)))))))
 313 \f
 314 (defun pmail-output-as-mbox (file-name nomsg &optional as-seen)
 315   "Convert the current buffer's text to mbox Babyl and output to FILE-NAME.
 316 It alters the current buffer's text, so call with a temp buffer current.
 317 If FILE-NAME is visited, output into its buffer instead.
 318 AS-SEEN is non-nil if we are copying the message \"as seen\"."
 319   (let ((case-fold-search t)
 320         mail-from mime-version content-type)
 321
 322     ;; Preserve the Mail-From and MIME-Version fields
 323     ;; even if they have been pruned.
 324     (search-forward "\n\n" nil 'move)
 325     (narrow-to-region (point-min) (point))
 326
 327     (pmail-delete-unwanted-fields
 328      (if pmail-enable-mime "Mail-From"
 329        "Mail-From\\|MIME-Version\\|Content-type"))
 330
 331     (widen)
 332
 333     ;; Make sure message ends with blank line.
 334     (goto-char (point-max))
 335     (unless (bolp)
 336        (insert "\n"))
 337     (unless (looking-back "\n\n")
 338       (insert "\n"))
 339
 340     ;; Generate a From line from other header fields
 341     ;; if necessary.
 342     (goto-char (point-min))
 343     (unless (looking-at "From ")
 344       (insert "From "
 345               (mail-strip-quoted-names
 346                (save-excursion
 347                  (save-restriction
 348                    (goto-char (point-min))
 349                    (narrow-to-region
 350                     (point)
 351                     (or (search-forward "\n\n" nil)
 352                         (point-max)))
 353                    (or (mail-fetch-field "from")
 354                        (mail-fetch-field "really-from")
 355                        (mail-fetch-field "sender")
 356                        "unknown"))))
 357               " " (current-time-string) "\n"))
 358
 359     (let ((buf (find-buffer-visiting file-name))
 360           (tembuf (current-buffer)))
 361       (if (null buf)
 362           (let ((coding-system-for-write 'raw-text-unix))
 363             (write-region (point-min) (point-max) file-name t nomsg))
 364         (if (eq buf (current-buffer))
 365             (error "Can't output message to same file it's already in"))
 366         ;; File has been visited, in buffer BUF.
 367         (set-buffer buf)
 368         (let ((inhibit-read-only t)
 369               (msg (and (boundp 'pmail-current-message)
 370                         pmail-current-message)))
 371           (and msg as-seen
 372                (error "Can't output \"as seen\" to a visited Pmail file"))
 373           (if msg
 374               (pmail-output-to-pmail-buffer tembuf msg)
 375             ;; Output file not in Pmail mode => just insert at the end.
 376             (narrow-to-region (point-min) (1+ (buffer-size)))
 377             (goto-char (point-max))
 378             (insert-buffer-substring tembuf)))))))
 379
 380 (defun pmail-output-to-pmail-buffer (tembuf msg)
 381   "Copy msg in TEMBUF from BEG to END into this Pmail buffer.
 382 Do what is necessary to make Pmail know about the new message.
 383 Then display message number MSG."
 384   (save-excursion
 385     (pmail-swap-buffers-maybe)
 386     ;; Turn on Auto Save mode, if it's off in this
 387     ;; buffer but enabled by default.
 388     (and (not buffer-auto-save-file-name)
 389          auto-save-default
 390          (auto-save-mode t))
 391     (pmail-maybe-set-message-counters)
 392     (narrow-to-region (point-max) (point-max))
 393     (insert-buffer-substring tembuf)
 394     (pmail-count-new-messages t)
 395     (if (pmail-summary-exists)
 396         (pmail-select-summary
 397          (pmail-update-summary)))
 398     (pmail-show-message msg)))
 399 \f
 400 ;;; There are functions elsewhere in Emacs that use this function;
 401 ;;; look at them before you change the calling method.
 402 ;;;###autoload
 403 (defun pmail-output (file-name &optional count noattribute from-gnus)
 404   "Append this message to mail file FILE-NAME.
 405 This works with both mbox format and Babyl format files,
 406 outputting in the appropriate format for each.
 407 The default file name comes from `pmail-default-file',
 408 which is updated to the name you use in this command.
 409
 410 A prefix argument COUNT says to output that many consecutive messages,
 411 starting with the current one.  Deleted messages are skipped and don't count.
 412 When called from Lisp code, COUNT may be omitted and defaults to 1.
 413
 414 This command always outputs the complete message header,
 415 even the header display is currently pruned.
 416
 417 The optional third argument NOATTRIBUTE, if non-nil, says not
 418 to set the `filed' attribute, and not to display a message.
 419
 420 The optional fourth argument FROM-GNUS is set when called from GNUS."
 421   (interactive
 422    (list (pmail-output-read-file-name)
 423          (prefix-numeric-value current-prefix-arg)))
 424   (or count (setq count 1))
 425   (setq file-name
 426         (expand-file-name file-name
 427                           (and pmail-default-file
 428                                (file-name-directory pmail-default-file))))
 429
 430   ;; Warn about creating new file.
 431   (or (find-buffer-visiting file-name)
 432       (file-exists-p file-name)
 433       (yes-or-no-p
 434        (concat "\"" file-name "\" does not exist, create it? "))
 435       (error "Output file does not exist"))
 436
 437   (set-buffer pmail-buffer)
 438
 439   (let ((orig-count count)
 440         (case-fold-search t)
 441         (tembuf (get-buffer-create " pmail-output"))
 442         (babyl-format
 443          (and (file-readable-p file-name) (mail-file-babyl-p file-name))))
 444
 445     (unwind-protect
 446         (while (> count 0)
 447           (with-current-buffer pmail-buffer
 448             (let (cur beg end)
 449               (setq beg (pmail-msgbeg pmail-current-message)
 450                     end (pmail-msgend pmail-current-message))
 451               ;; All access to the buffer's local variables is now finished...
 452               (save-excursion
 453                 ;; ... so it is ok to go to a different buffer.
 454                 (if (pmail-buffers-swapped-p) (set-buffer pmail-view-buffer))
 455                 (setq cur (current-buffer))
 456                 (save-restriction
 457                   (widen)
 458                   (with-current-buffer tembuf
 459                     (insert-buffer-substring cur beg end)
 460                     ;; Convert the text to one format or another and output.
 461                     (if babyl-format
 462                         (pmail-output-as-babyl file-name (if noattribute 'nomsg))
 463                       (pmail-output-as-mbox file-name
 464                                             (if noattribute 'nomsg))))))))
 465
 466           ;; Mark message as "filed".
 467           (unless noattribute
 468             (pmail-set-attribute pmail-filed-attr-index t))
 469
 470           (setq count (1- count))
 471
 472           (or from-gnus
 473               (let ((next-message-p
 474                      (if pmail-delete-after-output
 475                          (pmail-delete-forward)
 476                        (if (> count 0)
 477                            (pmail-next-undeleted-message 1))))
 478                     (num-appended (- orig-count count)))
 479                 (if (and (> count 0) (not next-message-p))
 480                     (error "Only %d message%s appended" num-appended
 481                            (if (= num-appended 1) "" "s"))))))
 482       (kill-buffer tembuf))))
 483
 484 (defun pmail-output-as-seen (file-name &optional count noattribute from-gnus)
 485   "Append this message to system-inbox-format mail file named FILE-NAME.
 486 A prefix argument COUNT says to output that many consecutive messages,
 487 starting with the current one.  Deleted messages are skipped and don't count.
 488 When called from Lisp code, COUNT may be omitted and defaults to 1.
 489
 490 This outputs the message header as you see it.
 491
 492 The default file name comes from `pmail-default-file',
 493 which is updated to the name you use in this command.
 494
 495 The optional third argument NOATTRIBUTE, if non-nil, says not
 496 to set the `filed' attribute, and not to display a message.
 497
 498 The optional fourth argument FROM-GNUS is set when called from GNUS."
 499   (interactive
 500    (list (pmail-output-read-file-name)
 501          (prefix-numeric-value current-prefix-arg)))
 502   (or count (setq count 1))
 503   (setq file-name
 504         (expand-file-name file-name
 505                           (and pmail-default-file
 506                                (file-name-directory pmail-default-file))))
 507   (set-buffer pmail-buffer)
 508
 509   ;; Warn about creating new file.
 510   (or (find-buffer-visiting file-name)
 511       (file-exists-p file-name)
 512       (yes-or-no-p
 513        (concat "\"" file-name "\" does not exist, create it? "))
 514       (error "Output file does not exist"))
 515
 516     (if (and (file-readable-p file-name) (mail-file-babyl-p file-name))
 517         (error "Cannot output `as seen' to a Babyl file"))
 518
 519   (let ((orig-count count)
 520         (case-fold-search t)
 521         (tembuf (get-buffer-create " pmail-output")))
 522
 523     (unwind-protect
 524         (while (> count 0)
 525           (let (cur beg end)
 526             ;; If operating from whole-mbox buffer, get message bounds.
 527             (if (not (pmail-buffers-swapped-p))
 528                 (setq beg (pmail-msgbeg pmail-current-message)
 529                       end (pmail-msgend pmail-current-message)))
 530             ;; All access to the buffer's local variables is now finished...
 531             (save-excursion
 532               (setq cur (current-buffer))
 533               (save-restriction
 534                 (widen)
 535                 ;; If operating from the view buffer, get the bounds.
 536                 (unless beg
 537                   (setq beg (point-min)
 538                         end (point-max)))
 539
 540                 (with-current-buffer tembuf
 541                   (insert-buffer-substring cur beg end)
 542                   ;; Convert the text to one format or another and output.
 543                   (pmail-output-as-mbox file-name
 544                                         (if noattribute 'nomsg)
 545                                         t)))))
 546
 547           ;; Mark message as "filed".
 548           (unless noattribute
 549             (pmail-set-attribute pmail-filed-attr-index t))
 550
 551           (setq count (1- count))
 552
 553           (or from-gnus
 554               (let ((next-message-p
 555                      (if pmail-delete-after-output
 556                          (pmail-delete-forward)
 557                        (if (> count 0)
 558                            (pmail-next-undeleted-message 1))))
 559                     (num-appended (- orig-count count)))
 560                 (if (and (> count 0) (not next-message-p))
 561                     (error "Only %d message%s appended" num-appended
 562                            (if (= num-appended 1) "" "s"))))))
 563       (kill-buffer tembuf))))
 564
 565 \f
 566 ;;;###autoload
 567 (defun pmail-output-body-to-file (file-name)
 568   "Write this message body to the file FILE-NAME.
 569 FILE-NAME defaults, interactively, from the Subject field of the message."
 570   (interactive
 571    (let ((default-file
 572            (or (mail-fetch-field "Subject")
 573                pmail-default-body-file)))
 574      (list (setq pmail-default-body-file
 575                  (read-file-name
 576                   "Output message body to file: "
 577                   (and default-file (file-name-directory default-file))
 578                   default-file
 579                   nil default-file)))))
 580   (setq file-name
 581         (expand-file-name file-name
 582                           (and pmail-default-body-file
 583                                (file-name-directory pmail-default-body-file))))
 584   (save-excursion
 585     (goto-char (point-min))
 586     (search-forward "\n\n")
 587     (and (file-exists-p file-name)
 588          (not (y-or-n-p (format "File %s exists; overwrite? " file-name)))
 589          (error "Operation aborted"))
 590     (write-region (point) (point-max) file-name))
 591   (if pmail-delete-after-output
 592       (pmail-delete-forward)))
 593
 594 ;; Local Variables:
 595 ;; change-log-default-name: "ChangeLog.pmail"
 596 ;; End:
 597
 598 ;; arch-tag: 4059abf0-f249-4be4-8e0d-602d370d01d1
 599 ;;; pmailout.el ends here