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 'static)
  35 (require 'mime-parse)
  36
  37 (eval-and-compile
  38   (luna-define-class mime-imap-entity (mime-entity)
  39                      (size header-string body-string new requested))
  40   (luna-define-internal-accessors 'mime-imap-entity))
  41
  42 ;;; @ MIME IMAP location
  43 ;;    It should contain server, mailbox and uid (sequence number).
  44 (eval-and-compile
  45   (luna-define-class mime-imap-location () ()))
  46
  47 (luna-define-generic mime-imap-location-section-body (location section)
  48   "Return a body string from LOCATION which corresponds to SECTION.
  49 SECTION is a section string which is defined in RFC2060.")
  50
  51 (luna-define-generic mime-imap-location-bodystructure (location)
  52   "Return a parsed bodystructure of LOCATION.
  53 `NIL' should be converted to nil, `astring' should be converted to a string.")
  54
  55 (luna-define-generic mime-imap-location-fetch-entity-p (location entity)
  56   "Return non-nil when LOCATION may fetch the ENTITY.")
  57
  58 ;;; @ Subroutines
  59 ;;
  60
  61 (defun mmimap-entity-section (node-id)
  62   "Return a section string from NODE-ID"
  63   (cond
  64    ((numberp node-id)
  65     (number-to-string (1+ node-id)))
  66    ((listp node-id)
  67     (mapconcat
  68      'mmimap-entity-section
  69      (reverse node-id)
  70      "."))))
  71
  72 (eval-and-compile
  73   (defun-maybe mime-decode-parameters (attrlist)
  74     (let (ret-val)
  75       (while attrlist
  76         (setq ret-val (append ret-val
  77                               (list (cons (downcase (car attrlist))
  78                                           (car (cdr attrlist))))))
  79         (setq attrlist (cdr (cdr attrlist))))
  80       ret-val)))
  81
  82 (defun mmimap-make-mime-entity (bodystructure class location node-id number
  83                                               parent)
  84   "Analyze parsed IMAP4 BODYSTRUCTURE response and make MIME entity.
  85 CLASS, LOCATION, NODE-ID, PARENT are set to the returned entity."
  86   (cond
  87    ((listp (car bodystructure)) ; multipart
  88     (let ((num 0)
  89           curp children content-type entity)
  90       (setq entity
  91             (luna-make-entity
  92              class
  93              :new      t
  94              :parent   parent
  95              :location location
  96              :node-id (if (eq number 0)
  97                           node-id
  98                         (nconc (list number) 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                                                (if (eq number 0)
 107                                                    node-id
 108                                                  (nconc (list number) node-id))
 109                                                num
 110                                                entity))))
 111         (setq num (+ num 1))
 112         (setq bodystructure (cdr bodystructure)))
 113       (mime-entity-set-children-internal entity children)
 114       (mime-entity-set-content-type-internal
 115        entity
 116        (make-mime-content-type 'multipart
 117                                (if (car bodystructure)
 118                                    (intern (downcase
 119                                             (car bodystructure))))
 120                                (mime-decode-parameters
 121                                 (nth 1 bodystructure))))
 122       entity))
 123    (t ; singlepart
 124     (let (content-type entity)
 125       (setq node-id (nconc (list number) node-id))
 126       (setq entity
 127             (luna-make-entity
 128              class
 129              :new  t
 130              :size (nth 6 bodystructure)
 131              :content-type content-type
 132              :location location
 133              :parent parent
 134              :node-id node-id))
 135       (mime-entity-set-content-type-internal
 136        entity
 137        (make-mime-content-type (intern (downcase (car bodystructure)))
 138                                (if (nth 1 bodystructure)
 139                                    (intern (downcase
 140                                             (nth 1 bodystructure))))
 141                                (mime-decode-parameters
 142                                 (nth 2 bodystructure))))
 143       (mime-entity-set-encoding-internal entity
 144                                          (and (nth 5 bodystructure)
 145                                               (downcase
 146                                                (nth 5 bodystructure))))
 147       (if (and (nth 7 bodystructure)
 148                (nth 8 bodystructure))  ; children.
 149           (mime-entity-set-children-internal
 150            entity
 151            (list (mmimap-make-mime-entity
 152                   (nth 8 bodystructure) class
 153                   location node-id 0
 154                   entity))))
 155       entity))))
 156
 157 (luna-define-method initialize-instance :after ((entity mime-imap-entity)
 158                                                 &rest init-args)
 159   ;; To prevent infinite loop...
 160   (if (mime-imap-entity-new-internal entity)
 161       entity
 162     (mmimap-make-mime-entity
 163      (mime-imap-location-bodystructure
 164       (mime-entity-location-internal entity))
 165      (luna-class-name entity)
 166      (mime-entity-location-internal entity)
 167      nil 0 nil)))
 168
 169 ;;; @ entity
 170 ;;
 171
 172 (luna-define-method mime-insert-entity ((entity mime-imap-entity))
 173   (if (mime-root-entity-p entity)
 174       (progn
 175         (insert (mime-imap-entity-header-string entity))
 176         (mime-insert-entity-body entity))
 177     ;; Insert body if it is not a multipart.
 178     (unless (eq (mime-content-type-primary-type
 179                  (mime-entity-content-type entity))
 180                 'multipart)
 181       (mime-insert-entity-body entity))))
 182
 183 (luna-define-method mime-write-entity ((entity mime-imap-entity) filename)
 184   (with-temp-buffer
 185     (mime-insert-entity entity)
 186     (write-region-as-raw-text-CRLF (point-min) (point-max) filename)))
 187
 188 ;;; @ entity body
 189 ;;
 190
 191 (luna-define-method mime-entity-body ((entity mime-imap-entity))
 192   (or (mime-imap-entity-body-string-internal entity)
 193       (if (or (mime-imap-entity-requested-internal entity) ; second time.
 194               (mime-imap-location-fetch-entity-p
 195                (mime-entity-location-internal entity)
 196                entity))
 197           (mime-imap-entity-set-body-string-internal
 198            entity
 199            (mime-imap-location-section-body
 200             (mime-entity-location-internal entity)
 201             (mmimap-entity-section
 202              (mime-entity-node-id-internal entity))))
 203         (mime-imap-entity-set-requested-internal entity t)
 204         "")))
 205
 206 (luna-define-method mime-insert-entity-body ((entity mime-imap-entity))
 207   (insert (mime-entity-body entity)))
 208
 209 (luna-define-method mime-write-entity-body ((entity mime-imap-entity)
 210                                             filename)
 211   (with-temp-buffer
 212     (mime-insert-entity-body entity)
 213     (write-region-as-binary (point-min) (point-max) filename)))
 214
 215 ;;; @ entity content
 216 ;;
 217
 218 (luna-define-method mime-entity-content ((entity mime-imap-entity))
 219   (let ((ret (mime-entity-body entity)))
 220     (if ret
 221         (mime-decode-string ret (mime-entity-encoding entity))
 222       (message "Cannot decode content.")
 223       nil)))
 224
 225 (luna-define-method mime-insert-entity-content ((entity mime-imap-entity))
 226   (insert (mime-entity-content entity)))
 227
 228 (luna-define-method mime-write-entity-content ((entity mime-imap-entity)
 229                                                filename)
 230   (with-temp-buffer
 231     (mime-insert-entity-body entity)
 232     (mime-write-decoded-region (point-min) (point-max)
 233                                filename
 234                                (or (mime-entity-encoding entity) "7bit"))))
 235
 236 ;;; @ header field
 237 ;;
 238
 239 (defun mime-imap-entity-header-string (entity)
 240   (or (mime-imap-entity-header-string-internal entity)
 241       (mime-imap-entity-set-header-string-internal
 242        entity
 243        (mime-imap-location-section-body
 244         (mime-entity-location-internal entity)
 245         (if (if (eq (car (mime-entity-node-id-internal entity)) 0)
 246                 (cdr (mime-entity-node-id-internal entity))
 247               (mime-entity-node-id-internal entity))
 248             (concat (mmimap-entity-section
 249                      (if (eq (car (mime-entity-node-id-internal entity)) 0)
 250                          (cdr (mime-entity-node-id-internal entity))
 251                        (mime-entity-node-id-internal entity)))
 252                     ".HEADER")
 253           "HEADER")))))
 254
 255 (luna-define-method mime-entity-fetch-field :around
 256   ((entity mime-imap-entity) field-name)
 257   (if (mime-root-entity-p entity)
 258       (or (luna-call-next-method)
 259           (with-temp-buffer
 260             (insert (mime-imap-entity-header-string entity))
 261             (let ((ret (std11-fetch-field field-name)))
 262               (when ret
 263                 (or (symbolp field-name)
 264                     (setq field-name
 265                           (intern (capitalize (capitalize field-name)))))
 266                 (mime-entity-set-original-header-internal
 267                  entity
 268                  (put-alist field-name ret
 269                             (mime-entity-original-header-internal entity)))
 270                 ret))))))
 271
 272 (luna-define-method mime-insert-header ((entity mime-imap-entity)
 273                                         &optional invisible-fields
 274                                         visible-fields)
 275   (let ((the-buf (current-buffer))
 276         buf p-min p-max)
 277     (with-temp-buffer
 278       (insert (mime-imap-entity-header-string entity))
 279       (setq buf (current-buffer)
 280             p-min (point-min)
 281             p-max (point-max))
 282       (set-buffer the-buf)
 283       (mime-insert-header-from-buffer buf p-min p-max
 284                                       invisible-fields visible-fields))))
 285
 286 ;;; @ end
 287 ;;
 288
 289 (provide 'mmimap)
 290
 291 ;;; mmimap.el ends here