cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-digest.el

   1 ;;; vm-digest.el --- Message encapsulation
   2 ;;
   3 ;; Copyright (C) 1989, 1990, 1993, 1994, 1997, 2001 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program 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 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program 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 along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21
  22 ;;;###autoload
  23 (defun vm-no-frills-encapsulate-message (m keep-list discard-regexp)
  24   "Encapsulate a message M for forwarding, simply.
  25 No message encapsulation standard is used.  The message is
  26 inserted at point in the current buffer, surrounded by two dashed
  27 start/end separator lines.  Point is not moved.
  28
  29 M should be a message struct for a real message, not a virtual message.
  30 This is the message that will be encapsulated.
  31 KEEP-LIST should be a list of regexps matching headers to keep.
  32 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
  33 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
  34 to be forwarded.  See the docs for vm-reorder-message-headers
  35 to find out how KEEP-LIST and DISCARD-REGEXP are used."
  36   (let ((target-buffer (current-buffer))
  37         source-buffer)
  38     (save-restriction
  39       ;; narrow to a zero length region to avoid interacting
  40       ;; with anything that might have already been inserted
  41       ;; into the buffer.
  42       (narrow-to-region (point) (point))
  43       (insert "------- start of forwarded message -------\n")
  44       (setq source-buffer (vm-buffer-of m))
  45       (save-excursion
  46         (set-buffer source-buffer)
  47         (save-restriction
  48           (widen)
  49           (save-excursion
  50             (set-buffer target-buffer)
  51             (let ((beg (point)))
  52               (insert-buffer-substring source-buffer (vm-headers-of m)
  53                                        (vm-text-end-of m))
  54               (goto-char beg)
  55               (vm-reorder-message-headers nil nil vm-internal-unforwarded-header-regexp)
  56               (vm-reorder-message-headers nil keep-list discard-regexp)
  57               (vm-decode-mime-message-headers)))))
  58       (goto-char (point-max))
  59       (insert "------- end of forwarded message -------\n"))))
  60
  61 ;;;###autoload
  62 (defun vm-mime-encapsulate-messages (message-list keep-list discard-regexp
  63                                      always-use-digest)
  64   "Encapsulate the messages in MESSAGE-LIST as per the MIME spec.
  65 The resulting digest is inserted at point in the current buffer.
  66 Point is not moved.
  67
  68 MESSAGE-LIST should be a list of message structs (real or virtual).
  69 These are the messages that will be encapsulated.
  70 KEEP-LIST should be a list of regexps matching headers to keep.
  71 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
  72 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
  73 to be forwarded.  See the docs for vm-reorder-message-headers
  74 to find out how KEEP-LIST and DISCARD-REGEXP are used.
  75
  76 If ALWAYS-USE-DIGEST is non-nil, always encapsulate for a multipart/digest.
  77 Otherwise if there is only one message to be encapsulated
  78 leave off the multipart boundary strings.  The caller is assumed to
  79 be using message/rfc822 or message/news encoding instead.
  80
  81 If multipart/digest encapsulation is done, the function returns
  82 the multipart boundary parameter (string) that should be used in
  83 the Content-Type header.  Otherwise nil is returned."
  84   (if message-list
  85       (let ((target-buffer (current-buffer))
  86             (boundary-positions nil)
  87             (mlist message-list)
  88             (boundary nil)
  89             source-buffer m start n beg)
  90         (save-restriction
  91           ;; narrow to a zero length region to avoid interacting
  92           ;; with anything that might have already been inserted
  93           ;; into the buffer.
  94           (narrow-to-region (point) (point))
  95           (setq start (point))
  96           (while mlist
  97             (setq boundary-positions (cons (point-marker) boundary-positions))
  98             (setq m (vm-real-message-of (car mlist))
  99                   source-buffer (vm-buffer-of m))
 100             (setq beg (point))
 101             (vm-insert-region-from-buffer source-buffer (vm-headers-of m)
 102                                           (vm-text-end-of m))
 103             (goto-char beg)
 104             ;; remove the Berkeley and VM status headers and sort
 105             ;; the MIME headers to the top of the message.
 106             (vm-reorder-message-headers nil vm-mime-header-list
 107                                         vm-internal-unforwarded-header-regexp)
 108             ;; skip past the MIME headers so that when the
 109             ;; user's header filters are applied they won't
 110             ;; remove the MIME headers.
 111             (while (and (vm-match-header) (looking-at vm-mime-header-regexp))
 112               (goto-char (vm-matched-header-end)))
 113             ;; apply the user's header filters.
 114             (vm-reorder-message-headers nil keep-list discard-regexp)
 115             (goto-char (point-max))
 116             (setq mlist (cdr mlist)))
 117           (if (and (< (length message-list) 2) (not always-use-digest))
 118               nil
 119             (goto-char start)
 120             (setq boundary (vm-mime-make-multipart-boundary))
 121             (while (re-search-forward (concat "^--"
 122                                               (regexp-quote boundary)
 123                                               "\\(--\\)?$")
 124                                       nil t)
 125               (setq boundary (vm-mime-make-multipart-boundary))
 126               (goto-char start))
 127             (goto-char (point-max))
 128             (insert "\n--" boundary "--\n")
 129             (while boundary-positions
 130               (goto-char (car boundary-positions))
 131               (insert "\n--" boundary "\n\n")
 132               (setq boundary-positions (cdr boundary-positions)))
 133             (goto-char start)
 134             (setq n (length message-list))
 135             (insert
 136              (format "This is a digest, %d message%s, MIME encapsulation.\n"
 137                      n (if (= n 1) "" "s"))))
 138           (goto-char start))
 139         boundary )))
 140
 141 (defun vm-mime-burst-message (m)
 142   "Burst messages from the digest message M.
 143 M should be a message struct for a real message.
 144 MIME encoding is expected.  Somewhere within the MIME layout
 145 there must be at least one part of type message/news, message/rfc822 or
 146 multipart/digest.  If there are multiple parts matching those types,
 147 all of them will be burst."
 148   (let ((ident-header nil)
 149         (did-burst nil)
 150         (list (vm-mime-find-digests-in-layout (vm-mm-layout m))))
 151     (if vm-digest-identifier-header-format
 152         (setq ident-header (vm-summary-sprintf
 153                             vm-digest-identifier-header-format m)))
 154     (while list
 155       (setq did-burst (or (vm-mime-burst-layout (car list) ident-header)
 156                           did-burst))
 157       (setq list (cdr list)))
 158     did-burst))
 159
 160 ;;;###autoload
 161 (defun vm-mime-burst-layout (layout ident-header)
 162   (let ((work-buffer nil)
 163         (folder-buffer (current-buffer))
 164         start part-list
 165         (folder-type vm-folder-type))
 166     (unwind-protect
 167         (vm-save-restriction
 168          (save-excursion
 169            (widen)
 170            (setq work-buffer (vm-make-work-buffer))
 171            (set-buffer work-buffer)
 172            (cond ((not (vectorp layout))
 173                   (error "Not a MIME message"))
 174                  ((vm-mime-types-match "message"
 175                                        (car (vm-mm-layout-type layout)))
 176                   (insert (vm-leading-message-separator folder-type))
 177                   (and ident-header (insert ident-header))
 178                   (setq start (point))
 179                   (vm-mime-insert-mime-body layout)
 180                   (vm-munge-message-separators folder-type start (point))
 181                   ;; remove any leading newlines as they will
 182                   ;; make vm-reorder-message-headers think the
 183                   ;; header section has ended.
 184                   (save-excursion
 185                     (goto-char start)
 186                     (while (= (following-char) ?\n)
 187                       (delete-char 1)))
 188                   (insert ?\n)
 189                   (insert (vm-trailing-message-separator folder-type)))
 190                  ((vm-mime-types-match "multipart/digest"
 191                                        (car (vm-mm-layout-type layout)))
 192                   (setq part-list (vm-mm-layout-parts layout))
 193                   (while part-list
 194                     ;; Maybe we should verify that each part is
 195                     ;; of type message/rfc822 or message/news in
 196                     ;; here.  But it seems more useful to just
 197                     ;; copy whatever the contents are and let the
 198                     ;; user see the goop, whatever type it really
 199                     ;; is.
 200                     (insert (vm-leading-message-separator folder-type))
 201                     (and ident-header (insert ident-header))
 202                     (setq start (point))
 203                     (vm-mime-insert-mime-body (car part-list))
 204                     (vm-munge-message-separators folder-type start (point))
 205                     ;; remove any leading newlines as they will
 206                     ;; make vm-reorder-message-headers think the
 207                     ;; header section has ended.
 208                     (save-excursion
 209                       (goto-char start)
 210                       (while (= (following-char) ?\n)
 211                         (delete-char 1)))
 212                     (insert ?\n)
 213                     (insert (vm-trailing-message-separator folder-type))
 214                     (setq part-list (cdr part-list))))
 215                  (t (error
 216                      "MIME type is not multipart/digest or message/rfc822 or message/news")))
 217            ;; do header conversions.
 218            (let ((vm-folder-type folder-type))
 219              (goto-char (point-min))
 220              (while (vm-find-leading-message-separator)
 221                (vm-skip-past-leading-message-separator)
 222                (vm-convert-folder-type-headers folder-type folder-type)
 223                (vm-find-trailing-message-separator)
 224                (vm-skip-past-trailing-message-separator)))
 225            ;; now insert the messages into the folder buffer
 226            (cond ((not (zerop (buffer-size)))
 227                   (set-buffer folder-buffer)
 228                   (let ((old-buffer-modified-p (buffer-modified-p))
 229                         (buffer-read-only nil)
 230                         (inhibit-quit t))
 231                     (goto-char (point-max))
 232                     (insert-buffer-substring work-buffer)
 233                     (set-buffer-modified-p old-buffer-modified-p)
 234                     ;; return non-nil so caller knows we found some messages
 235                     t ))
 236                  ;; return nil so the caller knows we didn't find anything
 237                  (t nil))))
 238          (and work-buffer (kill-buffer work-buffer)))))
 239
 240 (defun vm-rfc934-char-stuff-region (start end)
 241   "Quote RFC 934 message separators between START and END.
 242 START and END are buffer positions in the current buffer.
 243 Lines beginning with `-' in the region have `- ' prepended to them."
 244   (setq end (vm-marker end))
 245   (save-excursion
 246     (goto-char start)
 247     (while (and (< (point) end) (re-search-forward "^-" end t))
 248       (replace-match "- -" t t)))
 249   (set-marker end nil))
 250
 251 (defun vm-rfc934-char-unstuff-region (start end)
 252   "Unquote lines in between START and END as per RFC 934.
 253 START and END are buffer positions in the current buffer.
 254 Lines beginning with `- ' in the region have that string stripped
 255 from them."
 256   (setq end (vm-marker end))
 257   (save-excursion
 258     (goto-char start)
 259     (while (and (< (point) end) (re-search-forward "^- "  end t))
 260       (replace-match "" t t)
 261       (forward-char)))
 262   (set-marker end nil))
 263
 264 ;;;###autoload
 265 (defun vm-rfc934-encapsulate-messages (message-list keep-list discard-regexp)
 266   "Encapsulate the messages in MESSAGE-LIST as per RFC 934.
 267 The resulting digest is inserted at point in the current buffer.
 268 Point is not moved.
 269
 270 MESSAGE-LIST should be a list of message structs (real or virtual).
 271 These are the messages that will be encapsulated.
 272 KEEP-LIST should be a list of regexps matching headers to keep.
 273 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
 274 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
 275 to be forwarded.  See the docs for vm-reorder-message-headers
 276 to find out how KEEP-LIST and DISCARD-REGEXP are used."
 277   (if message-list
 278       (let ((target-buffer (current-buffer))
 279             (mlist message-list)
 280             source-buffer m start n)
 281         (save-restriction
 282           ;; narrow to a zero length region to avoid interacting
 283           ;; with anything that might have already been inserted
 284           ;; into the buffer.
 285           (narrow-to-region (point) (point))
 286           (setq start (point))
 287           (while mlist
 288             (insert "---------------\n")
 289             (setq m (vm-real-message-of (car mlist))
 290                   source-buffer (vm-buffer-of m))
 291             (save-excursion
 292               (set-buffer source-buffer)
 293               (save-restriction
 294                 (widen)
 295                 (save-excursion
 296                   (set-buffer target-buffer)
 297                   (let ((beg (point)))
 298                     (insert-buffer-substring source-buffer (vm-headers-of m)
 299                                              (vm-text-end-of m))
 300                     (goto-char beg)
 301                     ;; remove the Berkeley and VM status headers and sort
 302                     ;; the MIME headers to the top of the message.
 303                     (vm-reorder-message-headers nil vm-mime-header-list
 304                                                 vm-internal-unforwarded-header-regexp)
 305                     ;; skip past the MIME headers so that when the
 306                     ;; user's header filters are applied they won't
 307                     ;; remove the MIME headers.
 308                     (while (and (vm-match-header)
 309                                 (looking-at vm-mime-header-regexp))
 310                       (goto-char (vm-matched-header-end)))
 311                     ;; apply the user's header filters.
 312                     (vm-reorder-message-headers nil keep-list discard-regexp)
 313                     (vm-rfc934-char-stuff-region beg (point-max))))))
 314             (goto-char (point-max))
 315             (insert "---------------")
 316             (setq mlist (cdr mlist)))
 317           (delete-region (point) (progn (beginning-of-line) (point)))
 318           (insert "------- end -------\n")
 319           (goto-char start)
 320           (delete-region (point) (progn (forward-line 1) (point)))
 321           (setq n (length message-list))
 322    (insert (format "------- start of %s%s(RFC 934 encapsulation) -------\n"
 323                           (if (cdr message-list)
 324                               "digest "
 325                             "forwarded message ")
 326                           (if (cdr message-list)
 327                               (format "(%d messages) " n)
 328                             "")))
 329           (goto-char start)))))
 330
 331 (defun vm-rfc1153-char-stuff-region (start end)
 332   "Quote RFC 1153 message separators between START and END.
 333 START and END are buffer positions in the current buffer.
 334 Lines consisting only of 30 hyphens have the first hyphen
 335 converted to a space."
 336   (setq end (vm-marker end))
 337   (save-excursion
 338     (goto-char start)
 339     (while (and (< (point) end)
 340                 (re-search-forward "^------------------------------$" end t))
 341       (replace-match " -----------------------------" t t)))
 342   (set-marker end nil))
 343
 344 (defun vm-rfc1153-char-unstuff-region (start end)
 345   "Unquote lines in between START and END as per RFC 1153.
 346 START and END are buffer positions in the current buffer.
 347 Lines consisting only of a space following by 29 hyphens have the space
 348 converted to a hyphen."
 349   (setq end (vm-marker end))
 350   (save-excursion
 351     (goto-char start)
 352     (while (and (< (point) end)
 353                 (re-search-forward "^ -----------------------------$" end t))
 354       (replace-match "------------------------------" t t)))
 355   (set-marker end nil))
 356
 357 ;;;###autoload
 358 (defun vm-rfc1153-encapsulate-messages (message-list keep-list discard-regexp)
 359   "Encapsulate the messages in MESSAGE-LIST as per RFC 1153.
 360 The resulting digest is inserted at point in the current buffer.
 361 Point is not moved.
 362
 363 MESSAGE-LIST should be a list of message structs (real or virtual).
 364 These are the messages that will be encapsulated.
 365 KEEP-LIST should be a list of regexps matching headers to keep.
 366 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
 367 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
 368 to be forwarded.  See the docs for vm-reorder-message-headers
 369 to find out how KEEP-LIST and DISCARD-REGEXP are used."
 370   (if message-list
 371       (let ((target-buffer (current-buffer))
 372             (mlist message-list)
 373             source-buffer m start)
 374         (save-restriction
 375           ;; narrow to a zero length region to avoid interacting
 376           ;; with anything that might have already been inserted
 377           ;; into the buffer.
 378           (narrow-to-region (point) (point))
 379           (setq start (point))
 380           (while mlist
 381             (insert "---------------\n\n")
 382             (setq m (vm-real-message-of (car mlist))
 383                   source-buffer (vm-buffer-of m))
 384             (save-excursion
 385               (set-buffer source-buffer)
 386               (save-restriction
 387                 (widen)
 388                 (save-excursion
 389                   (set-buffer target-buffer)
 390                   (let ((beg (point)))
 391                     (insert-buffer-substring source-buffer (vm-headers-of m)
 392                                              (vm-text-end-of m))
 393                     (goto-char beg)
 394                     ;; remove the Berkeley and VM status headers and sort
 395                     ;; the MIME headers to the top of the message.
 396                     (vm-reorder-message-headers nil vm-mime-header-list
 397                                                 vm-internal-unforwarded-header-regexp)
 398                     ;; skip past the MIME headers so that when the
 399                     ;; user's header filters are applied they won't
 400                     ;; remove the MIME headers.
 401                     (while (and (vm-match-header)
 402                                 (looking-at vm-mime-header-regexp))
 403                       (goto-char (vm-matched-header-end)))
 404                     ;; apply the user's header filters.
 405                     (vm-reorder-message-headers nil keep-list discard-regexp)
 406                     (vm-rfc1153-char-stuff-region beg (point-max))))))
 407             (goto-char (point-max))
 408             (insert "\n---------------")
 409             (setq mlist (cdr mlist)))
 410     (insert "---------------\n\nEnd of this Digest\n******************\n")
 411           (goto-char start)
 412           (delete-region (point) (progn (forward-line 1) (point)))
 413           (insert (format "This is an RFC 1153 digest.\n(%d message%s)\n----------------------------------------------------------------------\n" (length message-list) (if (cdr message-list) "s" "")))
 414           (goto-char start)))))
 415
 416 (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153)
 417   "Burst messages from the digest message M.
 418 M should be a message struct for a real message.
 419 If RFC1153 is non-nil, assume the digest is of the form specified by
 420 RFC 1153.  Otherwise assume RFC 934 digests."
 421   (let ((work-buffer nil)
 422         (match t)
 423         (prev-sep nil)
 424         (ident-header nil)
 425         after-prev-sep prologue-separator-regexp separator-regexp
 426         temp-marker
 427         (folder-buffer (current-buffer))
 428         (folder-type vm-folder-type))
 429     (if vm-digest-identifier-header-format
 430         (setq ident-header (vm-summary-sprintf
 431                             vm-digest-identifier-header-format m)))
 432     (if rfc1153
 433         (setq prologue-separator-regexp "^----------------------------------------------------------------------\n"
 434               separator-regexp "^------------------------------\n")
 435       (setq prologue-separator-regexp "\\(^-[^ ].*\n+\\)+"
 436             separator-regexp "\\(^-[^ ].*\n+\\)+"))
 437     (vm-save-restriction
 438      (save-excursion
 439        (widen)
 440        (unwind-protect
 441            (catch 'done
 442              (setq work-buffer (vm-make-work-buffer))
 443              (set-buffer work-buffer)
 444              (setq temp-marker (vm-marker (point)))
 445              (vm-insert-region-from-buffer (vm-buffer-of m)
 446                                            (vm-text-of m)
 447                                            (vm-text-end-of m))
 448              (goto-char (point-min))
 449              (if (not (re-search-forward prologue-separator-regexp nil t))
 450                  (throw 'done nil))
 451              ;; think of this as a do-while loop.
 452              (while match
 453                (cond ((null prev-sep)
 454                       ;; from (point-min) to end of match
 455                       ;; is the digest prologue, devour it and
 456                       ;; carry on.
 457                       (delete-region (point-min) (match-end 0)))
 458                      (t
 459                       ;; save value as mark so that it will move
 460                       ;; with the text.
 461                       (set-marker temp-marker (match-beginning 0))
 462                       (let ((md (match-data)))
 463                         (unwind-protect
 464                             (progn
 465                               ;; Undo the quoting of the embedded message
 466                               ;; separators.
 467                               (if rfc1153
 468                                   (vm-rfc1153-char-unstuff-region
 469                                    after-prev-sep
 470                                    temp-marker)
 471                                 (vm-rfc934-char-unstuff-region after-prev-sep
 472                                                                temp-marker))
 473                               ;; munge previous messages' message separators
 474                               (vm-munge-message-separators
 475                                folder-type
 476                                after-prev-sep
 477                                temp-marker))
 478                           (store-match-data md)))))
 479                ;; there should be at least one valid header at
 480                ;; the beginning of an encapsulated message.  If
 481                ;; there isn't a valid header, then assume that
 482                ;; the digest was packed improperly and that this
 483                ;; isn't a real boundary.
 484                (if (not
 485                     (save-excursion
 486                       (save-match-data
 487                         ;; People who roll digests often think
 488                         ;; any old format will do.  Adding blank
 489                         ;; lines after the message separator is
 490                         ;; common.  Spaces in such lines are an
 491                         ;; added delight.
 492                         (skip-chars-forward " \n")
 493                         (or (and (vm-match-header)
 494                                  (vm-digest-get-header-contents "From"))
 495                             (not (re-search-forward separator-regexp
 496                                                     nil t))))))
 497                    (setq prev-sep (point)
 498                          after-prev-sep (point))
 499                  ;; if this isn't the first message, delete the
 500                  ;; digest separator goop and insert a trailing message
 501                  ;; separator of the proper type.
 502                  (if prev-sep
 503                      (progn
 504                        ;; eat preceding newlines
 505                        (while (= (preceding-char) ?\n)
 506                          (delete-char -1))
 507                        ;; put one back
 508                        (insert ?\n)
 509                        ;; delete the digest separator
 510                        (delete-region (match-beginning 0) (point))
 511                        ;; insert a trailing message separator
 512                        (insert (vm-trailing-message-separator folder-type))))
 513                  (setq prev-sep (point))
 514                  ;; insert the leading separator
 515                  (insert (vm-leading-message-separator folder-type))
 516                  (setq after-prev-sep (point))
 517                  ;; eat trailing newlines
 518                  (while (= (following-char) ?\n)
 519                    (delete-char 1))
 520                  (insert ident-header))
 521                ;; try to match message separator and repeat.
 522                (setq match (re-search-forward separator-regexp nil t)))
 523              ;; from the last separator to eof is the digest epilogue.
 524              ;; discard it.
 525              (delete-region (or prev-sep (point-min)) (point-max))
 526              ;; do header conversions.
 527              (let ((vm-folder-type folder-type))
 528                (goto-char (point-min))
 529                (while (vm-find-leading-message-separator)
 530                  (vm-skip-past-leading-message-separator)
 531                  (vm-convert-folder-type-headers folder-type folder-type)
 532                  (vm-find-trailing-message-separator)
 533                  (vm-skip-past-trailing-message-separator)))
 534              ;; now insert the messages into the folder buffer
 535              (cond ((not (zerop (buffer-size)))
 536                     (set-buffer folder-buffer)
 537                     (let ((old-buffer-modified-p (buffer-modified-p))
 538                           (buffer-read-only nil)
 539                           (inhibit-quit t))
 540                       (goto-char (point-max))
 541                       (insert-buffer-substring work-buffer)
 542                       (set-buffer-modified-p old-buffer-modified-p)
 543                       ;; return non-nil so caller knows we found some messages
 544                       t ))
 545                    ;; return nil so the caller knows we didn't find anything
 546                    (t nil)))
 547          (and work-buffer (kill-buffer work-buffer)))))))
 548
 549 (defun vm-rfc934-burst-message (m)
 550   "Burst messages from the RFC 934 digest message M.
 551 M should be a message struct for a real message."
 552   (vm-rfc1153-or-rfc934-burst-message m nil))
 553
 554 (defun vm-rfc1153-burst-message (m)
 555   "Burst messages from the RFC 1153 digest message M.
 556 M should be a message struct for a real message."
 557   (vm-rfc1153-or-rfc934-burst-message m t))
 558
 559 ;;;###autoload
 560 (defun vm-burst-digest (&optional digest-type)
 561   "Burst the current message (a digest) into its individual messages.
 562 The digest's messages are assimilated into the folder as new mail
 563 would be.
 564
 565 Optional argument DIGEST-TYPE is a string that tells VM what kind
 566 of digest the current message is.  If it is not given the value
 567 defaults to the value of vm-digest-burst-type.  When called
 568 interactively DIGEST-TYPE will be read from the minibuffer.
 569
 570 If invoked on marked messages (via vm-next-command-uses-marks),
 571 all marked messages will be burst."
 572   (interactive
 573    (list
 574     (let ((type nil)
 575           (this-command this-command)
 576           (last-command last-command))
 577       (setq type (completing-read (format "Digest type: (default %s) "
 578                                           vm-digest-burst-type)
 579                                   (append vm-digest-type-alist
 580                                           (list '("guess")))
 581                                   'identity nil))
 582       (if (string= type "")
 583           vm-digest-burst-type
 584         type ))))
 585   (or digest-type (setq digest-type vm-digest-burst-type))
 586   (vm-follow-summary-cursor)
 587   (vm-select-folder-buffer)
 588   (vm-check-for-killed-summary)
 589   (vm-error-if-folder-empty)
 590   (let ((start-buffer (current-buffer)) m totals-blurb
 591         (mlist (vm-select-marked-or-prefixed-messages 1)))
 592     (while mlist
 593       (if (vm-virtual-message-p (car mlist))
 594           (progn
 595             (setq m (vm-real-message-of (car mlist)))
 596             (set-buffer (vm-buffer-of m)))
 597         (setq m (car mlist)))
 598       (vm-error-if-folder-read-only)
 599       (if (equal digest-type "guess")
 600           (progn
 601             (setq digest-type (vm-guess-digest-type m))
 602             (if (null digest-type)
 603                 (error "Couldn't guess digest type."))))
 604       (message "Bursting %s digest..." digest-type)
 605       (cond
 606        ((cond ((equal digest-type "mime")
 607                (vm-mime-burst-message m))
 608               ((equal digest-type "rfc934")
 609                (vm-rfc934-burst-message m))
 610               ((equal digest-type "rfc1153")
 611                (vm-rfc1153-burst-message m))
 612               (t (error "Unknown digest type: %s" digest-type)))
 613         (message "Bursting %s digest... done" digest-type)
 614         (vm-clear-modification-flag-undos)
 615         (vm-set-buffer-modified-p t)
 616         (vm-increment vm-modification-counter)
 617         (and vm-delete-after-bursting
 618              ;; if start folder was virtual, we're now in the wrong
 619              ;; buffer.  switch back.
 620              (save-excursion
 621                (set-buffer start-buffer)
 622                ;; don't move message pointer when deleting the message
 623                (let ((vm-move-after-deleting nil))
 624                  (vm-delete-message 1))))
 625         (vm-assimilate-new-messages t nil (vm-labels-of (car mlist)))
 626         ;; do this now so if we error later in another iteration
 627         ;; of the loop the summary and mode line will be correct.
 628         (vm-update-summary-and-mode-line)))
 629       (setq mlist (cdr mlist)))
 630     ;; collect this data NOW, before the non-previewers read a
 631     ;; message, alter the new message count and confuse
 632     ;; themselves.
 633     (setq totals-blurb (vm-emit-totals-blurb))
 634     (vm-display nil nil '(vm-burst-digest
 635                           vm-burst-mime-digest
 636                           vm-burst-rfc934-digest
 637                           vm-burst-rfc1153-digest)
 638                 (list this-command))
 639     (if (vm-thoughtfully-select-message)
 640         (vm-preview-current-message)
 641       (vm-update-summary-and-mode-line))
 642     (message totals-blurb)))
 643
 644 ;;;###autoload
 645 (defun vm-burst-rfc934-digest ()
 646   "Burst an RFC 934 style digest"
 647   (interactive)
 648   (vm-burst-digest "rfc934"))
 649
 650 ;;;###autoload
 651 (defun vm-burst-rfc1153-digest ()
 652   "Burst an RFC 1153 style digest"
 653   (interactive)
 654   (vm-burst-digest "rfc1153"))
 655
 656 ;;;###autoload
 657 (defun vm-burst-mime-digest ()
 658   "Burst a MIME digest"
 659   (interactive)
 660   (vm-burst-digest "mime"))
 661
 662 ;;;###autoload
 663 (defun vm-burst-digest-to-temp-folder (&optional digest-type)
 664   "Burst the current message (a digest) into a temporary folder.
 665 The digest's messages are copied to a buffer and vm-mode is
 666 invoked on the buffer.  There is no file associated with this
 667 buffer.  You can use `vm-write-file' to save the buffer, or
 668 `vm-save-message' to save individual messages to a real folder.
 669
 670 Optional argument DIGEST-TYPE is a string that tells VM what kind
 671 of digest the current message is.  If it is not given the value
 672 defaults to the value of vm-digest-burst-type.  When called
 673 interactively DIGEST-TYPE will be read from the minibuffer.
 674
 675 If invoked on marked messages (via vm-next-command-uses-marks),
 676 all marked messages will be burst."
 677   (interactive
 678    (list
 679     (let ((type nil)
 680           (this-command this-command)
 681           (last-command last-command))
 682       (setq type (completing-read (format "Digest type: (default %s) "
 683                                           vm-digest-burst-type)
 684                                   (append vm-digest-type-alist
 685                                           (list '("guess")))
 686                                   'identity nil))
 687       (if (string= type "")
 688           vm-digest-burst-type
 689         type ))))
 690   (or digest-type (setq digest-type vm-digest-burst-type))
 691   (vm-follow-summary-cursor)
 692   (vm-select-folder-buffer)
 693   (vm-check-for-killed-summary)
 694   (vm-error-if-folder-empty)
 695   (let ((start-buffer (current-buffer)) m totals-blurb
 696         (mlist (vm-select-marked-or-prefixed-messages 1))
 697         (work-buffer nil))
 698     (unwind-protect
 699         (save-excursion
 700           (setq work-buffer (generate-new-buffer
 701                              (format "digest from %s/%s%s"
 702                                      (current-buffer)
 703                                      (vm-number-of (car vm-message-pointer))
 704                                      (if (cdr mlist) " ..." ""))))
 705           (buffer-disable-undo work-buffer)
 706           (set-buffer work-buffer)
 707           (setq vm-folder-type vm-default-folder-type)
 708           (while mlist
 709             (if (vm-virtual-message-p (car mlist))
 710                 (setq m (vm-real-message-of (car mlist)))
 711               (setq m (car mlist)))
 712             (if (equal digest-type "guess")
 713                 (progn
 714                   (setq digest-type (vm-guess-digest-type m))
 715                   (if (null digest-type)
 716                       (error "Couldn't guess digest type."))))
 717             (message "Bursting %s digest to folder..." digest-type)
 718             (cond ((equal digest-type "mime")
 719                    (vm-mime-burst-message m))
 720                   ((equal digest-type "rfc934")
 721                    (vm-rfc934-burst-message m))
 722                   ((equal digest-type "rfc1153")
 723                    (vm-rfc1153-burst-message m))
 724                   (t (error "Unknown digest type: %s" digest-type)))
 725             (message "Bursting %s digest... done" digest-type)
 726             (and vm-delete-after-bursting
 727                  (yes-or-no-p (format "Delete message %s? " (vm-number-of m)))
 728                  (save-excursion
 729                    (set-buffer start-buffer)
 730                    ;; don't move message pointer when deleting the message
 731                    (let ((vm-move-after-deleting nil))
 732                      (vm-delete-message 1))))
 733             (setq mlist (cdr mlist)))
 734           (set-buffer-modified-p nil)
 735           (vm-save-buffer-excursion
 736            (vm-goto-new-folder-frame-maybe 'folder)
 737            (vm-mode)
 738            (if (vm-should-generate-summary)
 739                (progn
 740                  (vm-goto-new-folder-frame-maybe 'summary)
 741                  (vm-summarize))))
 742           ;; temp buffer, don't offer to save it.
 743           (setq buffer-offer-save nil)
 744           (vm-display (or vm-presentation-buffer (current-buffer)) t
 745                       (list this-command) '(vm-mode startup))
 746           (setq work-buffer nil))
 747       (and work-buffer (kill-buffer work-buffer)))))
 748
 749 (defun vm-guess-digest-type (m)
 750   "Guess the digest type of the message M.
 751 M should be the message struct of a real message.
 752 Returns either \"rfc934\", \"rfc1153\" or \"mime\"."
 753   (catch 'return-value
 754     (save-excursion
 755       (set-buffer (vm-buffer-of m))
 756       (let ((layout (vm-mm-layout m)))
 757         (if (and (vectorp layout)
 758                  (or (vm-mime-layout-contains-type
 759                       layout
 760                       "multipart/digest")
 761                      (vm-mime-layout-contains-type
 762                       layout
 763                       "message/rfc822")
 764                      (vm-mime-layout-contains-type
 765                       layout
 766                       "message/news")))
 767             (throw 'return-value "mime"))))
 768     (save-excursion
 769       (save-restriction
 770         (widen)
 771         (goto-char (vm-text-of m))
 772         (cond ((and (search-forward "\n----------------------------------------------------------------------\n" (vm-text-end-of m) t)
 773                     (search-forward "\n------------------------------\n" (vm-text-end-of m) t))
 774                "rfc1153")
 775               (t "rfc934"))))))
 776
 777 (defun vm-digest-get-header-contents (header-name-regexp)
 778   (let ((contents nil)
 779         regexp)
 780     (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)"))
 781     (save-excursion
 782       (let ((case-fold-search t))
 783         (if (and (re-search-forward regexp nil t)
 784                  (match-beginning 1)
 785                  (progn (goto-char (match-beginning 0))
 786                         (vm-match-header)))
 787             (vm-matched-header-contents)
 788           nil )))))
 789
 790 (provide 'vm-digest)
 791
 792 ;;; vm-digest.el ends here