+++ /dev/null
-;;; mmelmo-imap4.el -- MM backend of IMAP4 for ELMO.
-
-;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
-
-;; Author: Yuuichi Teranishi <teranisi@gohome.org>
-;; Keywords: mail, net news
-
-;; This file is part of ELMO (Elisp Library for Message Orchestration).
-
-;; This program 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.
-;;
-;; This program 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:
-;;
-
-(require 'mmbuffer)
-
-(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
+++ /dev/null
-;;; mmelmo.el -- mm-backend by ELMO.
-
-;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
-
-;; Author: Yuuichi Teranishi <teranisi@gohome.org>
-;; Keywords: mail, net news
-
-;; This file is part of ELMO (Elisp Library for Message Orchestration).
-
-;; This program 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.
-;;
-;; This program 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:
-;;
-(require 'elmo-vars)
-(require 'elmo-util)
-(require 'mime-parse)
-(require 'mmbuffer)
-
-(provide 'mmelmo) ; circular dependency
-(require 'mmelmo-imap4)
-
-(eval-and-compile
- (luna-define-class mime-elmo-entity (mime-buffer-entity)
- (imap folder number msgdb size))
- (luna-define-internal-accessors 'mime-elmo-entity))
-
-(defvar mmelmo-force-reload nil)
-(defvar mmelmo-sort-field-list nil)
-
-(defvar mmelmo-header-max-column fill-column
- "*Inserted header is folded with this value.
-If function is specified, its return value is used.")
-
-(defvar mmelmo-header-inserted-hook nil
- "*A hook called when header is inserted.")
-
-(defvar mmelmo-entity-content-inserted-hook nil
- "*A hook called when entity-content is inserted.")
-
-(defun mmelmo-get-original-buffer ()
- (let ((ret-val (get-buffer (concat mmelmo-entity-buffer-name "0"))))
- (if (not ret-val)
- (save-excursion
- (set-buffer (setq ret-val
- (get-buffer-create
- (concat mmelmo-entity-buffer-name "0"))))
- (mmelmo-original-mode)))
- ret-val))
-
-(defun mmelmo-cleanup-entity-buffers ()
- "Cleanup entity buffers of mmelmo."
- (mapcar (lambda (x)
- (if (string-match mmelmo-entity-buffer-name x)
- (kill-buffer x)))
- (mapcar 'buffer-name (buffer-list))))
-
-;; For FLIM 1-13.x
-(defun-maybe mime-entity-body (entity)
- (luna-send entity 'mime-entity-body))
-
-(defun mmelmo-insert-sorted-header-from-buffer (buffer
- start end
- &optional invisible-fields
- visible-fields
- sorted-fields)
- (let ((the-buf (current-buffer))
- (mode-obj (mime-find-field-presentation-method 'wide))
- field-decoder
- f-b p f-e field-name field field-body
- vf-alist (sl sorted-fields))
- (save-excursion
- (set-buffer buffer)
- (save-restriction
- (narrow-to-region start end)
- (goto-char start)
- (while (re-search-forward std11-field-head-regexp nil t)
- (setq f-b (match-beginning 0)
- p (match-end 0)
- field-name (buffer-substring f-b p)
- f-e (std11-field-end))
- (when (mime-visible-field-p field-name
- visible-fields invisible-fields)
- (setq field (intern
- (capitalize (buffer-substring f-b (1- p))))
- field-body (buffer-substring p f-e)
- field-decoder (inline (mime-find-field-decoder-internal
- field mode-obj)))
- (setq vf-alist (append (list
- (cons field-name
- (list field-body field-decoder)))
- vf-alist))))
- (and vf-alist
- (setq vf-alist
- (sort vf-alist
- (function (lambda (s d)
- (let ((n 0) re
- (sf (car s))
- (df (car d)))
- (catch 'done
- (while (setq re (nth n sl))
- (setq n (1+ n))
- (and (string-match re sf)
- (throw 'done t))
- (and (string-match re df)
- (throw 'done nil)))
- t)))))))
- (with-current-buffer the-buf
- (while vf-alist
- (let* ((vf (car vf-alist))
- (field-name (car vf))
- (field-body (car (cdr vf)))
- (field-decoder (car (cdr (cdr vf)))))
- (insert field-name)
- (insert (if field-decoder
- (funcall field-decoder field-body
- (string-width field-name)
- (if (functionp mmelmo-header-max-column)
- (funcall mmelmo-header-max-column)
- mmelmo-header-max-column))
- ;; Don't decode
- field-body))
- (insert "\n"))
- (setq vf-alist (cdr vf-alist)))
- (run-hooks 'mmelmo-header-inserted-hook))))))
-
-(defun mmelmo-original-mode ()
- (setq major-mode 'mmelmo-original-mode)
- (setq buffer-read-only t)
- (elmo-set-buffer-multibyte nil)
- (setq mode-name "MMELMO-Original"))
-
-;; For FLIMs without rfc2231 feature .
-(if (not (fboundp 'mime-parse-parameters-from-list))
- (defun mime-parse-parameters-from-list (attrlist)
- (let (ret-val)
- (if (not (eq (% (length attrlist) 2) 0))
- (message "Invalid attributes."))
- (while attrlist
- (setq ret-val (append ret-val
- (list (cons (downcase (car attrlist))
- (car (cdr attrlist))))))
- (setq attrlist (cdr (cdr attrlist))))
- ret-val)))
-
-(luna-define-method initialize-instance :after ((entity mime-elmo-entity)
- &rest init-args)
- "The initialization method for elmo.
-mime-elmo-entity has its own member variable,
-`imap', `folder', `msgdb' and `size'.
-imap: boolean. if non-nil, entity becomes mime-elmo-imap4-entity class.
-folder: string. folder name.
-msgdb: msgdb of elmo.
-size: size of the entity."
- (if (mime-elmo-entity-imap-internal entity)
- ;; use imap part fetching.
- ;; child mime-entity's class becomes `mime-elmo-imap4-entity'
- ;; which implements `entity-buffer' method.
- (progn
- (let (new-entity)
- (mime-buffer-entity-set-buffer-internal entity nil)
- (setq new-entity
- (mmelmo-imap4-get-mime-entity
- (mime-elmo-entity-folder-internal entity) ; folder
- (mime-elmo-entity-number-internal entity) ; number
- (mime-elmo-entity-msgdb-internal entity) ; msgdb
- ))
- (mime-entity-set-content-type-internal
- entity
- (mime-entity-content-type-internal new-entity))
- (mime-entity-set-encoding-internal
- entity
- (mime-entity-encoding-internal new-entity))
- (mime-entity-set-children-internal
- entity
- (mime-entity-children-internal new-entity))
- (mime-elmo-entity-set-size-internal
- entity
- (mime-elmo-entity-size-internal new-entity))
- (mime-entity-set-representation-type-internal
- entity 'mime-elmo-imap4-entity)
- entity))
- (set-buffer (mime-buffer-entity-buffer-internal entity))
- (mmelmo-original-mode)
- (when (mime-root-entity-p entity)
- (let ((buffer-read-only nil)
- header-end body-start)
- (erase-buffer)
- (elmo-read-msg-with-buffer-cache
- (mime-elmo-entity-folder-internal entity)
- (mime-elmo-entity-number-internal entity)
- (current-buffer)
- (mime-elmo-entity-msgdb-internal entity)
- mmelmo-force-reload)
- (goto-char (point-min))
- (if (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$\\|^$" )
- nil t)
- (setq header-end (match-beginning 0)
- body-start (if (= (match-end 0) (point-max))
- (point-max)
- (1+ (match-end 0))))
- (setq header-end (point-min)
- body-start (point-min)))
- (mime-buffer-entity-set-header-start-internal entity (point-min))
- (mime-buffer-entity-set-header-end-internal entity header-end)
- (mime-buffer-entity-set-body-start-internal entity body-start)
- (mime-buffer-entity-set-body-end-internal entity (point-max))
- (save-restriction
- (narrow-to-region (mime-buffer-entity-header-start-internal entity)
- (mime-buffer-entity-header-end-internal entity))
- (mime-entity-set-content-type-internal
- entity
- (let ((str (std11-fetch-field "Content-Type")))
- (if str
- (mime-parse-Content-Type str)
- ))))))
- entity))
-
-(luna-define-method mime-insert-header ((entity mime-elmo-entity)
- &optional invisible-fields
- visible-fields)
- (mmelmo-insert-sorted-header-from-buffer
- (mime-buffer-entity-buffer-internal entity)
- (mime-buffer-entity-header-start-internal entity)
- (mime-buffer-entity-header-end-internal entity)
- invisible-fields visible-fields mmelmo-sort-field-list))
-
-(luna-define-method mime-insert-text-content :around ((entity
- mime-elmo-entity))
- (luna-call-next-method)
- (run-hooks 'mmelmo-entity-content-inserted-hook))
-
-(luna-define-method mime-entity-body ((entity mime-elmo-entity))
- (with-current-buffer (mime-buffer-entity-buffer-internal 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-entity))
-;; (mime-decode-string
-;; (with-current-buffer (mime-buffer-entity-buffer-internal entity)
-;; (buffer-substring (mime-buffer-entity-body-start-internal entity)
-;; (mime-buffer-entity-body-end-internal entity)))
-;; (mime-entity-encoding entity)))
-
-(require 'product)
-(product-provide (provide 'mmelmo) (require 'elmo-version))
-
-;;; mmelmo.el ends here
projects / elisp / wanderlust.git / commitdiff