X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Fmmimap.el;h=f0e33a2939a71b1dfe814d09b56e09a63b1ea926;hb=e43c5298bb288099406b09f3be0a918eabdefa3c;hp=54a5fafb4ab78b389b421cb758a58d8267dbb37d;hpb=8b003dd16e3d4a1f0d29b5fcd0f57a2ee294f967;p=elisp%2Fwanderlust.git diff --git a/elmo/mmimap.el b/elmo/mmimap.el index 54a5faf..f0e33a2 100644 --- 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))