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