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 / undigest.el < prev    next >
Encoding:
Text File  |  1992-06-29  |  3.7 KB  |  106 lines
  1. ;; "RMAIL" mail reader for Emacs.
  2. ;; Copyright (C) 1985, 1986 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. ;; note Interent RFP934
  21.  
  22. (defun undigestify-rmail-message ()
  23.   "Break up a digest message into its constituent messages.
  24. Leaves original message, deleted, before the undigestified messages."
  25.   (interactive)
  26.   (widen)
  27.   (let ((buffer-read-only nil)
  28.     (msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
  29.                       (rmail-msgend rmail-current-message))))
  30.     (goto-char (rmail-msgend rmail-current-message))
  31.     (narrow-to-region (point) (point))
  32.     (insert msg-string)
  33.     (narrow-to-region (point-min) (1- (point-max))))
  34.   (let ((error t)
  35.     (buffer-read-only nil))
  36.     (unwind-protect
  37.     (progn
  38.       (save-restriction
  39.         (goto-char (point-min))
  40.         (delete-region (point-min)
  41.                (progn (search-forward "\n*** EOOH ***\n")
  42.                   (point)))
  43.         (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  44.         (narrow-to-region (point)
  45.                   (point-max))
  46.         (let* ((fill-prefix "")
  47.            (case-fold-search t)
  48.            (digest-name
  49.             (mail-strip-quoted-names
  50.              (or (save-restriction
  51.                (search-forward "\n\n")
  52.                (narrow-to-region (point-min) (point))
  53.                (goto-char (point-max))
  54.                (or (mail-fetch-field "Reply-To")
  55.                    (mail-fetch-field "To")
  56.                    (mail-fetch-field "Apparently-To")
  57.                    (mail-fetch-field "From")))
  58.              (error "Message is not a digest")))))
  59.           (save-excursion
  60.         (goto-char (point-max))
  61.         (skip-chars-backward " \t\n")
  62.         (let ((count 10) found)
  63.           ;; compensate for broken un*x digestifiers.  Sigh Sigh.
  64.           (while (and (> count 0) (not found))
  65.             (forward-line -1)
  66.             (setq count (1- count))
  67.             (if (looking-at (concat "End of.*Digest.*\n"
  68.                         (regexp-quote "*********") "*"
  69.                         "\\(\n------*\\)*"))
  70.             (setq found t)))
  71.           (if (not found) (error "Message is not a digest"))))
  72.           (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*"))
  73.           (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  74.           (save-restriction
  75.         (narrow-to-region (point)
  76.                   (progn (search-forward "\n\n")
  77.                      (point)))
  78.         (if (mail-fetch-field "To") nil
  79.           (goto-char (point-min))
  80.           (insert "To: " digest-name "\n")))
  81.           (while (re-search-forward
  82.               (concat "\n\n" (make-string 27 ?-) "-*\n*")
  83.               nil t)
  84.         (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  85.         (save-restriction
  86.           (if (looking-at "End ")
  87.               (insert "To: " digest-name "\n\n")
  88.             (narrow-to-region (point)
  89.                       (progn (search-forward "\n\n"
  90.                                  nil 'move)
  91.                          (point))))
  92.           (if (mail-fetch-field "To") nil
  93.             (goto-char (point-min))
  94.             (insert "To: " digest-name "\n"))))))
  95.       (setq error nil)
  96.       (message "Message successfully undigestified")
  97.       (let ((n rmail-current-message))
  98.         (rmail-forget-messages)
  99.         (rmail-show-message n)
  100.         (rmail-delete-forward)))
  101.       (cond (error
  102.          (narrow-to-region (point-min) (1+ (point-max)))
  103.          (delete-region (point-min) (point-max))
  104.          (rmail-show-message rmail-current-message))))))
  105.  
  106.