projects / elisp / wanderlust.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
* elmo-vars.el (elmo-imap4-default-authenticate-type): Give
[elisp/wanderlust.git] / elmo / mmimap.el
diff --git a/elmo/mmimap.el b/elmo/mmimap.el
index 54a5faf..f0e33a2 100644 (file)
--- a/elmo/mmimap.el
+++ b/elmo/mmimap.el
@@ -24,7 +24,7 @@
 ;; Boston, MA 02111-1307, USA.
 
 ;;; Commentary:
-;; 
+;;
 
 ;;; Code:
 
@@ -36,7 +36,7 @@
 
 (eval-and-compile
   (luna-define-class mime-imap-entity (mime-entity)
-                    (size header-string body-string new))
+                    (size header-string body-string new requested))
   (luna-define-internal-accessors 'mime-imap-entity))
 
 ;;; @ MIME IMAP location
@@ -52,24 +52,27 @@ SECTION is a section string which is defined in RFC2060.")
   "Return a parsed bodystructure of LOCATION.
 `NIL' should be converted to nil, `astring' should be converted to a string.")
 
+(luna-define-generic mime-imap-location-fetch-entity-p (location entity)
+  "Return non-nil when LOCATION may fetch the ENTITY.")
+
 ;;; @ Subroutines
-;; 
+;;
 
 (defun mmimap-entity-section (node-id)
   "Return a section string from NODE-ID"
   (cond
+   ((null node-id)
+    "1")
    ((numberp node-id)
     (number-to-string (1+ node-id)))
    ((listp node-id)
-    (mapconcat 
+    (mapconcat
      'mmimap-entity-section
      (reverse node-id)
      "."))))
 
-(static-if (fboundp 'mime-decode-parameters)
-    (defalias 'mmimap-parse-parameters-from-list 'mime-decode-parameters)
-  (defun mmimap-parse-parameters-from-list (attrlist)
-    "Parse parameters from ATTRLIST."
+(eval-and-compile
+  (defun-maybe mime-decode-parameters (attrlist)
     (let (ret-val)
       (while attrlist
        (setq ret-val (append ret-val
@@ -82,6 +85,7 @@ SECTION is a section string which is defined in RFC2060.")
                                              parent)
   "Analyze parsed IMAP4 BODYSTRUCTURE response and make MIME entity.
 CLASS, LOCATION, NODE-ID, PARENT are set to the returned entity."
+  (setq node-id (if number (cons number node-id) node-id))
   (cond
    ((listp (car bodystructure)) ; multipart
     (let ((num 0)
@@ -92,10 +96,7 @@ CLASS, LOCATION, NODE-ID, PARENT are set to the returned entity."
             :new      t
             :parent   parent
             :location location
-            :node-id (if (eq number 0)
-                         node-id
-                       (nconc (list number) node-id))
-            ))
+            :node-id  node-id))
       (while (and (setq curp (car bodystructure))
                  (listp curp))
        (setq children
@@ -103,43 +104,23 @@ CLASS, LOCATION, NODE-ID, PARENT are set to the returned entity."
                     (list
                      (mmimap-make-mime-entity curp class
                                               location
-                                              (if (eq number 0)
-                                                  node-id
-                                                (nconc (list number) node-id))
+                                              node-id
                                               num
                                               entity))))
        (setq num (+ num 1))
        (setq bodystructure (cdr bodystructure)))
       (mime-entity-set-children-internal entity children)
-      (setq content-type (list (cons 'type 'multipart)))
-      (if (car bodystructure)
-         (setq content-type (nconc content-type
-                                   (list (cons 'subtype
-                                               (intern
-                                                (downcase
-                                                 (car
-                                                  bodystructure))))))))
-      (setq content-type (append content-type
-                                (mmimap-parse-parameters-from-list
-                                 (nth 1 bodystructure))))
-      (mime-entity-set-content-type-internal entity content-type)
+      (mime-entity-set-content-type-internal
+       entity
+       (make-mime-content-type 'multipart
+                              (if (car bodystructure)
+                                  (intern (downcase
+                                           (car bodystructure))))
+                              (mime-decode-parameters
+                               (nth 1 bodystructure))))
       entity))
    (t ; singlepart
     (let (content-type entity)
-      (setq content-type
-           (list (cons 'type (intern (downcase (car bodystructure))))))
-      (if (nth 1 bodystructure)
-         (setq content-type (append content-type
-                                    (list
-                                     (cons 'subtype
-                                           (intern
-                                            (downcase
-                                             (nth 1 bodystructure))))))))
-      (if (nth 2 bodystructure)
-         (setq content-type (append content-type
-                                    (mmimap-parse-parameters-from-list
-                                     (nth 2 bodystructure)))))
-      (setq node-id (nconc (list number) node-id))
       (setq entity
            (luna-make-entity
             class
@@ -149,7 +130,14 @@ CLASS, LOCATION, NODE-ID, PARENT are set to the returned entity."
             :location location
             :parent parent
             :node-id node-id))
-      (mime-entity-set-content-type-internal entity content-type)
+      (mime-entity-set-content-type-internal
+       entity
+       (make-mime-content-type (intern (downcase (car bodystructure)))
+                              (if (nth 1 bodystructure)
+                                  (intern (downcase
+                                           (nth 1 bodystructure))))
+                              (mime-decode-parameters
+                               (nth 2 bodystructure))))
       (mime-entity-set-encoding-internal entity
                                         (and (nth 5 bodystructure)
                                              (downcase
@@ -170,11 +158,11 @@ CLASS, LOCATION, NODE-ID, PARENT are set to the returned entity."
   (if (mime-imap-entity-new-internal entity)
       entity
     (mmimap-make-mime-entity
-     (mime-imap-location-bodystructure 
+     (mime-imap-location-bodystructure
       (mime-entity-location-internal entity))
      (luna-class-name entity)
      (mime-entity-location-internal entity)
-     nil 0 nil)))
+     nil nil nil)))
 
 ;;; @ entity
 ;;
@@ -200,12 +188,18 @@ CLASS, LOCATION, NODE-ID, PARENT are set to the returned entity."
 
 (luna-define-method mime-entity-body ((entity mime-imap-entity))
   (or (mime-imap-entity-body-string-internal entity)
-      (mime-imap-entity-set-body-string-internal
-       entity
-       (mime-imap-location-section-body
-       (mime-entity-location-internal entity)
-       (mmimap-entity-section
-        (mime-entity-node-id-internal entity))))))
+      (if (or (mime-imap-entity-requested-internal entity) ; second time.
+             (mime-imap-location-fetch-entity-p
+              (mime-entity-location-internal entity)
+              entity))
+         (mime-imap-entity-set-body-string-internal
+          entity
+          (mime-imap-location-section-body
+           (mime-entity-location-internal entity)
+           (mmimap-entity-section
+            (mime-entity-node-id-internal entity))))
+       (mime-imap-entity-set-requested-internal entity t)
+       "")))
 
 (luna-define-method mime-insert-entity-body ((entity mime-imap-entity))
   (insert (mime-entity-body entity)))
@@ -246,19 +240,15 @@ CLASS, LOCATION, NODE-ID, PARENT are set to the returned entity."
        entity
        (mime-imap-location-section-body
        (mime-entity-location-internal entity)
-       (if (if (eq (car (mime-entity-node-id-internal entity)) 0)
-               (cdr (mime-entity-node-id-internal entity))
-             (mime-entity-node-id-internal entity))
+       (if (mime-entity-node-id-internal entity)
            (concat (mmimap-entity-section
-                    (if (eq (car (mime-entity-node-id-internal entity)) 0)
-                        (cdr (mime-entity-node-id-internal entity))
-                      (mime-entity-node-id-internal entity)))
+                    (mime-entity-node-id-internal entity))
                    ".HEADER")
          "HEADER")))))
 
 (luna-define-method mime-entity-fetch-field :around
   ((entity mime-imap-entity) field-name)
-  (if (mime-root-entity-p entity) 
+  (if (mime-root-entity-p entity)
       (or (luna-call-next-method)
          (with-temp-buffer
            (insert (mime-imap-entity-header-string entity))