lisp/mail/rmailout.el

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