elmo/mmelmo-imap4-1.el

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