lisp/mail/undigest.el

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