| 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 | |