lisp/mail/rmailout.el

   1 ;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file.
   2
   3 ;; Maintainer: FSF
   4 ;; Last-Modified: 01 Mar 1991
   5
   6 ;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
   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 (defun rmail-output-to-rmail-file (count file-name)
  35   "Append the current message to an Rmail file named FILE-NAME.
  36 If the file does not exist, ask if it should be created.
  37 If file is being visited, the message is appended to the Emacs
  38 buffer visiting that file.
  39 A prefix argument N says to output N consecutive messages
  40 starting with the current one.  Deleted messages are skipped and don't count."
  41   (interactive (list (prefix-numeric-value current-prefix-arg)
  42                      (read-file-name
  43                       (concat "Output message to Rmail file: (default "
  44                               (file-name-nondirectory rmail-last-rmail-file)
  45                               ") ")
  46                       (file-name-directory rmail-last-rmail-file)
  47                       (let (answer tail)
  48                         (setq tail rmail-output-file-alist)
  49                         ;; Suggest a file based on a pattern match.
  50                         (while (and tail (not answer))
  51                           (save-excursion
  52                             (goto-char (point-min))
  53                             (if (re-search-forward (car (car tail)) nil t)
  54                                 (setq answer (cdr (car tail))))
  55                             (setq tail (cdr tail))))
  56                         ;; If not suggestions, use same file as last time.
  57                         (or answer rmail-last-rmail-file)))))
  58   (setq file-name
  59         (expand-file-name file-name
  60                           (file-name-directory rmail-last-rmail-file)))
  61   (setq rmail-last-rmail-file file-name)
  62   (rmail-maybe-set-message-counters)
  63   (or (get-file-buffer file-name)
  64       (file-exists-p file-name)
  65       (if (yes-or-no-p
  66            (concat "\"" file-name "\" does not exist, create it? "))
  67           (let ((file-buffer (create-file-buffer file-name)))
  68             (save-excursion
  69               (set-buffer file-buffer)
  70               (rmail-insert-rmail-file-header)
  71               (let ((require-final-newline nil))
  72                 (write-region (point-min) (point-max) file-name t 1)))
  73             (kill-buffer file-buffer))
  74         (error "Output file does not exist")))
  75   (while (> count 0)
  76     (let (redelete)
  77       (unwind-protect
  78           (progn
  79             (save-restriction
  80               (widen)
  81               (if (rmail-message-deleted-p rmail-current-message)
  82                   (progn (setq redelete t)
  83                          (rmail-set-attribute "deleted" nil)))
  84               ;; Decide whether to append to a file or to an Emacs buffer.
  85               (save-excursion
  86                 (let ((buf (get-file-buffer file-name))
  87                       (cur (current-buffer))
  88                       (beg (1+ (rmail-msgbeg rmail-current-message)))
  89                       (end (1+ (rmail-msgend rmail-current-message))))
  90                   (if (not buf)
  91                       (append-to-file beg end file-name)
  92                     (if (eq buf (current-buffer))
  93                         (error "Can't output message to same file it's already in"))
  94                     ;; File has been visited, in buffer BUF.
  95                     (set-buffer buf)
  96                     (let ((buffer-read-only nil)
  97                           (msg (and (boundp 'rmail-current-message)
  98                                     rmail-current-message)))
  99                       ;; If MSG is non-nil, buffer is in RMAIL mode.
 100                       (if msg
 101                           (progn
 102                             (rmail-maybe-set-message-counters)
 103                             (widen)
 104                             (narrow-to-region (point-max) (point-max))
 105                             (insert-buffer-substring cur beg end)
 106                             (goto-char (point-min))
 107                             (widen)
 108                             (search-backward "\n\^_")
 109                             (narrow-to-region (point) (point-max))
 110                             (rmail-count-new-messages t)
 111                             (rmail-show-message msg))
 112               ;; Output file not in rmail mode => just insert at the end.
 113               (narrow-to-region (point-min) (1+ (buffer-size)))
 114               (goto-char (point-max))
 115               (insert-buffer-substring cur beg end)))))))
 116             (rmail-set-attribute "filed" t))
 117         (if redelete (rmail-set-attribute "deleted" t))))
 118     (setq count (1- count))
 119     (if rmail-delete-after-output
 120         (rmail-delete-forward)
 121       (if (> count 0)
 122           (rmail-next-undeleted-message 1)))))
 123
 124 (defun rmail-output (count file-name)
 125   "Append this message to Unix mail file named FILE-NAME.
 126 A prefix argument N says to output N consecutive messages
 127 starting with the current one.  Deleted messages are skipped and don't count."
 128   (interactive
 129    (list (prefix-numeric-value current-prefix-arg)
 130          (read-file-name
 131           (concat "Output message to Unix mail file"
 132                   (if rmail-last-file
 133                       (concat " (default "
 134                               (file-name-nondirectory rmail-last-file)
 135                               "): " )
 136                     ": "))
 137           (and rmail-last-file (file-name-directory rmail-last-file))
 138           rmail-last-file)))
 139   (setq file-name
 140         (expand-file-name file-name
 141                           (and rmail-last-file
 142                                (file-name-directory rmail-last-file))))
 143   (setq rmail-last-file file-name)
 144   (while (> count 0)
 145     (let ((rmailbuf (current-buffer))
 146           (tembuf (get-buffer-create " rmail-output"))
 147           (case-fold-search t))
 148       (save-excursion
 149         (set-buffer tembuf)
 150         (erase-buffer)
 151         ;; If we can do it, read a little of the file
 152         ;; to check whether it is an RMAIL file.
 153         ;; If it is, don't mess it up.
 154         (if (fboundp 'insert-partial-file-contents)
 155             (progn
 156               (insert-partial-file-contents file-name 0 20)
 157               (if (looking-at "BABYL OPTIONS:\n")
 158                   (error (save-excursion
 159                            (set-buffer rmailbuf)
 160                            (substitute-command-keys
 161                             "File %s is an RMAIL file; use the \\[rmail-output-to-rmail-file] command"))
 162                          file-name))
 163               (erase-buffer)))
 164         (insert-buffer-substring rmailbuf)
 165         (insert "\n")
 166         (goto-char (point-min))
 167         (insert "From "
 168                 (mail-strip-quoted-names (or (mail-fetch-field "from")
 169                                              (mail-fetch-field "really-from")
 170                                              (mail-fetch-field "sender")
 171                                              "unknown"))
 172                 " " (or (mail-fetch-field "date") (current-time-string)) "\n")
 173         ;; ``Quote'' "\nFrom " as "\n>From "
 174         ;;  (note that this isn't really quoting, as there is no requirement
 175         ;;   that "\n[>]+From " be quoted in the same transparent way.)
 176         (while (search-forward "\nFrom " nil t)
 177           (forward-char -5)
 178           (insert ?>))
 179         (append-to-file (point-min) (point-max) file-name))
 180       (kill-buffer tembuf))
 181     (if (equal major-mode 'rmail-mode)
 182         (rmail-set-attribute "filed" t))
 183     (setq count (1- count))
 184     (if rmail-delete-after-output
 185         (rmail-delete-forward)
 186       (if (> count 0)
 187           (rmail-next-undeleted-message 1)))))
 188
 189 ;;; rmailout.el ends here