elmo/mmelmo-imap4-2.el

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