elmo/mmimap.el

   1 ;;; mmimap.el --- MIME entity module for IMAP4rev1 (RFC2060).
   2 ;;                **** This is EXPERIMENTAL *****
   3
   4 ;; Copyright (C) 2000 Yuuichi Teranishi <teranisi@gohome.org>
   5
   6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   7 ;; Keywords: IMAP, MIME, multimedia, mail, news
   8
   9 ;; This file is part of FLIM (Faithful Library about Internet Message).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; 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 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30
  31 (require 'mmgeneric)
  32 (require 'mime)
  33 (require 'pces)
  34 (require 'mime-parse)
  35
  36 (eval-and-compile
  37   (luna-define-class mime-imap-entity (mime-entity)
  38                      (size header-string body-string new requested))
  39   (luna-define-internal-accessors 'mime-imap-entity))
  40
  41 ;;; @ MIME IMAP location
  42 ;;    It should contain server, mailbox and uid (sequence number).
  43 (eval-and-compile
  44   (luna-define-class mime-imap-location () ()))
  45
  46 (luna-define-generic mime-imap-location-section-body (location section)
  47   "Return a body string from LOCATION which corresponds to SECTION.
  48 SECTION is a section string which is defined in RFC2060.")
  49
  50 (luna-define-generic mime-imap-location-bodystructure (location)
  51   "Return a parsed bodystructure of LOCATION.
  52 `NIL' should be converted to nil, `astring' should be converted to a string.")
  53
  54 (luna-define-generic mime-imap-location-fetch-entity-p (location entity)
  55   "Return non-nil when LOCATION may fetch the ENTITY.")
  56
  57 ;;; @ Subroutines
  58 ;;
  59
  60 (defun mmimap-entity-section (node-id)
  61   "Return a section string from NODE-ID"
  62   (cond
  63    ((null node-id)
  64     "1")
  65    ((numberp node-id)
  66     (number-to-string (1+ node-id)))
  67    ((listp node-id)
  68     (mapconcat
  69      'mmimap-entity-section
  70      (reverse node-id)
  71      "."))))
  72
  73 (eval-and-compile
  74   (defun-maybe mime-decode-parameters (attrlist)
  75     (let (ret-val)
  76       (while attrlist
  77         (setq ret-val (append ret-val
  78                               (list (cons (downcase (car attrlist))
  79                                           (car (cdr attrlist))))))
  80         (setq attrlist (cdr (cdr attrlist))))
  81       ret-val)))
  82
  83 (defun mmimap-make-mime-entity (bodystructure class location node-id number
  84                                               parent)
  85   "Analyze parsed IMAP4 BODYSTRUCTURE response and make MIME entity.
  86 CLASS, LOCATION, NODE-ID, PARENT are set to the returned entity."
  87   (setq node-id (if number (cons number node-id) node-id))
  88   (cond
  89    ((listp (car bodystructure)) ; multipart
  90     (let ((num 0)
  91           curp children content-type entity)
  92       (setq entity
  93             (luna-make-entity
  94              class
  95              :new      t
  96              :parent   parent
  97              :location location
  98              :node-id  node-id))
  99       (while (and (setq curp (car bodystructure))
 100                   (listp curp))
 101         (setq children
 102               (nconc children
 103                      (list
 104                       (mmimap-make-mime-entity curp class
 105                                                location
 106                                                node-id
 107                                                num
 108                                                entity))))
 109         (setq num (+ num 1))
 110         (setq bodystructure (cdr bodystructure)))
 111       (mime-entity-set-children-internal entity children)
 112       (mime-entity-set-content-type-internal
 113        entity
 114        (make-mime-content-type 'multipart
 115                                (if (car bodystructure)
 116                                    (intern (downcase
 117                                             (car bodystructure))))
 118                                (mime-decode-parameters
 119                                 (nth 1 bodystructure))))
 120       entity))
 121    (t ; singlepart
 122     (let (content-type entity)
 123       (setq entity
 124             (luna-make-entity
 125              class
 126              :new  t
 127              :size (nth 6 bodystructure)
 128              :content-type content-type
 129              :location location
 130              :parent parent
 131              :node-id node-id))
 132       (mime-entity-set-content-type-internal
 133        entity
 134        (make-mime-content-type (intern (downcase (car bodystructure)))
 135                                (if (nth 1 bodystructure)
 136                                    (intern (downcase
 137                                             (nth 1 bodystructure))))
 138                                (mime-decode-parameters
 139                                 (nth 2 bodystructure))))
 140       (mime-entity-set-encoding-internal entity
 141                                          (and (nth 5 bodystructure)
 142                                               (downcase
 143                                                (nth 5 bodystructure))))
 144       (if (and (nth 7 bodystructure)
 145                (nth 8 bodystructure))  ; children.
 146           (mime-entity-set-children-internal
 147            entity
 148            (list (mmimap-make-mime-entity
 149                   (nth 8 bodystructure) class
 150                   location node-id nil
 151                   entity))))
 152       entity))))
 153
 154 (luna-define-method initialize-instance :after ((entity mime-imap-entity)
 155                                                 &rest init-args)
 156   ;; To prevent infinite loop...
 157   (if (mime-imap-entity-new-internal entity)
 158       entity
 159     (mmimap-make-mime-entity
 160      (mime-imap-location-bodystructure
 161       (mime-entity-location-internal entity))
 162      (luna-class-name entity)
 163      (mime-entity-location-internal entity)
 164      nil nil nil)))
 165
 166 ;;; @ entity
 167 ;;
 168
 169 (luna-define-method mime-insert-entity ((entity mime-imap-entity))
 170   (if (mime-root-entity-p entity)
 171       (progn
 172         (insert (mime-imap-entity-header-string entity))
 173         (mime-insert-entity-body entity))
 174     ;; Insert body if it is not a multipart.
 175     (unless (eq (mime-content-type-primary-type
 176                  (mime-entity-content-type entity))
 177                 'multipart)
 178       (mime-insert-entity-body entity))))
 179
 180 (luna-define-method mime-write-entity ((entity mime-imap-entity) filename)
 181   (with-temp-buffer
 182     (mime-insert-entity entity)
 183     (write-region-as-raw-text-CRLF (point-min) (point-max) filename)))
 184
 185 ;;; @ entity body
 186 ;;
 187
 188 (luna-define-method mime-entity-body ((entity mime-imap-entity))
 189   (or (mime-imap-entity-body-string-internal entity)
 190       (if (or (mime-imap-entity-requested-internal entity) ; second time.
 191               (mime-imap-location-fetch-entity-p
 192                (mime-entity-location-internal entity)
 193                entity))
 194           (mime-imap-entity-set-body-string-internal
 195            entity
 196            (mime-imap-location-section-body
 197             (mime-entity-location-internal entity)
 198             (mmimap-entity-section
 199              (mime-entity-node-id-internal entity))))
 200         (mime-imap-entity-set-requested-internal entity t)
 201         "")))
 202
 203 (luna-define-method mime-insert-entity-body ((entity mime-imap-entity))
 204   (insert (mime-entity-body entity)))
 205
 206 (luna-define-method mime-write-entity-body ((entity mime-imap-entity)
 207                                             filename)
 208   (with-temp-buffer
 209     (mime-insert-entity-body entity)
 210     (write-region-as-binary (point-min) (point-max) filename)))
 211
 212 ;;; @ entity content
 213 ;;
 214
 215 (luna-define-method mime-entity-content ((entity mime-imap-entity))
 216   (let ((ret (mime-entity-body entity)))
 217     (if ret
 218         (mime-decode-string ret (mime-entity-encoding entity))
 219       (message "Cannot decode content.")
 220       nil)))
 221
 222 (luna-define-method mime-insert-entity-content ((entity mime-imap-entity))
 223   (insert (mime-entity-content entity)))
 224
 225 (luna-define-method mime-write-entity-content ((entity mime-imap-entity)
 226                                                filename)
 227   (with-temp-buffer
 228     (mime-insert-entity-body entity)
 229     (mime-write-decoded-region (point-min) (point-max)
 230                                filename
 231                                (or (mime-entity-encoding entity) "7bit"))))
 232
 233 ;;; @ header field
 234 ;;
 235
 236 (defun mime-imap-entity-header-string (entity)
 237   (or (mime-imap-entity-header-string-internal entity)
 238       (mime-imap-entity-set-header-string-internal
 239        entity
 240        (mime-imap-location-section-body
 241         (mime-entity-location-internal entity)
 242         (if (mime-entity-node-id-internal entity)
 243             (concat (mmimap-entity-section
 244                      (mime-entity-node-id-internal entity))
 245                     ".HEADER")
 246           "HEADER")))))
 247
 248 (luna-define-method mime-entity-fetch-field :around
 249   ((entity mime-imap-entity) field-name)
 250   (if (mime-root-entity-p entity)
 251       (or (luna-call-next-method)
 252           (with-temp-buffer
 253             (insert (mime-imap-entity-header-string entity))
 254             (let ((ret (std11-fetch-field field-name)))
 255               (when ret
 256                 (or (symbolp field-name)
 257                     (setq field-name
 258                           (intern (capitalize (capitalize field-name)))))
 259                 (mime-entity-set-original-header-internal
 260                  entity
 261                  (put-alist field-name ret
 262                             (mime-entity-original-header-internal entity)))
 263                 ret))))))
 264
 265 (luna-define-method mime-insert-header ((entity mime-imap-entity)
 266                                         &optional invisible-fields
 267                                         visible-fields)
 268   (let ((the-buf (current-buffer))
 269         buf p-min p-max)
 270     (with-temp-buffer
 271       (insert (mime-imap-entity-header-string entity))
 272       (setq buf (current-buffer)
 273             p-min (point-min)
 274             p-max (point-max))
 275       (set-buffer the-buf)
 276       (mime-insert-header-from-buffer buf p-min p-max
 277                                       invisible-fields visible-fields))))
 278
 279 ;;; @ end
 280 ;;
 281
 282 (provide 'mmimap)
 283
 284 ;;; mmimap.el ends here