home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-digest.el < prev    next >
Encoding:
Text File  |  1995-08-18  |  16.1 KB  |  426 lines
  1. ;;; Message encapsulation
  2. ;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-digest)
  19.  
  20. (defun vm-no-frills-encapsulate-message (m keep-list discard-regexp)
  21.   "Encapsulate a message M for forwarding, simply.
  22. No message encapsulation standard is used.  The message is
  23. inserted at point in the current buffer, surrounded by two dashed
  24. start/end separator lines.  Point is not moved.
  25.  
  26. M should be a message struct for a real message, not a virtual message.
  27. This is the message that will be encapsulated.
  28. KEEP-LIST should be a list of regexps matching headers to keep.
  29. DISCARD-REGEXP should be a regexp that matches headers to be discarded.
  30. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
  31. to be forwarded.  See the docs for vm-reorder-message-headers
  32. to find out how KEEP-LIST and DISCARD-REGEXP are used."
  33.   (let ((target-buffer (current-buffer))
  34.     source-buffer)
  35.     (save-restriction
  36.       ;; narrow to a zero length region to avoid interacting
  37.       ;; with anything that might have already been inserted
  38.       ;; into the buffer.
  39.       (narrow-to-region (point) (point))
  40.       (insert "------- start of forwarded message -------\n")
  41.       (setq source-buffer (vm-buffer-of m))
  42.       (save-excursion
  43.     (set-buffer source-buffer)
  44.     (save-restriction
  45.       (widen)
  46.       (save-excursion
  47.         (set-buffer target-buffer)
  48.         (let ((beg (point)))
  49.           (insert-buffer-substring source-buffer (vm-headers-of m)
  50.                        (vm-text-end-of m))
  51.           (goto-char beg)
  52.           (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)")
  53.           (vm-reorder-message-headers nil keep-list discard-regexp)))))
  54.       (goto-char (point-max))
  55.       (insert "------- end of forwarded message -------\n"))))
  56.  
  57. (defun vm-rfc934-char-stuff-region (start end)
  58.   "Quote RFC 934 message separators between START and END.
  59. START and END are buffer positions in the current buffer.
  60. Lines beginning with `-' in the region have `- ' prepended to them."
  61.   (setq end (vm-marker end))
  62.   (save-excursion
  63.     (goto-char start)
  64.     (while (and (< (point) end) (re-search-forward "^-" end t))
  65.       (replace-match "- -" t t)))
  66.   (set-marker end nil))
  67.  
  68. (defun vm-rfc934-char-unstuff-region (start end)
  69.   "Unquote lines in between START and END as per RFC 934.
  70. START and END are buffer positions in the current buffer.
  71. Lines beginning with `- ' in the region have that string stripped
  72. from them."
  73.   (setq end (vm-marker end))
  74.   (save-excursion
  75.     (goto-char start)
  76.     (while (and (< (point) end) (re-search-forward "^- "  end t))
  77.       (replace-match "" t t)
  78.       (forward-char)))
  79.   (set-marker end nil))
  80.  
  81. (defun vm-rfc934-encapsulate-messages (message-list keep-list discard-regexp)
  82.   "Encapsulate the messages in MESSAGE-LIST as per RFC 934.
  83. The resulting digest is inserted at point in the current buffer.
  84. Point is not moved.
  85.  
  86. MESSAGE-LIST should be a list of message structs (real or virtual).
  87. These are the messages that will be encapsulated.
  88. KEEP-LIST should be a list of regexps matching headers to keep.
  89. DISCARD-REGEXP should be a regexp that matches headers to be discarded.
  90. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
  91. to be forwarded.  See the docs for vm-reorder-message-headers
  92. to find out how KEEP-LIST and DISCARD-REGEXP are used."
  93.   (if message-list
  94.       (let ((target-buffer (current-buffer))
  95.         (mlist message-list)
  96.         source-buffer m start n)
  97.     (save-restriction
  98.       ;; narrow to a zero length region to avoid interacting
  99.       ;; with anything that might have already been inserted
  100.       ;; into the buffer.
  101.       (narrow-to-region (point) (point))
  102.       (setq start (point))
  103.       (while mlist
  104.         (insert "---------------\n")
  105.         (setq m (vm-real-message-of (car mlist))
  106.           source-buffer (vm-buffer-of m))
  107.         (save-excursion
  108.           (set-buffer source-buffer)
  109.           (save-restriction
  110.         (widen)
  111.         (save-excursion
  112.           (set-buffer target-buffer)
  113.           (let ((beg (point)))
  114.             (insert-buffer-substring source-buffer (vm-headers-of m)
  115.                          (vm-text-end-of m))
  116.             (goto-char beg)
  117.             (vm-reorder-message-headers nil nil
  118.                         "\\(X-VM-\\|Status:\\)")
  119.             (vm-reorder-message-headers nil keep-list discard-regexp)
  120.             (vm-rfc934-char-stuff-region beg (point-max))))))
  121.         (goto-char (point-max))
  122.         (insert "---------------")
  123.         (setq mlist (cdr mlist)))
  124.       (delete-region (point) (progn (beginning-of-line) (point)))
  125.       (insert "------- end -------\n")
  126.       (goto-char start)
  127.       (delete-region (point) (progn (forward-line 1) (point)))
  128.       (setq n (length message-list))
  129.    (insert (format "------- start of %s%s(RFC 934 encapsulation) -------\n"
  130.               (if (cdr message-list)
  131.                   "digest "
  132.                 "forwarded message ")
  133.               (if (cdr message-list)
  134.                   (format "(%d messages) " n)
  135.                 "")))
  136.       (goto-char start)))))
  137.  
  138. (defun vm-rfc1153-char-stuff-region (start end)
  139.   "Quote RFC 1153 message separators between START and END.
  140. START and END are buffer positions in the current buffer.
  141. Lines consisting only of 30 hyphens have the first hyphen
  142. converted to a space."
  143.   (setq end (vm-marker end))
  144.   (save-excursion
  145.     (goto-char start)
  146.     (while (and (< (point) end)
  147.         (re-search-forward "^------------------------------$" end t))
  148.       (replace-match " -----------------------------" t t)))
  149.   (set-marker end nil))
  150.  
  151. (defun vm-rfc1153-char-unstuff-region (start end)
  152.   "Unquote lines in between START and END as per RFC 1153.
  153. START and END are buffer positions in the current buffer.
  154. Lines consisting only of a space following by 29 hyphens have the space
  155. converted to a hyphen."
  156.   (setq end (vm-marker end))
  157.   (save-excursion
  158.     (goto-char start)
  159.     (while (and (< (point) end)
  160.         (re-search-forward "^ -----------------------------$" end t))
  161.       (replace-match "------------------------------" t t)))
  162.   (set-marker end nil))
  163.  
  164. (defun vm-rfc1153-encapsulate-messages (message-list keep-list discard-regexp)
  165.   "Encapsulate the messages in MESSAGE-LIST as per RFC 1153.
  166. The resulting digest is inserted at point in the current buffer.
  167. Point is not moved.
  168.  
  169. MESSAGE-LIST should be a list of message structs (real or virtual).
  170. These are the messages that will be encapsulated.
  171. KEEP-LIST should be a list of regexps matching headers to keep.
  172. DISCARD-REGEXP should be a regexp that matches headers to be discarded.
  173. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
  174. to be forwarded.  See the docs for vm-reorder-message-headers
  175. to find out how KEEP-LIST and DISCARD-REGEXP are used."
  176.   (if message-list
  177.       (let ((target-buffer (current-buffer))
  178.         (mlist message-list)
  179.         source-buffer m start)
  180.     (save-restriction
  181.       ;; narrow to a zero length region to avoid interacting
  182.       ;; with anything that might have already been inserted
  183.       ;; into the buffer.
  184.       (narrow-to-region (point) (point))
  185.       (setq start (point))
  186.       (while mlist
  187.         (insert "---------------\n\n")
  188.         (setq m (vm-real-message-of (car mlist))
  189.           source-buffer (vm-buffer-of m))
  190.         (save-excursion
  191.           (set-buffer source-buffer)
  192.           (save-restriction
  193.         (widen)
  194.         (save-excursion
  195.           (set-buffer target-buffer)
  196.           (let ((beg (point)))
  197.             (insert-buffer-substring source-buffer (vm-headers-of m)
  198.                          (vm-text-end-of m))
  199.             (goto-char beg)
  200.             (vm-reorder-message-headers nil nil
  201.                         "\\(X-VM-\\|Status:\\)")
  202.             (vm-reorder-message-headers nil keep-list discard-regexp)
  203.             (vm-rfc1153-char-stuff-region beg (point-max))))))
  204.         (goto-char (point-max))
  205.         (insert "\n---------------")
  206.         (setq mlist (cdr mlist)))
  207.     (insert "---------------\n\nEnd of this Digest\n******************\n")
  208.       (goto-char start)
  209.       (delete-region (point) (progn (forward-line 1) (point)))
  210.       (insert (format "This is an RFC 1153 digest.\n(%d message%s)\n----------------------------------------------------------------------\n" (length message-list) (if (cdr message-list) "s" "")))
  211.       (goto-char start)))))
  212.  
  213. (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153)
  214.   "Burst messages from the digest message M.
  215. M should be a message struct for a real message.
  216. If RFC1153 is non-nil, assume the digest is of the form specified by
  217. RFC 1153.  Otherwise assume RFC 934 digests."
  218.   (let ((work-buffer nil)
  219.     (match t)
  220.     (prev-sep nil)
  221.     (ident-header nil)
  222.     after-prev-sep prologue-separator-regexp separator-regexp
  223.     (folder-type vm-folder-type))
  224.     (if vm-digest-identifier-header-format
  225.     (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
  226.     (if rfc1153
  227.     (setq prologue-separator-regexp "^----------------------------------------------------------------------\n"
  228.           separator-regexp "^------------------------------\n")
  229.       (setq prologue-separator-regexp "^-[^ ].*\n"
  230.         separator-regexp "^-[^ ].*\n"))
  231.     (save-excursion
  232.       (vm-save-restriction
  233.        (widen)
  234.        (unwind-protect
  235.        (catch 'done
  236.          (setq work-buffer (generate-new-buffer "*vm-work*"))
  237.          (set-buffer work-buffer)
  238.          (insert-buffer-substring (vm-buffer-of m)
  239.                       (vm-text-of m)
  240.                       (vm-text-end-of m))
  241.          (goto-char (point-min))
  242.          (if (not (re-search-forward prologue-separator-regexp nil t))
  243.          (throw 'done nil))
  244.          ;; think of this as a do-while loop.
  245.          (while match
  246.            (cond ((null prev-sep)
  247.               ;; from (point-min) to end of match
  248.               ;; is the digest prologue, devour it and
  249.               ;; carry on.
  250.               (delete-region (point-min) (match-end 0)))
  251.              (t
  252.               ;; munge previous messages message separators
  253.               (let ((md (match-data)))
  254.             (unwind-protect
  255.                 (vm-munge-message-separators
  256.                  folder-type
  257.                  after-prev-sep
  258.                  (match-beginning 0))
  259.               (store-match-data md)))
  260.               ;; eat preceding newlines
  261.               (while (= (preceding-char) ?\n)
  262.             (delete-char -1))
  263.               ;; put one back
  264.               (insert ?\n)))
  265.            ;; insert a trailing message separator
  266.            ;; delete the digest separator
  267.            ;; insert the leading separator
  268.            (if prev-sep
  269.            (progn
  270.              (delete-region (match-beginning 0) (match-end 0))
  271.              (insert (vm-trailing-message-separator folder-type))))
  272.            (setq prev-sep (point))
  273.            (insert (vm-leading-message-separator folder-type))
  274.            (setq after-prev-sep (point))
  275.            ;; eat trailing newlines
  276.            (while (= (following-char) ?\n)
  277.          (delete-char 1))
  278.            (insert ident-header)
  279.            ;; try to match message separator and repeat.
  280.            (setq match (re-search-forward separator-regexp nil t)))
  281.          ;; from the last separator to eof is the digest epilogue.
  282.          ;; discard it.
  283.          (delete-region (or prev-sep (point-min)) (point-max))
  284.          ;; Undo the quoting of the embedded message
  285.          ;; separators.  This must be done before header
  286.          ;; conversions, else the Content-Length offsets might be
  287.          ;; rendered invalid by buffer size changes.
  288.          (if rfc1153
  289.          (vm-rfc1153-char-unstuff-region (point-min) (point-max))
  290.            (vm-rfc934-char-unstuff-region (point-min) (point-max)))
  291.          ;; do header conversions.
  292.          (let ((vm-folder-type folder-type))
  293.            (goto-char (point-min))
  294.            (while (vm-find-leading-message-separator)
  295.          (vm-skip-past-leading-message-separator)
  296.          (vm-convert-folder-type-headers folder-type folder-type)
  297.          (vm-find-trailing-message-separator)
  298.          (vm-skip-past-trailing-message-separator)))
  299.          ;; now insert the messages into the folder buffer
  300.          (cond ((not (zerop (buffer-size)))
  301.             (set-buffer (vm-buffer-of m))
  302.             (let ((old-buffer-modified-p (buffer-modified-p))
  303.               (buffer-read-only nil)
  304.               (inhibit-quit t))
  305.               (goto-char (point-max))
  306.               (insert-buffer-substring work-buffer)
  307.               (set-buffer-modified-p old-buffer-modified-p)
  308.               ;; return non-nil so caller knows we found some messages
  309.               t ))
  310.            ;; return nil so the caller knows we didn't find anything
  311.            (t nil)))
  312.      (and work-buffer (kill-buffer work-buffer)))))))
  313.  
  314. (defun vm-rfc934-burst-message (m)
  315.   "Burst messages from the RFC 934 digest message M.
  316. M should be a message struct for a real message."
  317.   (vm-rfc1153-or-rfc934-burst-message m nil))
  318.  
  319. (defun vm-rfc1153-burst-message (m)
  320.   "Burst messages from the RFC 1153 digest message M.
  321. M should be a message struct for a real message."
  322.   (vm-rfc1153-or-rfc934-burst-message m t))
  323.  
  324. (defun vm-burst-digest (&optional digest-type)
  325.   "Burst the current message (a digest) into its individual messages.
  326. The digest's messages are assimilated into the folder as new mail
  327. would be.
  328.  
  329. Optional argument DIGEST-TYPE is a string that tells VM what kind
  330. of digest the current message is.  If it is not given the value
  331. defaults to the value of vm-digest-burst-type.  When called
  332. interactively DIGEST-TYPE will be read from the minibuffer.
  333.  
  334. If invoked on marked messages (via vm-next-command-uses-marks),
  335. all marked messages will be burst."
  336.   (interactive
  337.    (list
  338.     (let ((type nil)
  339.       (this-command this-command)
  340.       (last-command last-command))
  341.       (setq type (completing-read (format "Digest type: (default %s) "
  342.                       vm-digest-burst-type)
  343.                   (append vm-digest-type-alist
  344.                       (list '("guess")))
  345.                   'identity nil))
  346.       (if (string= type "")
  347.       vm-digest-burst-type
  348.     type ))))
  349.   (or digest-type (setq digest-type vm-digest-burst-type))
  350.   (vm-follow-summary-cursor)
  351.   (vm-select-folder-buffer)
  352.   (vm-check-for-killed-summary)
  353.   (vm-error-if-folder-empty)
  354.   (let ((start-buffer (current-buffer)) m totals-blurb
  355.     (mlist (vm-select-marked-or-prefixed-messages 1)))
  356.     (while mlist
  357.       (if (vm-virtual-message-p (car mlist))
  358.       (progn
  359.         (setq m (vm-real-message-of (car mlist)))
  360.         (set-buffer (vm-buffer-of m)))
  361.     (setq m (car mlist)))
  362.       (vm-error-if-folder-read-only)
  363.       (if (equal digest-type "guess")
  364.       (progn
  365.         (setq digest-type (vm-guess-digest-type m))
  366.         (if (null digest-type)
  367.         (error "Couldn't guess digest type."))))
  368.       (vm-unsaved-message "Bursting %s digest..." digest-type)
  369.       (cond
  370.        ((cond ((equal digest-type "rfc934")
  371.            (vm-rfc934-burst-message m))
  372.           ((equal digest-type "rfc1153")
  373.            (vm-rfc1153-burst-message m))
  374.           (t (error "Unknown digest type: %s" digest-type)))
  375.     (message "Bursting %s digest... done" digest-type)
  376.     (vm-clear-modification-flag-undos)
  377.     (vm-set-buffer-modified-p t)
  378.     (vm-increment vm-modification-counter)
  379.     (and vm-delete-after-bursting
  380.          ;; if start folder was virtual, we're now in the wrong
  381.          ;; buffer.  switch back.
  382.          (save-excursion
  383.            (set-buffer start-buffer)
  384.            (vm-delete-message 1)))
  385.     (vm-assimilate-new-messages t)
  386.     ;; do this now so if we error later in another iteration
  387.     ;; of the loop the summary and mode line will be correct.
  388.     (vm-update-summary-and-mode-line)))
  389.       (setq mlist (cdr mlist)))
  390.     ;; collect this data NOW, before the non-previewers read a
  391.     ;; message, alter the new message count and confuse
  392.     ;; themselves.
  393.     (setq totals-blurb (vm-emit-totals-blurb))
  394.     (vm-display nil nil '(vm-burst-digest
  395.               vm-burst-rfc934-digest
  396.               vm-burst-rfc1153-digest)
  397.         (list this-command))
  398.     (if (vm-thoughtfully-select-message)
  399.     (vm-preview-current-message)
  400.       (vm-update-summary-and-mode-line))
  401.     (message totals-blurb)))
  402.  
  403. (defun vm-burst-rfc934-digest ()
  404.   "Burst an RFC 934 style digest"
  405.   (interactive)
  406.   (vm-burst-digest "rfc934"))
  407.  
  408. (defun vm-burst-rfc1153-digest ()
  409.   "Burst an RFC 1153 style digest"
  410.   (interactive)
  411.   (vm-burst-digest "rfc1153"))
  412.  
  413. (defun vm-guess-digest-type (m)
  414.   "Guess the digest type of the message M.
  415. M should be the message struct of a real message.
  416. Returns either \"rfc934\" or \"rfc1153\"."
  417.   (save-excursion
  418.     (set-buffer (vm-buffer-of m))
  419.     (save-excursion
  420.       (save-restriction
  421.     (widen)
  422.     (goto-char (vm-text-of m))
  423.     (if (search-forward "\n----------------------------------------------------------------------\n" nil t)
  424.         "rfc1153"
  425.       "rfc934")))))
  426.