home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / emacs-19.28-src.tgz / tar.out / fsf / emacs / lisp / undigest.el < prev    next >
Lisp/Scheme  |  1996-09-28  |  4KB  |  120 lines
  1. ;;; undigest.el --- digest-cracking support for the RMAIL mail reader
  2.  
  3. ;; Copyright (C) 1985, 1986, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;; See Internet RFC 934
  27.  
  28. ;;; Code:
  29.  
  30. (require 'rmail)
  31.  
  32. (defun undigestify-rmail-message ()
  33.   "Break up a digest message into its constituent messages.
  34. Leaves original message, deleted, before the undigestified messages."
  35.   (interactive)
  36.   (widen)
  37.   (let ((buffer-read-only nil)
  38.     (msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
  39.                       (rmail-msgend rmail-current-message))))
  40.     (goto-char (rmail-msgend rmail-current-message))
  41.     (narrow-to-region (point) (point))
  42.     (insert msg-string)
  43.     (narrow-to-region (point-min) (1- (point-max))))
  44.   (let ((error t)
  45.     (buffer-read-only nil))
  46.     (unwind-protect
  47.     (progn
  48.       (save-restriction
  49.         (goto-char (point-min))
  50.         (delete-region (point-min)
  51.                (progn (search-forward "\n*** EOOH ***\n")
  52.                   (point)))
  53.         (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  54.         (narrow-to-region (point)
  55.                   (point-max))
  56.         (let* ((fill-prefix "")
  57.            (case-fold-search t)
  58.            (digest-name
  59.             (mail-strip-quoted-names
  60.              (or (save-restriction
  61.                (search-forward "\n\n")
  62.                (narrow-to-region (point-min) (point))
  63.                (goto-char (point-max))
  64.                (or (mail-fetch-field "Reply-To")
  65.                    (mail-fetch-field "To")
  66.                    (mail-fetch-field "Apparently-To")
  67.                    (mail-fetch-field "From")))
  68.              (error "Message is not a digest")))))
  69.           (save-excursion
  70.         (goto-char (point-max))
  71.         (skip-chars-backward " \t\n")
  72.         (let ((count 10) found)
  73.           ;; compensate for broken un*x digestifiers.  Sigh Sigh.
  74.           (while (and (> count 0) (not found))
  75.             (forward-line -1)
  76.             (setq count (1- count))
  77.             (if (looking-at (concat "End of.*Digest.*\n"
  78.                         (regexp-quote "*********") "*"
  79.                         "\\(\n------*\\)*"))
  80.             (setq found t)))
  81.           (if (not found) (error "Message is not a digest"))))
  82.           (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*"))
  83.           (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  84.           (save-restriction
  85.         (narrow-to-region (point)
  86.                   (progn (search-forward "\n\n")
  87.                      (point)))
  88.         (if (mail-fetch-field "To") nil
  89.           (goto-char (point-min))
  90.           (insert "To: " digest-name "\n")))
  91.           (while (re-search-forward
  92.               (concat "\n\n" (make-string 27 ?-) "-*\n*")
  93.               nil t)
  94.         (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  95.         (save-restriction
  96.           (if (looking-at "End ")
  97.               (insert "To: " digest-name "\n\n")
  98.             (narrow-to-region (point)
  99.                       (progn (search-forward "\n\n"
  100.                                  nil 'move)
  101.                          (point))))
  102.           (if (mail-fetch-field "To") nil
  103.             (goto-char (point-min))
  104.             (insert "To: " digest-name "\n"))))))
  105.       (setq error nil)
  106.       (message "Message successfully undigestified")
  107.       (let ((n rmail-current-message))
  108.         (rmail-forget-messages)
  109.         (rmail-show-message n)
  110.         (rmail-delete-forward)
  111.         (if (rmail-summary-exists)
  112.         (rmail-select-summary
  113.          (rmail-update-summary)))))
  114.       (cond (error
  115.          (narrow-to-region (point-min) (1+ (point-max)))
  116.          (delete-region (point-min) (point-max))
  117.          (rmail-show-message rmail-current-message))))))
  118.  
  119. ;;; undigest.el ends here
  120.