home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / emacs-18.59-bin.lha / lib / emacs / 18.59 / lisp / rmailout.el < prev    next >
Lisp/Scheme  |  1991-02-09  |  5KB  |  127 lines
  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. (defun rmail-output-to-rmail-file (file-name)
  26.   "Append the current message to an Rmail file named FILE-NAME.
  27. If the file does not exist, ask if it should be created.
  28. If file is being visited, the message is appended to the Emacs
  29. buffer visiting that file."
  30.   (interactive (list (read-file-name
  31.               (concat "Output message to Rmail file: (default "
  32.                   (file-name-nondirectory rmail-last-rmail-file)
  33.                   ") ")
  34.               (file-name-directory rmail-last-rmail-file)
  35.               rmail-last-rmail-file)))
  36.   (setq file-name (expand-file-name file-name))
  37.   (setq rmail-last-rmail-file file-name)
  38.   (rmail-maybe-set-message-counters)
  39.   (or (get-file-buffer file-name)
  40.       (file-exists-p file-name)
  41.       (if (yes-or-no-p
  42.        (concat "\"" file-name "\" does not exist, create it? "))
  43.       (let ((file-buffer (create-file-buffer file-name)))
  44.         (save-excursion
  45.           (set-buffer file-buffer)
  46.           (rmail-insert-rmail-file-header)
  47.           (let ((require-final-newline nil))
  48.         (write-region (point-min) (point-max) file-name t 1)))
  49.         (kill-buffer file-buffer))
  50.     (error "Output file does not exist")))
  51.   (save-restriction
  52.     (widen)
  53.     ;; Decide whether to append to a file or to an Emacs buffer.
  54.     (save-excursion
  55.       (let ((buf (get-file-buffer file-name))
  56.         (cur (current-buffer))
  57.         (beg (1+ (rmail-msgbeg rmail-current-message)))
  58.         (end (1+ (rmail-msgend rmail-current-message))))
  59.     (if (not buf)
  60.         (append-to-file beg end file-name)
  61.       (if (eq buf (current-buffer))
  62.           (error "Can't output message to same file it's already in"))
  63.       ;; File has been visited, in buffer BUF.
  64.       (set-buffer buf)
  65.       (let ((buffer-read-only nil)
  66.         (msg (and (boundp 'rmail-current-message)
  67.               rmail-current-message)))
  68.         ;; If MSG is non-nil, buffer is in RMAIL mode.
  69.         (if msg
  70.         (rmail-maybe-set-message-counters))
  71.         (widen)
  72.         (narrow-to-region (point-max) (point-max))
  73.         (insert-buffer-substring cur beg end)
  74.         (if msg
  75.         (progn
  76.           (goto-char (point-min))
  77.           (widen)
  78.           (search-backward "\^_")
  79.           (narrow-to-region (point) (point-max))
  80.           (goto-char (1+ (point-min)))
  81.           (rmail-count-new-messages t)
  82.           (rmail-show-message msg))))))))
  83.   (rmail-set-attribute "filed" t)
  84.   (and rmail-delete-after-output (rmail-delete-forward)))
  85.  
  86. (defun rmail-output (file-name)
  87.   "Append this message to Unix mail file named FILE-NAME."
  88.   (interactive
  89.    (list
  90.     (read-file-name
  91.      (concat "Output message to Unix mail file"
  92.          (if rmail-last-file
  93.          (concat " (default "
  94.              (file-name-nondirectory rmail-last-file)
  95.              "): " )
  96.            ": "))            
  97.      (and rmail-last-file (file-name-directory rmail-last-file))
  98.      rmail-last-file)))
  99.   (setq file-name (expand-file-name file-name))
  100.   (setq rmail-last-file file-name)
  101.   (let ((rmailbuf (current-buffer))
  102.     (tembuf (get-buffer-create " rmail-output"))
  103.     (case-fold-search t))
  104.     (save-excursion
  105.       (set-buffer tembuf)
  106.       (erase-buffer)
  107.       (insert-buffer-substring rmailbuf)
  108.       (insert "\n")
  109.       (goto-char (point-min))
  110.       (insert "From "
  111.           (if (mail-fetch-field "from")
  112.           (mail-strip-quoted-names (mail-fetch-field "from"))
  113.         "unknown")
  114.           " " (current-time-string) "\n")
  115.       ;; ``Quote'' "\nFrom " as "\n>From "
  116.       ;;  (note that this isn't really quoting, as there is no requirement
  117.       ;;   that "\n[>]+From " be quoted in the same transparent way.)
  118.       (while (search-forward "\nFrom " nil t)
  119.     (forward-char -5)
  120.     (insert ?>))
  121.       (append-to-file (point-min) (point-max) file-name))
  122.     (kill-buffer tembuf))
  123.   (if (equal major-mode 'rmail-mode)
  124.       (progn
  125.     (rmail-set-attribute "filed" t)
  126.     (and rmail-delete-after-output (rmail-delete-forward)))))
  127.