elmo/mmelmo-imap4.el

   1 ;;; mmelmo-imap4.el -- MM backend of IMAP4 for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (require 'mmbuffer)
  33
  34 (require 'mmelmo)
  35
  36 (defvar mmelmo-imap4-threshold nil)
  37 (defvar mmelmo-imap4-skipped-parts nil)
  38 (defvar mmelmo-imap4-current-message-structure nil)
  39
  40 ;; Buffer local variable.
  41 (defvar mmelmo-imap4-fetched nil)
  42 (make-variable-buffer-local 'mmelmo-imap4-fetched)
  43
  44 (defun mmelmo-imap4-node-id-to-string (node-id)
  45   (let ((i (length node-id))
  46         result)
  47     (while (> i 0)
  48       (setq result
  49             (concat result
  50                     (if result
  51                         (concat "." (int-to-string
  52                                      (+ 1 (nth (- i 1) node-id))))
  53                       (int-to-string (or
  54                                       (+ 1 (nth (- i 1) node-id))
  55                                       0)))))
  56       (setq i (- i 1)))
  57     (or result "0")))
  58
  59 ;; parse IMAP4 body structure entity recursively.
  60 (defun mmelmo-imap4-parse-bodystructure-object (folder
  61                                                 number msgdb
  62                                                 node-id object parent)
  63   (cond
  64    ((listp (car object));; multipart
  65     (let (cur-obj children content-type ret-val (num 0))
  66       (setq ret-val
  67             (luna-make-entity
  68              (mm-expand-class-name 'elmo-imap4)
  69              :folder   folder
  70              :number   number
  71              :msgdb    msgdb
  72              :parent   parent
  73              :node-id  node-id))
  74       (while (and (setq cur-obj (car object))
  75                   (listp cur-obj))
  76         (setq children
  77               (append children
  78                       (list
  79                        (mmelmo-imap4-parse-bodystructure-object
  80                         folder number msgdb
  81                         (append (list num) node-id)
  82                         cur-obj
  83                         ret-val ; myself as parent
  84                         ))))
  85         (setq num (+ num 1))
  86         (setq object (cdr object)))
  87       (mime-entity-set-children-internal ret-val children)
  88       (setq content-type (list (cons 'type 'multipart)))
  89       (if (elmo-imap4-nth 0 object)
  90           (setq content-type (append content-type
  91                                      (list (cons 'subtype
  92                                                  (intern
  93                                                   (downcase
  94                                                    (elmo-imap4-nth
  95                                                     0
  96                                                     object))))))))
  97       (setq content-type (append content-type
  98                                  (mime-parse-parameters-from-list
  99                                   (elmo-imap4-nth 1 object))))
 100       (mime-entity-set-content-type-internal ret-val content-type)
 101       ret-val))
 102    (t ;; singlepart
 103     (let (content-type ret-val)
 104       ;; append size information into location
 105       (setq content-type (list (cons 'type (intern (downcase (car object))))))
 106       (if (elmo-imap4-nth 1 object)
 107           (setq content-type (append content-type
 108                                      (list
 109                                       (cons 'subtype
 110                                             (intern
 111                                              (downcase
 112                                               (elmo-imap4-nth 1 object))))))))
 113       (if (elmo-imap4-nth 2 object)
 114           (setq content-type (append content-type
 115                                      (mime-parse-parameters-from-list
 116                                       (elmo-imap4-nth 2 object)))))
 117       (setq ret-val
 118             (luna-make-entity
 119              (mm-expand-class-name 'elmo-imap4)
 120              :folder folder
 121              :number number
 122              :size (nth 6 object)
 123              :content-type content-type
 124              :parent parent
 125              :node-id node-id))
 126       (mime-entity-set-encoding-internal ret-val
 127                                          (and (elmo-imap4-nth 5 object)
 128                                               (downcase
 129                                                (elmo-imap4-nth 5 object))))
 130       ret-val))))
 131
 132 (defun mmelmo-imap4-multipart-p (entity)
 133   (eq (cdr (assq 'type (mime-entity-content-type entity))) 'multipart))
 134
 135 (defun mmelmo-imap4-rfc822part-p (entity)
 136   (eq (cdr (assq 'type (mime-entity-content-type entity))) 'rfc822))
 137
 138 (defun mmelmo-imap4-textpart-p (entity)
 139   (eq (cdr (assq 'type (mime-entity-content-type entity))) 'text))
 140
 141 (defun mmelmo-imap4-get-mime-entity (folder number msgdb)
 142   (let* ((spec (elmo-folder-get-spec folder))
 143          (session (elmo-imap4-get-session spec)))
 144     (elmo-imap4-session-select-mailbox session (elmo-imap4-spec-mailbox spec))
 145     (with-current-buffer (elmo-network-session-buffer session)
 146       (setq elmo-imap4-fetch-callback nil)
 147       (setq elmo-imap4-fetch-callback-data nil))
 148     (mmelmo-imap4-parse-bodystructure-object
 149      folder
 150      number
 151      msgdb
 152      nil ; node-id
 153      (elmo-imap4-response-value
 154       (elmo-imap4-response-value
 155        (elmo-imap4-send-command-wait
 156         session
 157         (format
 158          (if elmo-imap4-use-uid
 159              "uid fetch %s bodystructure"
 160            "fetch %s bodystructure")
 161          number)) 'fetch) 'bodystructure)
 162      nil ; parent
 163      )))
 164
 165 (defun mmelmo-imap4-read-part (entity)
 166   (if (or (not mmelmo-imap4-threshold)
 167           (not (mime-elmo-entity-size-internal entity))
 168           (and (mime-elmo-entity-size-internal entity)
 169                mmelmo-imap4-threshold
 170                (<= (mime-elmo-entity-size-internal entity)
 171                    mmelmo-imap4-threshold)))
 172       (progn
 173         (cond ((mmelmo-imap4-multipart-p entity)) ; noop
 174               (t (insert (elmo-imap4-read-part
 175                           (mime-elmo-entity-folder-internal entity)
 176                           (mime-elmo-entity-number-internal entity)
 177                           (mmelmo-imap4-node-id-to-string
 178                            (mime-entity-node-id-internal entity))))))
 179         (setq mmelmo-imap4-fetched t)
 180         (mime-buffer-entity-set-body-start-internal entity (point-min))
 181         (mime-buffer-entity-set-body-end-internal entity (point-max)))
 182     (setq mmelmo-imap4-fetched nil)
 183     (mime-buffer-entity-set-body-start-internal entity (point-min))
 184     (mime-buffer-entity-set-body-end-internal entity (point-min))
 185     (setq mmelmo-imap4-skipped-parts
 186           (append
 187            mmelmo-imap4-skipped-parts
 188            (list (mmelmo-imap4-node-id-to-string
 189                   (mime-entity-node-id-internal entity)))))))
 190
 191 (defun mmelmo-imap4-insert-body (entity)
 192   (mime-buffer-entity-set-body-start-internal entity (- (point) 1))
 193   (if (or (not mmelmo-imap4-threshold)
 194           (not (mime-elmo-entity-size-internal entity))
 195           (and (mime-elmo-entity-size-internal entity)
 196                mmelmo-imap4-threshold
 197                (<= (mime-elmo-entity-size-internal entity)
 198                    mmelmo-imap4-threshold)))
 199       (insert (elmo-imap4-read-part
 200                (mime-elmo-entity-folder-internal entity)
 201                (mime-elmo-entity-number-internal entity) "1"))
 202     (setq mmelmo-imap4-skipped-parts
 203           (append
 204            mmelmo-imap4-skipped-parts
 205            (list (mmelmo-imap4-node-id-to-string
 206                   (mime-entity-node-id-internal entity)))))))
 207
 208 ;;; mime-elmo-imap4-entity class definitions.
 209 (luna-define-class mime-elmo-imap4-entity (mime-buffer-entity)
 210                    (imap folder number msgdb size))
 211 (luna-define-internal-accessors 'mime-elmo-imap4-entity)
 212
 213 (luna-define-method initialize-instance ((entity mime-elmo-imap4-entity)
 214                                          &rest init-args)
 215   "The initialization method for elmo-imap4.
 216 mime-elmo-entity has its own instance variable
 217 `imap', `folder', `msgdb', and `size'.
 218 These value must be specified as argument for `luna-make-entity'."
 219   (apply (car (luna-class-find-functions
 220                (luna-find-class 'standard-object)
 221                'initialize-instance))
 222          entity init-args))
 223
 224 (defun mmelmo-imap4-mime-entity-buffer (entity)
 225   (if (mime-buffer-entity-buffer-internal entity)
 226       (save-excursion
 227         (set-buffer (mime-buffer-entity-buffer-internal entity))
 228         (unless (mime-root-entity-p entity)
 229           (unless mmelmo-imap4-fetched
 230             (setq mmelmo-imap4-skipped-parts nil) ; No need?
 231             (let ((mmelmo-imap4-threshold
 232                    (mime-elmo-entity-size-internal entity)))
 233               (mime-buffer-entity-set-buffer-internal entity nil)
 234               (message "Fetching skipped part...")
 235               (mmelmo-imap4-mime-entity-buffer entity)
 236               (message "Fetching skipped part...done."))
 237             (setq mmelmo-imap4-fetched t)))
 238         (mime-buffer-entity-buffer-internal entity))
 239     ;; No buffer exist.
 240     (save-excursion
 241       (set-buffer (get-buffer-create
 242                    (concat mmelmo-entity-buffer-name
 243                            (mmelmo-imap4-node-id-to-string
 244                             (mime-entity-node-id-internal entity)))))
 245       (mmelmo-original-mode)
 246       (mime-buffer-entity-set-buffer-internal entity (current-buffer))
 247       (let ((buffer-read-only nil))
 248         (erase-buffer)
 249         (mime-entity-node-id entity)
 250         (if (mime-root-entity-p entity)
 251             (progn
 252               ;; root entity
 253               (setq mmelmo-imap4-current-message-structure entity)
 254               (setq mime-message-structure entity)
 255               (setq mmelmo-imap4-skipped-parts nil)
 256               ;; insert header
 257               (insert (elmo-imap4-read-part
 258                        (mime-elmo-entity-folder-internal entity)
 259                        (mime-elmo-entity-number-internal entity)
 260                        "header"))
 261               (mime-buffer-entity-set-header-start-internal
 262                entity (point-min))
 263               (mime-buffer-entity-set-header-end-internal
 264                entity (max (- (point) 1) 1))
 265               (if (null (mime-entity-children-internal entity))
 266                   (progn
 267                     (mime-buffer-entity-set-body-start-internal
 268                      entity (point))
 269                     ;; insert body if size is OK.
 270                     (mmelmo-imap4-insert-body entity)
 271                     (mime-buffer-entity-set-body-end-internal
 272                      entity (point)))))
 273           (setq mime-message-structure
 274                 mmelmo-imap4-current-message-structure)
 275           (mmelmo-imap4-read-part entity)))
 276       (current-buffer))))
 277
 278 ; mime-entity-children
 279 (luna-define-method mime-entity-children ((entity
 280                                            mime-elmo-imap4-entity))
 281   (mime-entity-children-internal entity))
 282
 283 ;; override generic function for dynamic body fetching.
 284 (luna-define-method mime-entity-body ((entity
 285                                        mime-elmo-imap4-entity))
 286   (save-excursion
 287     (set-buffer (mmelmo-imap4-mime-entity-buffer entity))
 288     (buffer-substring (mime-buffer-entity-body-start-internal entity)
 289                       (mime-buffer-entity-body-end-internal entity))))
 290
 291 (luna-define-method mime-entity-content ((entity
 292                                           mime-elmo-imap4-entity))
 293   (save-excursion
 294     (set-buffer (mmelmo-imap4-mime-entity-buffer entity))
 295     (mime-decode-string
 296      (buffer-substring (mime-buffer-entity-body-start-internal entity)
 297                        (mime-buffer-entity-body-end-internal entity))
 298      (mime-entity-encoding entity))))
 299
 300 (luna-define-method mime-entity-fetch-field ((entity mime-elmo-imap4-entity)
 301                                              field-name)
 302   (save-excursion
 303     (save-restriction
 304       (when (mime-buffer-entity-buffer-internal entity)
 305         (set-buffer (mime-buffer-entity-buffer-internal entity))
 306         (if (and (mime-buffer-entity-header-start-internal entity)
 307                  (mime-buffer-entity-header-end-internal entity))
 308             (progn
 309               (narrow-to-region
 310                (mime-buffer-entity-header-start-internal entity)
 311                (mime-buffer-entity-header-end-internal entity))
 312               (std11-fetch-field field-name))
 313           nil)))))
 314
 315 (luna-define-method mime-insert-header ((entity mime-elmo-imap4-entity)
 316                                         &optional invisible-fields
 317                                         visible-fields)
 318   (mmelmo-insert-sorted-header-from-buffer
 319    (mmelmo-imap4-mime-entity-buffer entity)
 320    (mime-buffer-entity-header-start-internal entity)
 321    (mime-buffer-entity-header-end-internal entity)
 322    invisible-fields visible-fields))
 323
 324 (luna-define-method mime-entity-header-buffer ((entity mime-elmo-imap4-entity))
 325   (mime-buffer-entity-buffer-internal entity))
 326
 327 (luna-define-method mime-entity-body-buffer ((entity mime-elmo-imap4-entity))
 328   (mime-buffer-entity-buffer-internal entity))
 329
 330 (luna-define-method mime-write-entity-content ((entity mime-elmo-imap4-entity)
 331                                                filename)
 332   (let ((mmelmo-imap4-threshold (mime-elmo-entity-size-internal entity)))
 333     (if (mime-buffer-entity-buffer-internal entity)
 334         (save-excursion
 335           (set-buffer (mime-buffer-entity-buffer-internal entity))
 336           (unless mmelmo-imap4-fetched
 337             (setq mmelmo-imap4-skipped-parts nil) ; No need?
 338             (mime-buffer-entity-set-buffer-internal entity nil) ; To re-fetch.
 339             ))
 340       (unless mmelmo-imap4-fetched
 341         (setq mmelmo-imap4-skipped-parts nil) ; No need?
 342         (let ((mmelmo-imap4-threshold (mime-elmo-entity-size-internal entity)))
 343           (mime-buffer-entity-set-buffer-internal entity nil) ; To re-fetch.
 344           (message "Fetching skipped part...")
 345           (mime-buffer-entity-set-buffer-internal
 346            entity
 347            (mmelmo-imap4-mime-entity-buffer entity))
 348           (message "Fetching skipped part...done.")))
 349       (with-current-buffer (mime-buffer-entity-buffer-internal entity)
 350         (mime-write-decoded-region
 351          (mime-buffer-entity-body-start-internal entity)
 352          (mime-buffer-entity-body-end-internal entity)
 353          filename
 354          (or (mime-entity-encoding entity) "7bit"))))))
 355
 356 (require 'product)
 357 (product-provide (provide 'mmelmo-imap4) (require 'elmo-version))
 358
 359 ;;; mmelmo-imap4.el ends here