home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / rmail / rmailout.el < prev    next >
Encoding:
Text File  |  1992-06-29  |  6.1 KB  |  164 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 (count 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. A prefix argument N says to output N consecutive messages
  31. starting with the current one.  Deleted messages are skipped and don't count."
  32.   (interactive (list (prefix-numeric-value current-prefix-arg)
  33.              (read-file-name
  34.               (concat "Output message to Rmail file: (default "
  35.                   (file-name-nondirectory rmail-last-rmail-file)
  36.                   ") ")
  37.               (file-name-directory rmail-last-rmail-file)
  38.               rmail-last-rmail-file)))
  39.   (setq file-name (expand-file-name file-name))
  40.   (setq rmail-last-rmail-file file-name)
  41.   (rmail-maybe-set-message-counters)
  42.   (or (get-file-buffer file-name)
  43.       (file-exists-p file-name)
  44.       (if (yes-or-no-p
  45.        (concat "\"" file-name "\" does not exist, create it? "))
  46.       (let ((file-buffer (create-file-buffer file-name)))
  47.         (save-excursion
  48.           (set-buffer file-buffer)
  49.           (rmail-insert-rmail-file-header)
  50.           (let ((require-final-newline nil))
  51.         (write-region (point-min) (point-max) file-name t 1)))
  52.         (kill-buffer file-buffer))
  53.     (error "Output file does not exist")))
  54.   (while (> count 0)
  55.     (let (redelete)
  56.       (unwind-protect
  57.       (progn
  58.         (save-restriction
  59.           (widen)
  60.           (if (rmail-message-deleted-p rmail-current-message)
  61.           (progn (setq redelete t)
  62.              (rmail-set-attribute "deleted" nil)))
  63.           ;; Decide whether to append to a file or to an Emacs buffer.
  64.           (save-excursion
  65.         (let ((buf (get-file-buffer file-name))
  66.               (cur (current-buffer))
  67.               (beg (1+ (rmail-msgbeg rmail-current-message)))
  68.               (end (1+ (rmail-msgend rmail-current-message))))
  69.           (if (not buf)
  70.               (append-to-file beg end file-name)
  71.             (if (eq buf (current-buffer))
  72.             (error "Can't output message to same file it's already in"))
  73.             ;; File has been visited, in buffer BUF.
  74.             (set-buffer buf)
  75.             (let ((buffer-read-only nil)
  76.               (msg (and (boundp 'rmail-current-message)
  77.                     rmail-current-message)))
  78.               ;; If MSG is non-nil, buffer is in RMAIL mode.
  79.               (if msg
  80.               (progn
  81.                 (rmail-maybe-set-message-counters)
  82.                 (widen)
  83.                 (narrow-to-region (point-max) (point-max))
  84.                 (insert-buffer-substring cur beg end)
  85.                 (goto-char (point-min))
  86.                 (widen)
  87.                 (search-backward "\n\^_")
  88.                 (narrow-to-region (point) (point-max))
  89.                 (rmail-count-new-messages t)
  90.                 (rmail-show-message msg))
  91.           ;; Output file not in rmail mode => just insert at the end.
  92.           (narrow-to-region (point-min) (1+ (buffer-size)))
  93.           (goto-char (point-max))
  94.           (insert-buffer-substring cur beg end)))))))
  95.         (rmail-set-attribute "filed" t))
  96.     (if redelete (rmail-set-attribute "deleted" t))))
  97.     (setq count (1- count))
  98.     (if rmail-delete-after-output
  99.     (rmail-delete-forward)
  100.       (if (> count 0)
  101.       (rmail-next-undeleted-message 1)))))
  102.  
  103. (defun rmail-output (count file-name)
  104.   "Append this message to Unix mail file named FILE-NAME.
  105. A prefix argument N says to output N consecutive messages
  106. starting with the current one.  Deleted messages are skipped and don't count."
  107.   (interactive
  108.    (list (prefix-numeric-value current-prefix-arg)
  109.      (read-file-name
  110.       (concat "Output message to Unix mail file"
  111.           (if rmail-last-file
  112.               (concat " (default "
  113.                   (file-name-nondirectory rmail-last-file)
  114.                   "): " )
  115.             ": "))            
  116.       (and rmail-last-file (file-name-directory rmail-last-file))
  117.       rmail-last-file)))
  118.   (setq file-name (expand-file-name file-name))
  119.   (setq rmail-last-file file-name)
  120.   (while (> count 0)
  121.     (let ((rmailbuf (current-buffer))
  122.       (tembuf (get-buffer-create " rmail-output"))
  123.       (case-fold-search t))
  124.       (save-excursion
  125.     (set-buffer tembuf)
  126.     (erase-buffer)
  127.     ;; If we can do it, read a little of the file
  128.     ;; to check whether it is an RMAIL file.
  129.     ;; If it is, don't mess it up.
  130.     (if (fboundp 'insert-partial-file-contents)
  131.         (progn
  132.           (insert-partial-file-contents file-name 0 20)
  133.           (if (looking-at "BABYL OPTIONS:\n")
  134.           (error (save-excursion
  135.                (set-buffer rmailbuf)
  136.                (substitute-command-keys
  137.                 "File %s is an RMAIL file; use the \\[rmail-output-to-rmail-file] command"))
  138.              file-name))
  139.           (erase-buffer)))
  140.     (insert-buffer-substring rmailbuf)
  141.     (insert "\n")
  142.     (goto-char (point-min))
  143.     (insert "From "
  144.         (mail-strip-quoted-names (or (mail-fetch-field "from")
  145.                          (mail-fetch-field "really-from")
  146.                          (mail-fetch-field "sender")
  147.                          "unknown"))
  148.         " " (current-time-string) "\n")
  149.     ;; ``Quote'' "\nFrom " as "\n>From "
  150.     ;;  (note that this isn't really quoting, as there is no requirement
  151.     ;;   that "\n[>]+From " be quoted in the same transparent way.)
  152.     (while (search-forward "\nFrom " nil t)
  153.       (forward-char -5)
  154.       (insert ?>))
  155.     (append-to-file (point-min) (point-max) file-name))
  156.       (kill-buffer tembuf))
  157.     (if (equal major-mode 'rmail-mode)
  158.     (rmail-set-attribute "filed" t))
  159.     (setq count (1- count))
  160.     (if rmail-delete-after-output
  161.     (rmail-delete-forward)
  162.       (if (> count 0)
  163.       (rmail-next-undeleted-message 1)))))
  164.