home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 31 / CDASC_31_1996_juillet_aout.iso / vrac_os2 / e31el3.zip / EMACS / 19.31 / LISP / UNDIGEST.EL < prev    next >
Lisp/Scheme  |  1996-03-22  |  6KB  |  174 lines
  1. ;;; undigest.el --- digest-cracking support for the RMAIL mail reader
  2.  
  3. ;; Copyright (C) 1985, 1986, 1994, 1996 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 the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; See Internet RFC 934
  28.  
  29. ;;; Code:
  30.  
  31. (require 'rmail)
  32.  
  33. (defun undigestify-rmail-message ()
  34.   "Break up a digest message into its constituent messages.
  35. Leaves original message, deleted, before the undigestified messages."
  36.   (interactive)
  37.   (widen)
  38.   (let ((buffer-read-only nil)
  39.     (msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
  40.                       (rmail-msgend rmail-current-message))))
  41.     (goto-char (rmail-msgend rmail-current-message))
  42.     (narrow-to-region (point) (point))
  43.     (insert msg-string)
  44.     (narrow-to-region (point-min) (1- (point-max))))
  45.   (let ((error t)
  46.     (buffer-read-only nil))
  47.     (unwind-protect
  48.     (progn
  49.       (save-restriction
  50.         (goto-char (point-min))
  51.         (delete-region (point-min)
  52.                (progn (search-forward "\n*** EOOH ***\n")
  53.                   (point)))
  54.         (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  55.         (narrow-to-region (point)
  56.                   (point-max))
  57.         (let* ((fill-prefix "")
  58.            (case-fold-search t)
  59.            start
  60.            (digest-name
  61.             (mail-strip-quoted-names
  62.              (or (save-restriction
  63.                (search-forward "\n\n")
  64.                (setq start (point))
  65.                (narrow-to-region (point-min) (point))
  66.                (goto-char (point-max))
  67.                (or (mail-fetch-field "Reply-To")
  68.                    (mail-fetch-field "To")
  69.                    (mail-fetch-field "Apparently-To")
  70.                    (mail-fetch-field "From")))
  71.              (error "Message is not a digest--bad header")))))
  72.           (save-excursion
  73.         (goto-char (point-max))
  74.         (skip-chars-backward " \t\n")
  75.         (let (found)
  76.           ;; compensate for broken un*x digestifiers.  Sigh Sigh.
  77.           (while (and (> (point) start) (not found))
  78.             (forward-line -1)
  79.             (if (looking-at (concat "End of.*Digest.*\n"
  80.                         (regexp-quote "*********") "*"
  81.                         "\\(\n------*\\)*"))
  82.             (setq found t)))
  83.           (if (not found)
  84.               (error "Message is not a digest--no end line"))))
  85.           (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*"))
  86.           (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  87.           (save-restriction
  88.         (narrow-to-region (point)
  89.                   (progn (search-forward "\n\n")
  90.                      (point)))
  91.         (if (mail-fetch-field "To") nil
  92.           (goto-char (point-min))
  93.           (insert "To: " digest-name "\n")))
  94.           (while (re-search-forward
  95.               (concat "\n\n" (make-string 27 ?-) "-*\n*")
  96.               nil t)
  97.         (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  98.         (save-restriction
  99.           (if (looking-at "End ")
  100.               (insert "To: " digest-name "\n\n")
  101.             (narrow-to-region (point)
  102.                       (progn (search-forward "\n\n"
  103.                                  nil 'move)
  104.                          (point))))
  105.           (if (mail-fetch-field "To")
  106.               nil
  107.             (goto-char (point-min))
  108.             (insert "To: " digest-name "\n")))
  109.         ;; Digestifiers may insert `- ' on lines that start with `-'.
  110.         ;; Undo that.
  111.         (save-excursion
  112.           (goto-char (point-min))
  113.           (if (re-search-forward
  114.                "\n\n----------------------------*\n*"
  115.                nil t)
  116.               (let ((end (point-marker)))
  117.             (goto-char (point-min))
  118.             (while (re-search-forward "^- " end t)
  119.               (delete-char -2)))))
  120.         )))
  121.       (setq error nil)
  122.       (message "Message successfully undigestified")
  123.       (let ((n rmail-current-message))
  124.         (rmail-forget-messages)
  125.         (rmail-show-message n)
  126.         (rmail-delete-forward)
  127.         (if (rmail-summary-exists)
  128.         (rmail-select-summary
  129.          (rmail-update-summary)))))
  130.       (cond (error
  131.          (narrow-to-region (point-min) (1+ (point-max)))
  132.          (delete-region (point-min) (point-max))
  133.          (rmail-show-message rmail-current-message))))))
  134.  
  135. (defun unforward-rmail-message ()
  136.   "Extract a forwarded message from the containing message.
  137. This puts the forwarded message into a separate rmail message
  138. following the containing message."
  139.   (interactive)
  140.   (narrow-to-region (rmail-msgbeg rmail-current-message)
  141.             (rmail-msgend rmail-current-message))
  142.   (goto-char (point-min))
  143.   (let (beg end (buffer-read-only nil) msg-string who-forwarded-it)
  144.     (setq who-forwarded-it (mail-fetch-field "From"))
  145.     (if (re-search-forward "^----" nil t)
  146.     nil
  147.       (error "No forwarded message"))
  148.     (forward-line 1)
  149.     (setq beg (point))
  150.     (if (re-search-forward "^----" nil t)
  151.     (setq end (match-beginning 0))
  152.       (error "No terminator for forwarded message"))
  153.     (widen)
  154.     (setq msg-string (buffer-substring beg end))
  155.     (goto-char (rmail-msgend rmail-current-message))
  156.     (narrow-to-region (point) (point))
  157.     (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  158.     (narrow-to-region (point) (point))
  159.     (insert "Forwarded-by: " who-forwarded-it "\n")
  160.     (insert msg-string)
  161.     (goto-char (point-min))
  162.     (while (not (eobp))
  163.       (if (looking-at "- ")
  164.       (delete-region (point) (+ 2 (point))))
  165.       (forward-line 1))
  166.     (let ((n rmail-current-message))
  167.       (rmail-forget-messages)
  168.       (rmail-show-message n)
  169.       (if (rmail-summary-exists)
  170.       (rmail-select-summary
  171.        (rmail-update-summary))))))
  172.  
  173. ;;; undigest.el ends here
  174.