lisp/mail/rmailout.el

   1 ;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file.
   2
   3 ;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Code:
  25
  26 ;; Temporary until Emacs always has this variable.
  27 (defvar rmail-delete-after-output nil
  28   "*Non-nil means automatically delete a message that is copied to a file.")
  29
  30 (defvar rmail-output-file-alist nil
  31   "*Alist matching regexps to suggested output Rmail files.
  32 This is a list of elements of the form (REGEXP . FILENAME).")
  33
  34 ;;; There are functions elsewhere in Emacs that use this function; check
  35 ;;; them out before you change the calling method.
  36 (defun rmail-output-to-rmail-file (file-name &optional count)
  37   "Append the current message to an Rmail file named FILE-NAME.
  38 If the file does not exist, ask if it should be created.
  39 If file is being visited, the message is appended to the Emacs
  40 buffer visiting that file.
  41 A prefix argument N says to output N consecutive messages
  42 starting with the current one.  Deleted messages are skipped and don't count."
  43   (interactive
  44    (let ((default-file
  45            (let (answer tail)
  46              (setq tail rmail-output-file-alist)
  47              ;; Suggest a file based on a pattern match.
  48              (while (and tail (not answer))
  49                (save-excursion
  50                  (goto-char (point-min))
  51                  (if (re-search-forward (car (car tail)) nil t)
  52                      (setq answer (cdr (car tail))))
  53                  (setq tail (cdr tail))))
  54              ;; If not suggestions, use same file as last time.
  55              (or answer rmail-last-rmail-file))))
  56      (list (read-file-name
  57             (concat "Output message to Rmail file: (default "
  58                     (file-name-nondirectory default-file)
  59                     ") ")
  60             (file-name-directory rmail-last-rmail-file)
  61             default-file)
  62            (prefix-numeric-value current-prefix-arg))))
  63   (or count (setq count 1))
  64   (setq file-name
  65         (expand-file-name file-name
  66                           (file-name-directory rmail-last-rmail-file)))
  67   (setq rmail-last-rmail-file file-name)
  68   (rmail-maybe-set-message-counters)
  69   (setq file-name (abbreviate-file-name file-name))
  70   (or (get-file-buffer file-name)
  71       (file-exists-p file-name)
  72       (if (yes-or-no-p
  73            (concat "\"" file-name "\" does not exist, create it? "))
  74           (let ((file-buffer (create-file-buffer file-name)))
  75             (save-excursion
  76               (set-buffer file-buffer)
  77               (rmail-insert-rmail-file-header)
  78               (let ((require-final-newline nil))
  79                 (write-region (point-min) (point-max) file-name t 1)))
  80             (kill-buffer file-buffer))
  81         (error "Output file does not exist")))
  82   (while (> count 0)
  83     (let (redelete)
  84       (unwind-protect
  85           (progn
  86             (save-restriction
  87               (widen)
  88               (if (rmail-message-deleted-p rmail-current-message)
  89                   (progn (setq redelete t)
  90                          (rmail-set-attribute "deleted" nil)))
  91               ;; Decide whether to append to a file or to an Emacs buffer.
  92               (save-excursion
  93                 (let ((buf (get-file-buffer file-name))
  94                       (cur (current-buffer))
  95                       (beg (1+ (rmail-msgbeg rmail-current-message)))
  96                       (end (1+ (rmail-msgend rmail-current-message))))
  97                   (if (not buf)
  98                       (append-to-file beg end file-name)
  99                     (if (eq buf (current-buffer))
 100                         (error "Can't output message to same file it's already in"))
 101                     ;; File has been visited, in buffer BUF.
 102                     (set-buffer buf)
 103                     (let ((buffer-read-only nil)
 104                           (msg (and (boundp 'rmail-current-message)
 105                                     rmail-current-message)))
 106                       ;; If MSG is non-nil, buffer is in RMAIL mode.
 107                       (if msg
 108                           (progn
 109                             (rmail-maybe-set-message-counters)
 110                             (widen)
 111                             (narrow-to-region (point-max) (point-max))
 112                             (insert-buffer-substring cur beg end)
 113                             (goto-char (point-min))
 114                             (widen)
 115                             (search-backward "\n\^_")
 116                             (narrow-to-region (point) (point-max))
 117                             (rmail-count-new-messages t)
 118                             (rmail-show-message msg))
 119               ;; Output file not in rmail mode => just insert at the end.
 120               (narrow-to-region (point-min) (1+ (buffer-size)))
 121               (goto-char (point-max))
 122               (insert-buffer-substring cur beg end)))))))
 123             (rmail-set-attribute "filed" t))
 124         (if redelete (rmail-set-attribute "deleted" t))))
 125     (setq count (1- count))
 126     (if rmail-delete-after-output
 127         (rmail-delete-forward)
 128       (if (> count 0)
 129           (rmail-next-undeleted-message 1)))))
 130
 131 ;;; There are functions elsewhere in Emacs that use this function; check
 132 ;;; them out before you change the calling method.
 133 (defun rmail-output (file-name &optional count)
 134   "Append this message to Unix mail file named FILE-NAME.
 135 A prefix argument N says to output N consecutive messages
 136 starting with the current one.  Deleted messages are skipped and don't count.
 137 When called from lisp code, N may be omitted."
 138   (interactive
 139    (list (read-file-name
 140           (concat "Output message to Unix mail file"
 141                   (if rmail-last-file
 142                       (concat " (default "
 143                               (file-name-nondirectory rmail-last-file)
 144                               "): " )
 145                     ": "))
 146           (and rmail-last-file (file-name-directory rmail-last-file))
 147           rmail-last-file)
 148          (prefix-numeric-value current-prefix-arg)))
 149   (or count (setq count 1))
 150   (setq file-name
 151         (expand-file-name file-name
 152                           (and rmail-last-file
 153                                (file-name-directory rmail-last-file))))
 154   (setq rmail-last-file file-name)
 155   (while (> count 0)
 156     (let ((rmailbuf (current-buffer))
 157           (tembuf (get-buffer-create " rmail-output"))
 158           (case-fold-search t))
 159       (save-excursion
 160         (set-buffer tembuf)
 161         (erase-buffer)
 162         ;; If we can do it, read a little of the file
 163         ;; to check whether it is an RMAIL file.
 164         ;; If it is, don't mess it up.
 165         (insert-file-contents file-name nil 0 20)
 166         (if (looking-at "BABYL OPTIONS:\n")
 167             (error (save-excursion
 168                      (set-buffer rmailbuf)
 169                      (substitute-command-keys
 170                       "Use \\[rmail-output-to-rmail-file] to output to Rmail file `%s'"))
 171                    (file-name-nondirectory file-name)))
 172         (erase-buffer)
 173         (insert-buffer-substring rmailbuf)
 174         (insert "\n")
 175         (goto-char (point-min))
 176         (insert "From "
 177                 (mail-strip-quoted-names (or (mail-fetch-field "from")
 178                                              (mail-fetch-field "really-from")
 179                                              (mail-fetch-field "sender")
 180                                              "unknown"))
 181                 " " (current-time-string) "\n")
 182         ;; ``Quote'' "\nFrom " as "\n>From "
 183         ;;  (note that this isn't really quoting, as there is no requirement
 184         ;;   that "\n[>]+From " be quoted in the same transparent way.)
 185         (while (search-forward "\nFrom " nil t)
 186           (forward-char -5)
 187           (insert ?>))
 188         (append-to-file (point-min) (point-max) file-name))
 189       (kill-buffer tembuf))
 190     (if (equal major-mode 'rmail-mode)
 191         (rmail-set-attribute "filed" t))
 192     (setq count (1- count))
 193     (if rmail-delete-after-output
 194         (rmail-delete-forward)
 195       (if (> count 0)
 196           (rmail-next-undeleted-message 1)))))
 197
 198 ;;; rmailout.el ends here