Add message/partial viewer.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 4f32c0e..cc9a46e 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,9 @@
+2000-04-27 00:58:43  Shenghuo ZHU  <zsh@cs.rochester.edu>
+
+       * mm-decode.el (mm-inline-media-tests): Add message/partial.
+       (mm-inlined-types): Ditto.
+       * mm-partial.el: New file.
+
 2000-04-27  Dave Love  <fx@gnu.org>
 
        * mailcap.el (mailcap-mime-data): Fix octet-stream syntax -- might

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index 717e017..fe9b5f7 100644 (file)
--- a/lisp/mm-decode.el
+++ b/lisp/mm-decode.el
@@ -28,6 +28,9 @@
 (require 'mailcap)
 (require 'mm-bodies)
 
+(eval-and-compile
+  (autoload 'mm-inline-partial "mm-partial"))
+
 (defvar mm-xemacs-p (string-match "XEmacs" (emacs-version)))
 
 (defgroup mime-display ()
@@ -126,6 +129,7 @@
           (locate-library "vcard"))))
     ("message/delivery-status" mm-inline-text identity)
     ("message/rfc822" mm-inline-message identity)
+    ("message/partial" mm-inline-partial identity)
     ("text/.*" mm-inline-text identity)
     ("audio/wav" mm-inline-audio
      (lambda (handle)
@@ -148,6 +152,7 @@
 
 (defcustom mm-inlined-types
   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
+    "message/partial"
     "application/pgp-signature")
   "List of media types that are to be displayed inline."
   :type '(repeat string)

diff --git a/lisp/mm-partial.el b/lisp/mm-partial.el
new file mode 100644 (file)
index 0000000..8f32aa9
--- /dev/null
+++ b/lisp/mm-partial.el
@@ -0,0 +1,143 @@
+;;; mm-partial.el --- showing message/partial
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
+;; Keywords: message partial
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published
+;; by the Free Software Foundation; either version 2, or (at your
+;; option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile 
+  (require 'cl))
+
+(require 'gnus-sum)
+(require 'mm-util)
+(require 'mm-decode)
+
+(defun mm-partial-find-parts (id &optional art)
+  (let ((headers (save-excursion
+                  (set-buffer gnus-summary-buffer)
+                  gnus-newsgroup-headers))
+       phandles handles  header)
+    (while (setq header (pop headers))
+      (unless (eq (aref header 0) art)
+       (mm-with-unibyte-buffer
+         (gnus-request-article-this-buffer (aref header 0) 
+                                           gnus-newsgroup-name)
+         (when (search-forward id nil t)
+           (let ((nhandles (mm-dissect-buffer)) nid)
+             (setq handles gnus-article-mime-handles)
+             (if (consp (car nhandles))
+                 (mm-destroy-parts nhandles)
+               (setq nid (cdr (assq 'id 
+                                    (cdr (mm-handle-type nhandles)))))
+               (if (not (equal id nid))
+                   (mm-destroy-parts nhandles)
+                 (push nhandles phandles))))))))
+    phandles))
+
+;;;###autoload
+(defun mm-inline-partial (handle)
+  (let ((id (cdr (assq 'id (cdr (mm-handle-type handle))))) 
+       phandles
+       (b (point)) (n 1) total
+       phandle nn ntotal
+       gnus-displaying-mime handles buffer)
+    (unless (mm-handle-cache handle)
+      (unless id
+       (error "Can not find message/partial id."))
+      (setq phandles
+           (sort (cons handle 
+                       (mm-partial-find-parts
+                        id 
+                        (save-excursion
+                          (set-buffer gnus-summary-buffer)
+                          (gnus-summary-article-number))))
+                 #'(lambda (a b)
+                     (let ((anumber (string-to-number 
+                                     (cdr (assq 'number 
+                                                (cdr (mm-handle-type a))))))
+                           (bnumber (string-to-number 
+                                     (cdr (assq 'number 
+                                                (cdr (mm-handle-type b)))))))
+                       (< anumber bnumber)))))
+      (setq gnus-article-mime-handles
+           (append (if (listp (car gnus-article-mime-handles))
+                       gnus-article-mime-handles
+                     (list gnus-article-mime-handles))
+                   phandles))
+      (save-excursion
+       (set-buffer (generate-new-buffer "*mm*"))
+       (while (setq phandle (pop phandles))
+         (setq nn (string-to-number 
+                   (cdr (assq 'number 
+                              (cdr (mm-handle-type phandle))))))
+         (setq ntotal (string-to-number 
+                       (cdr (assq 'total 
+                                  (cdr (mm-handle-type phandle))))))
+         (if ntotal
+             (if total
+                 (unless (eq total ntotal) 
+                 (error "The numbers of total are different."))
+               (setq total ntotal)))
+         (unless (< nn n)
+           (unless (eq nn n)
+             (error "Missing part %d" n))
+           (mm-insert-part phandle)
+           (goto-char (point-max))
+           (setq n (+ n 1))))
+       (unless total
+         (error "Don't known the total number of"))
+       (if (<= n total)
+           (error "Missing part %d" n))
+       (kill-buffer (mm-handle-buffer handle))
+       (setcar handle (current-buffer))
+       (mm-handle-set-cache handle t)))
+    (save-excursion
+      (save-restriction
+       (narrow-to-region b b)
+       (mm-insert-part handle)
+       (let (gnus-article-mime-handles)
+         (run-hooks 'gnus-article-decode-hook)
+         (gnus-article-prepare-display)
+         (setq handles gnus-article-mime-handles))
+       (when handles
+         ;; It is in article buffer.
+         (setq gnus-article-mime-handles
+               (nconc (if (listp (car gnus-article-mime-handles))
+                          gnus-article-mime-handles
+                        (list gnus-article-mime-handles))
+                      (if (listp (car handles)) 
+                          handles (list handles)))))
+       (mm-handle-set-undisplayer
+        handle
+        `(lambda ()
+           (let (buffer-read-only)
+             (condition-case nil
+                 ;; This is only valid on XEmacs.
+                 (mapcar (lambda (prop)
+                           (remove-specifier
+                            (face-property 'default prop) (current-buffer)))
+                         '(background background-pixmap foreground))
+               (error nil))
+             (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
+
+;; mm-partial.el ends here