home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / NeXT / GnuSource / emacs-15.0.3 / lisp / rmailout.el < prev    next >
Lisp/Scheme  |  1990-07-19  |  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 distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20.  
  21.  
  22. ;; Temporary until Emacs always has this variable.
  23. (defvar rmail-delete-after-output nil
  24.   "*Non-nil means automatically delete a message that is copied to a file.")
  25.  
  26. (defun rmail-output-to-rmail-file (file-name)
  27.   "Append the current message to an Rmail file named FILE-NAME.
  28. If the file does not exist, ask if it should be created.
  29. If file is being visited, the message is appended to the Emacs
  30. buffer visiting that file."
  31.   (interactive (list (read-file-name
  32.               (concat "Output message to Rmail file: (default "
  33.                   (file-name-nondirectory rmail-last-rmail-file)
  34.                   ") ")
  35.               (file-name-directory rmail-last-rmail-file)
  36.               rmail-last-rmail-file)))
  37.   (setq file-name (expand-file-name file-name))
  38.   (setq rmail-last-rmail-file file-name)
  39.   (rmail-maybe-set-message-counters)
  40.   (or (get-file-buffer file-name)
  41.       (file-exists-p file-name)
  42.       (if (yes-or-no-p
  43.        (concat "\"" file-name "\" does not exist, create it? "))
  44.       (let ((file-buffer (create-file-buffer file-name)))
  45.         (save-excursion
  46.           (set-buffer file-buffer)
  47.           (rmail-insert-rmail-file-header)
  48.           (let ((require-final-newline nil))
  49.         (write-region (point-min) (point-max) file-name t 1)))
  50.         (kill-buffer file-buffer))
  51.     (error "Output file does not exist")))
  52.   (save-restriction
  53.     (widen)
  54.     ;; Decide whether to append to a file or to an Emacs buffer.
  55.     (save-excursion
  56.       (let ((buf (get-file-buffer file-name))
  57.         (cur (current-buffer))
  58.         (beg (1+ (rmail-msgbeg rmail-current-message)))
  59.         (end (1+ (rmail-msgend rmail-current-message))))
  60.     (if (not buf)
  61.         (append-to-file beg end file-name)
  62.       (if (eq buf (current-buffer))
  63.           (error "Can't output message to same file it's already in"))
  64.       ;; File has been visited, in buffer BUF.
  65.       (set-buffer buf)
  66.       (let ((buffer-read-only nil)
  67.         (msg (and (boundp 'rmail-current-message)
  68.               rmail-current-message)))
  69.         ;; If MSG is non-nil, buffer is in RMAIL mode.
  70.         (if msg
  71.         (progn (rmail-maybe-set-message-counters)
  72.                (widen)
  73.                (narrow-to-region (point-max) (point-max))))
  74.         (insert-buffer-substring cur beg end)
  75.         (if msg
  76.         (progn
  77.           (goto-char (point-min))
  78.           (widen)
  79.           (search-backward "\^_")
  80.           (narrow-to-region (point) (point-max))
  81.           (goto-char (1+ (point-min)))
  82.           (rmail-count-new-messages t)
  83.           (rmail-show-message msg))))))))
  84.   (rmail-set-attribute "filed" t)
  85.   (and rmail-delete-after-output (rmail-delete-forward)))
  86.  
  87. (defun rmail-output (file-name)
  88.   "Append this message to Unix mail file named FILE-NAME."
  89.   (interactive
  90.    (list
  91.     (read-file-name
  92.      (concat "Output message to Unix mail file"
  93.          (if rmail-last-file
  94.          (concat " (default "
  95.              (file-name-nondirectory rmail-last-file)
  96.              "): " )
  97.            ": "))            
  98.      (and rmail-last-file (file-name-directory rmail-last-file))
  99.      rmail-last-file)))
  100.   (setq file-name (expand-file-name file-name))
  101.   (setq rmail-last-file file-name)
  102.   (let ((rmailbuf (current-buffer))
  103.     (tembuf (get-buffer-create " rmail-output"))
  104.     (case-fold-search t))
  105.     (save-excursion
  106.       (set-buffer tembuf)
  107.       (erase-buffer)
  108.       (insert-buffer-substring rmailbuf)
  109.       (insert "\n")
  110.       (goto-char (point-min))
  111.       (insert "From "
  112.           (or (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.