mime.el

   1 ;;; mime.el --- MIME library module
   2
   3 ;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: MIME, multimedia, mail, news
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; 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 ;;; Code:
  26
  27 (require 'alist)
  28 (require 'std11)
  29 (require 'mime-def)
  30 (require 'eword-decode)
  31
  32 (eval-and-compile
  33
  34 (autoload 'eword-encode-header "eword-encode"
  35   "Encode header fields to network representation, such as MIME encoded-word.")
  36
  37 (autoload 'mime-parse-Content-Type "mime-parse"
  38   "Parse STRING as field-body of Content-Type field.")
  39 (autoload 'mime-read-Content-Type "mime-parse"
  40   "Read field-body of Content-Type field from current-buffer,
  41 and return parsed it.")
  42
  43 (autoload 'mime-parse-Content-Disposition "mime-parse"
  44   "Parse STRING as field-body of Content-Disposition field.")
  45 (autoload 'mime-read-Content-Disposition "mime-parse"
  46   "Read field-body of Content-Disposition field from current-buffer,
  47 and return parsed it.")
  48
  49 (autoload 'mime-parse-Content-Transfer-Encoding "mime-parse"
  50   "Parse STRING as field-body of Content-Transfer-Encoding field.")
  51 (autoload 'mime-read-Content-Transfer-Encoding "mime-parse"
  52   "Read field-body of Content-Transfer-Encoding field from
  53 current-buffer, and return it.")
  54
  55 (autoload 'mime-parse-msg-id "mime-parse"
  56   "Parse TOKENS as msg-id of Content-Id or Message-Id field.")
  57
  58 (autoload 'mime-uri-parse-cid "mime-parse"
  59   "Parse STRING as cid URI.")
  60
  61 (autoload 'mime-parse-buffer "mime-parse"
  62   "Parse BUFFER as a MIME message.")
  63
  64 )
  65
  66 ;;; @ Entity Representation and Implementation
  67 ;;;
  68
  69 (defsubst mime-find-function (service type)
  70   (let ((imps (cdr (assq type mime-entity-implementation-alist))))
  71     (if imps
  72         (cdr (assq service imps))
  73       (require (intern (format "mm%s" type)))
  74       (cdr (assq service
  75                  (cdr (assq type mime-entity-implementation-alist))))
  76       )))
  77
  78 (defsubst mime-entity-function (entity service)
  79   (mime-find-function service
  80                       (mime-entity-representation-type-internal entity)))
  81
  82 (defsubst mime-entity-send (entity message &rest args)
  83   "Send MESSAGE to ENTITY with ARGS, and return the result."
  84   (apply (mime-find-function
  85           message (mime-entity-representation-type-internal entity))
  86          entity
  87          args))
  88
  89 (defmacro mm-define-generic (name args &optional doc)
  90   (if doc
  91       `(defun ,(intern (format "mime-%s" name)) ,args
  92          ,doc
  93          (mime-entity-send ,(car args) ',name
  94                            ,@(mm-arglist-to-arguments (cdr args)))
  95          )
  96     `(defun ,(intern (format "mime-%s" name)) ,args
  97        (mime-entity-send ,(car args) ',name
  98                          ,@(mm-arglist-to-arguments (cdr args)))
  99        )))
 100
 101 (put 'mm-define-generic 'lisp-indent-function 'defun)
 102
 103 (defun mime-open-entity (type location)
 104   "Open an entity and return it.
 105 TYPE is representation-type.
 106 LOCATION is location of entity.  Specification of it is depended on
 107 representation-type."
 108   (let ((entity (make-mime-entity-internal type location)))
 109     (mime-entity-send entity 'initialize-instance)
 110     entity))
 111
 112 (mm-define-generic entity-cooked-p (entity)
 113   "Return non-nil if contents of ENTITY has been already code-converted.")
 114
 115
 116 ;;; @ Entity as node of message
 117 ;;;
 118
 119 (defun mime-entity-children (entity)
 120   (or (mime-entity-children-internal entity)
 121       (mime-entity-send entity 'entity-children)))
 122
 123 (defalias 'mime-entity-node-id 'mime-entity-node-id-internal)
 124
 125 (defun mime-entity-number (entity)
 126   "Return entity-number of ENTITY."
 127   (reverse (mime-entity-node-id-internal entity)))
 128
 129 (defun mime-find-entity-from-number (entity-number &optional message)
 130   "Return entity from ENTITY-NUMBER in MESSAGE.
 131 If MESSAGE is not specified, `mime-message-structure' is used."
 132   (or message
 133       (setq message mime-message-structure))
 134   (let ((sn (car entity-number)))
 135     (if (null sn)
 136         message
 137       (let ((rc (nth sn (mime-entity-children message))))
 138         (if rc
 139             (mime-find-entity-from-number (cdr entity-number) rc)
 140           ))
 141       )))
 142
 143 (defun mime-find-entity-from-node-id (entity-node-id &optional message)
 144   "Return entity from ENTITY-NODE-ID in MESSAGE.
 145 If MESSAGE is not specified, `mime-message-structure' is used."
 146   (mime-find-entity-from-number (reverse entity-node-id) message))
 147
 148 (defun mime-find-entity-from-content-id (cid &optional message)
 149   "Return entity from CID in MESSAGE.
 150 If MESSAGE is not specified, `mime-message-structure' is used."
 151   (or message
 152       (setq message mime-message-structure))
 153   (if (equal cid (mime-read-field 'Content-Id message))
 154       message
 155     (let ((children (mime-entity-children message))
 156           ret)
 157       (while (and children
 158                   (null (setq ret (mime-find-entity-from-content-id
 159                                    cid (car children)))))
 160         (setq children (cdr children)))
 161       ret)))
 162
 163 (defun mime-entity-parent (entity &optional message)
 164   "Return mother entity of ENTITY.
 165 If MESSAGE is specified, it is regarded as root entity."
 166   (if (equal entity message)
 167       nil
 168     (mime-entity-parent-internal entity)))
 169
 170 (defun mime-root-entity-p (entity &optional message)
 171   "Return t if ENTITY is root-entity (message).
 172 If MESSAGE is specified, it is regarded as root entity."
 173   (null (mime-entity-parent entity message)))
 174
 175
 176 ;;; @ Entity Buffer
 177 ;;;
 178
 179 (defun mime-entity-buffer (entity)
 180   (or (mime-entity-buffer-internal entity)
 181       (mime-entity-send entity 'entity-buffer)))
 182
 183 (mm-define-generic entity-point-min (entity)
 184   "Return the start point of ENTITY in the buffer which contains ENTITY.")
 185
 186 (mm-define-generic entity-point-max (entity)
 187   "Return the end point of ENTITY in the buffer which contains ENTITY.")
 188
 189 (defun mime-entity-header-start (entity)
 190   (or (mime-entity-header-start-internal entity)
 191       (mime-entity-send entity 'entity-header-start)))
 192
 193 (defun mime-entity-header-end (entity)
 194   (or (mime-entity-header-end-internal entity)
 195       (mime-entity-send entity 'entity-header-end)))
 196
 197 (defun mime-entity-body-start (entity)
 198   (or (mime-entity-body-start-internal entity)
 199       (mime-entity-send entity 'entity-body-start)))
 200
 201 (defun mime-entity-body-end (entity)
 202   (or (mime-entity-body-end-internal entity)
 203       (mime-entity-send entity 'entity-body-end)))
 204
 205
 206 ;;; @ Entity Header
 207 ;;;
 208
 209 (defun mime-fetch-field (field-name &optional entity)
 210   (or (symbolp field-name)
 211       (setq field-name (intern (capitalize (capitalize field-name)))))
 212   (or entity
 213       (setq entity mime-message-structure))
 214   (cond ((eq field-name 'Date)
 215          (or (mime-entity-date-internal entity)
 216              (mime-entity-set-date-internal
 217               entity (mime-entity-send entity 'fetch-field "Date"))
 218              ))
 219         ((eq field-name 'Message-Id)
 220          (or (mime-entity-message-id-internal entity)
 221              (mime-entity-set-message-id-internal
 222               entity (mime-entity-send entity 'fetch-field "Message-Id"))
 223              ))
 224         ((eq field-name 'References)
 225          (or (mime-entity-references-internal entity)
 226              (mime-entity-set-references-internal
 227               entity (mime-entity-send entity 'fetch-field "References"))
 228              ))
 229         (t
 230          (let* ((header (mime-entity-original-header-internal entity))
 231                 (field-body (cdr (assq field-name header))))
 232            (or field-body
 233                (progn
 234                  (if (setq field-body
 235                            (mime-entity-send entity 'fetch-field
 236                                              (symbol-name field-name)))
 237                      (mime-entity-set-original-header-internal
 238                       entity (put-alist field-name field-body header))
 239                    )
 240                  field-body))
 241            ))))
 242
 243 (defun mime-entity-content-type (entity)
 244   (or (mime-entity-content-type-internal entity)
 245       (let ((ret (mime-fetch-field 'Content-Type entity)))
 246         (if ret
 247             (mime-entity-set-content-type-internal
 248              entity (mime-parse-Content-Type ret))
 249           ))))
 250
 251 (defun mime-entity-content-disposition (entity)
 252   (or (mime-entity-content-disposition-internal entity)
 253       (let ((ret (mime-fetch-field 'Content-Disposition entity)))
 254         (if ret
 255             (mime-entity-set-content-disposition-internal
 256              entity (mime-parse-Content-Disposition ret))
 257           ))))
 258
 259 (defun mime-entity-encoding (entity &optional default-encoding)
 260   (or (mime-entity-encoding-internal entity)
 261       (let ((ret (mime-fetch-field 'Content-Transfer-Encoding entity)))
 262         (mime-entity-set-encoding-internal
 263          entity
 264          (or (and ret (mime-parse-Content-Transfer-Encoding ret))
 265              default-encoding "7bit"))
 266         )))
 267
 268 (defvar mime-field-parser-alist
 269   '((Return-Path        . std11-parse-route-addr)
 270
 271     (Reply-To           . std11-parse-addresses)
 272
 273     (Sender             . std11-parse-mailbox)
 274     (From               . std11-parse-addresses)
 275
 276     (Resent-Reply-To    . std11-parse-addresses)
 277
 278     (Resent-Sender      . std11-parse-mailbox)
 279     (Resent-From        . std11-parse-addresses)
 280
 281     (To                 . std11-parse-addresses)
 282     (Resent-To          . std11-parse-addresses)
 283     (Cc                 . std11-parse-addresses)
 284     (Resent-Cc          . std11-parse-addresses)
 285     (Bcc                . std11-parse-addresses)
 286     (Resent-Bcc         . std11-parse-addresses)
 287
 288     (Message-Id         . mime-parse-msg-id)
 289     (Recent-Message-Id  . mime-parse-msg-id)
 290
 291     (In-Reply-To        . std11-parse-msg-ids)
 292     (References         . std11-parse-msg-ids)
 293
 294     (Content-Id         . mime-parse-msg-id)
 295     ))
 296
 297 (defun mime-read-field (field-name &optional entity)
 298   (or (symbolp field-name)
 299       (setq field-name (capitalize (capitalize field-name))))
 300   (or entity
 301       (setq entity mime-message-structure))
 302   (cond ((eq field-name 'Content-Type)
 303          (mime-entity-content-type entity)
 304          )
 305         ((eq field-name 'Content-Disposition)
 306          (mime-entity-content-disposition entity)
 307          )
 308         ((eq field-name 'Content-Transfer-Encoding)
 309          (mime-entity-encoding entity)
 310          )
 311         (t
 312          (let* ((header (mime-entity-parsed-header-internal entity))
 313                 (field (cdr (assq field-name header))))
 314            (or field
 315                (let ((field-body (mime-fetch-field field-name entity))
 316                      parser)
 317                  (when field-body
 318                    (setq parser
 319                          (cdr (assq field-name mime-field-parser-alist)))
 320                    (setq field
 321                          (if parser
 322                              (funcall parser
 323                                       (eword-lexical-analyze field-body))
 324                            (mime-decode-field-body
 325                             field-body field-name 'plain)
 326                            ))
 327                    (mime-entity-set-parsed-header-internal
 328                     entity (put-alist field-name field header))
 329                    field)))))))
 330
 331 (mm-define-generic insert-header (entity &optional invisible-fields
 332                                          visible-fields)
 333   "Insert before point a decoded header of ENTITY.")
 334
 335 (define-obsolete-function-alias
 336   'mime-insert-decoded-header 'mime-insert-header)
 337
 338
 339 ;;; @ Entity Attributes
 340 ;;;
 341
 342 (defun mime-entity-uu-filename (entity)
 343   (if (member (mime-entity-encoding entity) mime-uuencode-encoding-name-list)
 344       (save-excursion
 345         (set-buffer (mime-entity-buffer entity))
 346         (goto-char (mime-entity-body-start entity))
 347         (if (re-search-forward "^begin [0-9]+ "
 348                                (mime-entity-body-end entity) t)
 349             (if (looking-at ".+$")
 350                 (buffer-substring (match-beginning 0)(match-end 0))
 351               )))))
 352
 353 (defun mime-entity-filename (entity)
 354   "Return filename of ENTITY."
 355   (or (mime-entity-uu-filename entity)
 356       (mime-content-disposition-filename
 357        (mime-entity-content-disposition entity))
 358       (cdr (let ((param (mime-content-type-parameters
 359                          (mime-entity-content-type entity))))
 360              (or (assoc "name" param)
 361                  (assoc "x-name" param))
 362              ))))
 363
 364
 365 (defsubst mime-entity-media-type (entity)
 366   (mime-content-type-primary-type (mime-entity-content-type entity)))
 367 (defsubst mime-entity-media-subtype (entity)
 368   (mime-content-type-subtype (mime-entity-content-type entity)))
 369 (defsubst mime-entity-parameters (entity)
 370   (mime-content-type-parameters (mime-entity-content-type entity)))
 371 (defsubst mime-entity-type/subtype (entity-info)
 372   (mime-type/subtype-string (mime-entity-media-type entity-info)
 373                             (mime-entity-media-subtype entity-info)))
 374
 375
 376 ;;; @ Entity Content
 377 ;;;
 378
 379 (mm-define-generic entity-content (entity)
 380   "Return content of ENTITY as byte sequence (string).")
 381
 382 (mm-define-generic insert-entity-content (entity)
 383   "Insert content of ENTITY at point.")
 384
 385 (mm-define-generic write-entity-content (entity filename)
 386   "Write content of ENTITY into FILENAME.")
 387
 388 (mm-define-generic insert-text-content (entity)
 389   "Insert decoded text body of ENTITY.")
 390
 391 (mm-define-generic insert-entity (entity)
 392   "Insert header and body of ENTITY at point.")
 393
 394 (mm-define-generic write-entity (entity filename)
 395   "Write header and body of ENTITY into FILENAME.")
 396
 397 (mm-define-generic write-entity-body (entity filename)
 398   "Write body of ENTITY into FILENAME.")
 399
 400
 401 ;;; @ end
 402 ;;;
 403
 404 (provide 'mime)
 405
 406 ;;; mime.el ends here