;;; mmelmo-imap4.el -- MM backend of IMAP4 for ELMO.
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: mail, net news
;;; Code:
;;
-(static-if (fboundp 'luna-define-method)
- ;; FLIM 1.13 or later
- (require 'mmelmo-imap4-2)
- ;; FLIM 1.12
- (require 'mmelmo-imap4-1))
+(require 'mmbuffer)
-(provide 'mmelmo-imap4)
+(require 'mmelmo)
+
+(defvar mmelmo-imap4-threshold nil)
+(defvar mmelmo-imap4-skipped-parts nil)
+(defvar mmelmo-imap4-current-message-structure nil)
+
+;; Buffer local variable.
+(defvar mmelmo-imap4-fetched nil)
+(make-variable-buffer-local 'mmelmo-imap4-fetched)
+
+(defun mmelmo-imap4-node-id-to-string (node-id)
+ (let ((i (length node-id))
+ result)
+ (while (> i 0)
+ (setq result
+ (concat result
+ (if result
+ (concat "." (int-to-string
+ (+ 1 (nth (- i 1) node-id))))
+ (int-to-string (or
+ (+ 1 (nth (- i 1) node-id))
+ 0)))))
+ (setq i (- i 1)))
+ (or result "0")))
+
+;; parse IMAP4 body structure entity recursively.
+(defun mmelmo-imap4-parse-bodystructure-object (folder
+ number msgdb
+ node-id object parent)
+ (cond
+ ((listp (car object));; multipart
+ (let (cur-obj children content-type ret-val (num 0))
+ (setq ret-val
+ (luna-make-entity
+ (mm-expand-class-name 'elmo-imap4)
+ :folder folder
+ :number number
+ :msgdb msgdb
+ :parent parent
+ :node-id node-id))
+ (while (and (setq cur-obj (car object))
+ (listp cur-obj))
+ (setq children
+ (append children
+ (list
+ (mmelmo-imap4-parse-bodystructure-object
+ folder number msgdb
+ (append (list num) node-id)
+ cur-obj
+ ret-val ; myself as parent
+ ))))
+ (setq num (+ num 1))
+ (setq object (cdr object)))
+ (mime-entity-set-children-internal ret-val children)
+ (setq content-type (list (cons 'type 'multipart)))
+ (if (elmo-imap4-nth 0 object)
+ (setq content-type (append content-type
+ (list (cons 'subtype
+ (intern
+ (downcase
+ (elmo-imap4-nth
+ 0
+ object))))))))
+ (setq content-type (append content-type
+ (mime-parse-parameters-from-list
+ (elmo-imap4-nth 1 object))))
+ (mime-entity-set-content-type-internal ret-val content-type)
+ ret-val))
+ (t ;; singlepart
+ (let (content-type ret-val)
+ ;; append size information into location
+ (setq content-type (list (cons 'type (intern (downcase (car object))))))
+ (if (elmo-imap4-nth 1 object)
+ (setq content-type (append content-type
+ (list
+ (cons 'subtype
+ (intern
+ (downcase
+ (elmo-imap4-nth 1 object))))))))
+ (if (elmo-imap4-nth 2 object)
+ (setq content-type (append content-type
+ (mime-parse-parameters-from-list
+ (elmo-imap4-nth 2 object)))))
+ (setq ret-val
+ (luna-make-entity
+ (mm-expand-class-name 'elmo-imap4)
+ :folder folder
+ :number number
+ :size (nth 6 object)
+ :content-type content-type
+ :parent parent
+ :node-id node-id))
+ (mime-entity-set-encoding-internal ret-val
+ (and (elmo-imap4-nth 5 object)
+ (downcase
+ (elmo-imap4-nth 5 object))))
+ ret-val))))
+
+(defun mmelmo-imap4-multipart-p (entity)
+ (eq (cdr (assq 'type (mime-entity-content-type entity))) 'multipart))
+
+(defun mmelmo-imap4-rfc822part-p (entity)
+ (eq (cdr (assq 'type (mime-entity-content-type entity))) 'rfc822))
+
+(defun mmelmo-imap4-textpart-p (entity)
+ (eq (cdr (assq 'type (mime-entity-content-type entity))) 'text))
+
+(defun mmelmo-imap4-get-mime-entity (folder number msgdb)
+ (let* ((spec (elmo-folder-get-spec folder))
+ (session (elmo-imap4-get-session spec)))
+ (elmo-imap4-session-select-mailbox session (elmo-imap4-spec-mailbox spec))
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-fetch-callback nil)
+ (setq elmo-imap4-fetch-callback-data nil))
+ (mmelmo-imap4-parse-bodystructure-object
+ folder
+ number
+ msgdb
+ nil ; node-id
+ (elmo-imap4-response-value
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session
+ (format
+ (if elmo-imap4-use-uid
+ "uid fetch %s bodystructure"
+ "fetch %s bodystructure")
+ number)) 'fetch) 'bodystructure)
+ nil ; parent
+ )))
+
+(defun mmelmo-imap4-read-part (entity)
+ (if (or (not mmelmo-imap4-threshold)
+ (not (mime-elmo-entity-size-internal entity))
+ (and (mime-elmo-entity-size-internal entity)
+ mmelmo-imap4-threshold
+ (<= (mime-elmo-entity-size-internal entity)
+ mmelmo-imap4-threshold)))
+ (progn
+ (cond ((mmelmo-imap4-multipart-p entity)) ; noop
+ (t (insert (elmo-imap4-read-part
+ (mime-elmo-entity-folder-internal entity)
+ (mime-elmo-entity-number-internal entity)
+ (mmelmo-imap4-node-id-to-string
+ (mime-entity-node-id-internal entity))))))
+ (setq mmelmo-imap4-fetched t)
+ (mime-buffer-entity-set-body-start-internal entity (point-min))
+ (mime-buffer-entity-set-body-end-internal entity (point-max)))
+ (setq mmelmo-imap4-fetched nil)
+ (mime-buffer-entity-set-body-start-internal entity (point-min))
+ (mime-buffer-entity-set-body-end-internal entity (point-min))
+ (setq mmelmo-imap4-skipped-parts
+ (append
+ mmelmo-imap4-skipped-parts
+ (list (mmelmo-imap4-node-id-to-string
+ (mime-entity-node-id-internal entity)))))))
+
+(defun mmelmo-imap4-insert-body (entity)
+ (mime-buffer-entity-set-body-start-internal entity (- (point) 1))
+ (if (or (not mmelmo-imap4-threshold)
+ (not (mime-elmo-entity-size-internal entity))
+ (and (mime-elmo-entity-size-internal entity)
+ mmelmo-imap4-threshold
+ (<= (mime-elmo-entity-size-internal entity)
+ mmelmo-imap4-threshold)))
+ (insert (elmo-imap4-read-part
+ (mime-elmo-entity-folder-internal entity)
+ (mime-elmo-entity-number-internal entity) "1"))
+ (setq mmelmo-imap4-skipped-parts
+ (append
+ mmelmo-imap4-skipped-parts
+ (list (mmelmo-imap4-node-id-to-string
+ (mime-entity-node-id-internal entity)))))))
+
+;;; mime-elmo-imap4-entity class definitions.
+(luna-define-class mime-elmo-imap4-entity (mime-buffer-entity)
+ (imap folder number msgdb size))
+(luna-define-internal-accessors 'mime-elmo-imap4-entity)
+
+(luna-define-method initialize-instance ((entity mime-elmo-imap4-entity)
+ &rest init-args)
+ "The initialization method for elmo-imap4.
+mime-elmo-entity has its own instance variable
+`imap', `folder', `msgdb', and `size'.
+These value must be specified as argument for `luna-make-entity'."
+ (apply (car (luna-class-find-functions
+ (luna-find-class 'standard-object)
+ 'initialize-instance))
+ entity init-args))
+
+(defun mmelmo-imap4-mime-entity-buffer (entity)
+ (if (mime-buffer-entity-buffer-internal entity)
+ (save-excursion
+ (set-buffer (mime-buffer-entity-buffer-internal entity))
+ (unless (mime-root-entity-p entity)
+ (unless mmelmo-imap4-fetched
+ (setq mmelmo-imap4-skipped-parts nil) ; No need?
+ (let ((mmelmo-imap4-threshold
+ (mime-elmo-entity-size-internal entity)))
+ (mime-buffer-entity-set-buffer-internal entity nil)
+ (message "Fetching skipped part...")
+ (mmelmo-imap4-mime-entity-buffer entity)
+ (message "Fetching skipped part...done."))
+ (setq mmelmo-imap4-fetched t)))
+ (mime-buffer-entity-buffer-internal entity))
+ ;; No buffer exist.
+ (save-excursion
+ (set-buffer (get-buffer-create
+ (concat mmelmo-entity-buffer-name
+ (mmelmo-imap4-node-id-to-string
+ (mime-entity-node-id-internal entity)))))
+ (mmelmo-original-mode)
+ (mime-buffer-entity-set-buffer-internal entity (current-buffer))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (mime-entity-node-id entity)
+ (if (mime-root-entity-p entity)
+ (progn
+ ;; root entity
+ (setq mmelmo-imap4-current-message-structure entity)
+ (setq mime-message-structure entity)
+ (setq mmelmo-imap4-skipped-parts nil)
+ ;; insert header
+ (insert (elmo-imap4-read-part
+ (mime-elmo-entity-folder-internal entity)
+ (mime-elmo-entity-number-internal entity)
+ "header"))
+ (mime-buffer-entity-set-header-start-internal
+ entity (point-min))
+ (mime-buffer-entity-set-header-end-internal
+ entity (max (- (point) 1) 1))
+ (if (null (mime-entity-children-internal entity))
+ (progn
+ (mime-buffer-entity-set-body-start-internal
+ entity (point))
+ ;; insert body if size is OK.
+ (mmelmo-imap4-insert-body entity)
+ (mime-buffer-entity-set-body-end-internal
+ entity (point)))))
+ (setq mime-message-structure
+ mmelmo-imap4-current-message-structure)
+ (mmelmo-imap4-read-part entity)))
+ (current-buffer))))
+
+; mime-entity-children
+(luna-define-method mime-entity-children ((entity
+ mime-elmo-imap4-entity))
+ (mime-entity-children-internal entity))
+
+;; override generic function for dynamic body fetching.
+(luna-define-method mime-entity-body ((entity
+ mime-elmo-imap4-entity))
+ (save-excursion
+ (set-buffer (mmelmo-imap4-mime-entity-buffer entity))
+ (buffer-substring (mime-buffer-entity-body-start-internal entity)
+ (mime-buffer-entity-body-end-internal entity))))
+
+(luna-define-method mime-entity-content ((entity
+ mime-elmo-imap4-entity))
+ (save-excursion
+ (set-buffer (mmelmo-imap4-mime-entity-buffer entity))
+ (mime-decode-string
+ (buffer-substring (mime-buffer-entity-body-start-internal entity)
+ (mime-buffer-entity-body-end-internal entity))
+ (mime-entity-encoding entity))))
+
+(luna-define-method mime-entity-fetch-field ((entity mime-elmo-imap4-entity)
+ field-name)
+ (save-excursion
+ (save-restriction
+ (when (mime-buffer-entity-buffer-internal entity)
+ (set-buffer (mime-buffer-entity-buffer-internal entity))
+ (if (and (mime-buffer-entity-header-start-internal entity)
+ (mime-buffer-entity-header-end-internal entity))
+ (progn
+ (narrow-to-region
+ (mime-buffer-entity-header-start-internal entity)
+ (mime-buffer-entity-header-end-internal entity))
+ (std11-fetch-field field-name))
+ nil)))))
+
+(luna-define-method mime-insert-header ((entity mime-elmo-imap4-entity)
+ &optional invisible-fields
+ visible-fields)
+ (mmelmo-insert-sorted-header-from-buffer
+ (mmelmo-imap4-mime-entity-buffer entity)
+ (mime-buffer-entity-header-start-internal entity)
+ (mime-buffer-entity-header-end-internal entity)
+ invisible-fields visible-fields))
+
+(luna-define-method mime-entity-header-buffer ((entity mime-elmo-imap4-entity))
+ (mime-buffer-entity-buffer-internal entity))
+
+(luna-define-method mime-entity-body-buffer ((entity mime-elmo-imap4-entity))
+ (mime-buffer-entity-buffer-internal entity))
+
+(luna-define-method mime-write-entity-content ((entity mime-elmo-imap4-entity)
+ filename)
+ (let ((mmelmo-imap4-threshold (mime-elmo-entity-size-internal entity)))
+ (if (mime-buffer-entity-buffer-internal entity)
+ (save-excursion
+ (set-buffer (mime-buffer-entity-buffer-internal entity))
+ (unless mmelmo-imap4-fetched
+ (setq mmelmo-imap4-skipped-parts nil) ; No need?
+ (mime-buffer-entity-set-buffer-internal entity nil) ; To re-fetch.
+ ))
+ (unless mmelmo-imap4-fetched
+ (setq mmelmo-imap4-skipped-parts nil) ; No need?
+ (let ((mmelmo-imap4-threshold (mime-elmo-entity-size-internal entity)))
+ (mime-buffer-entity-set-buffer-internal entity nil) ; To re-fetch.
+ (message "Fetching skipped part...")
+ (mime-buffer-entity-set-buffer-internal
+ entity
+ (mmelmo-imap4-mime-entity-buffer entity))
+ (message "Fetching skipped part...done.")))
+ (with-current-buffer (mime-buffer-entity-buffer-internal entity)
+ (mime-write-decoded-region
+ (mime-buffer-entity-body-start-internal entity)
+ (mime-buffer-entity-body-end-internal entity)
+ filename
+ (or (mime-entity-encoding entity) "7bit"))))))
+
+(require 'product)
+(product-provide (provide 'mmelmo-imap4) (require 'elmo-version))
;;; mmelmo-imap4.el ends here
projects / elisp / wanderlust.git / blobdiff