mime-def.el

   1 ;;; mime-def.el --- definition module about MIME -*- coding: iso-8859-4; -*-
   2
   3 ;; Copyright (C) 1995,96,97,98,99,2000,2001,2002 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   6 ;;      Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   7 ;; Keywords: definition, 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 ;;; Code:
  27
  28 (require 'custom)
  29 (require 'mcharset)
  30 (require 'alist)
  31
  32 (eval-when-compile (require 'luna))     ; luna-arglist-to-arguments
  33
  34 (eval-and-compile
  35   (defconst mime-library-product ["FLIM" (1 14 5) "Demachiyanagi"]
  36     "Product name, version number and code name of MIME-library package."))
  37
  38 (defmacro mime-product-name (product)
  39   `(aref ,product 0))
  40
  41 (defmacro mime-product-version (product)
  42   `(aref ,product 1))
  43
  44 (defmacro mime-product-code-name (product)
  45   `(aref ,product 2))
  46
  47 (defconst mime-library-version
  48   (eval-when-compile
  49     (concat (mime-product-name mime-library-product) " "
  50             (mapconcat #'number-to-string
  51                        (mime-product-version mime-library-product) ".")
  52             " - \"" (mime-product-code-name mime-library-product) "\"")))
  53
  54
  55 ;;; @ variables
  56 ;;;
  57
  58 (defgroup mime '((default-mime-charset custom-variable))
  59   "Emacs MIME Interfaces"
  60   :group 'news
  61   :group 'mail)
  62
  63 (defcustom mime-uuencode-encoding-name-list '("x-uue" "x-uuencode")
  64   "*List of encoding names for uuencode format."
  65   :group 'mime
  66   :type '(repeat string))
  67
  68
  69 ;;; @@ for encoded-word
  70 ;;;
  71
  72 (defgroup mime-header nil
  73   "Header representation, specially encoded-word"
  74   :group 'mime)
  75
  76 ;;; @@@ decoding
  77 ;;;
  78
  79 (defcustom mime-field-decoding-max-size 1000
  80   "*Max size to decode header field."
  81   :group 'mime-header
  82   :type '(choice (integer :tag "Limit (bytes)")
  83                  (const :tag "Don't limit" nil)))
  84
  85 ;;; @@@ encoding
  86 ;;;
  87
  88 (defcustom mime-field-encoding-method-alist
  89   '(("X-Nsubject" . iso-2022-jp-2)
  90     ("Newsgroups" . nil)
  91     ("Message-ID" . nil)
  92     (t            . mime)
  93     )
  94   "*Alist to specify field encoding method.
  95 Its key is field-name, value is encoding method.
  96
  97 If method is `mime', this field will be encoded into MIME format.
  98
  99 If method is a MIME-charset, this field will be encoded as the charset
 100 when it must be convert into network-code.
 101
 102 If method is `default-mime-charset', this field will be encoded as
 103 variable `default-mime-charset' when it must be convert into
 104 network-code.
 105
 106 If method is nil, this field will not be encoded."
 107   :group 'mime-header
 108   :type '(repeat (cons (choice :tag "Field"
 109                                (string :tag "Name")
 110                                (const :tag "Default" t))
 111                        (choice :tag "Method"
 112                                (const :tag "MIME conversion" mime)
 113                                (symbol :tag "non-MIME conversion")
 114                                (const :tag "no-conversion" nil)))))
 115
 116
 117 ;;; @ required functions
 118 ;;;
 119
 120 (defsubst regexp-* (regexp)
 121   (concat regexp "*"))
 122
 123 (defsubst regexp-or (&rest args)
 124   (concat "\\(" (mapconcat (function identity) args "\\|") "\\)"))
 125
 126 (or (fboundp 'char-int)
 127     (defalias 'char-int 'identity))
 128
 129
 130 ;;; @ MIME constants
 131 ;;;
 132
 133 (defconst mime-tspecial-char-list
 134   '(?\] ?\[ ?\( ?\) ?< ?> ?@ ?, ?\; ?: ?\\ ?\" ?/ ?? ?=))
 135 (defconst mime-token-regexp
 136   (concat "[^" mime-tspecial-char-list "\000-\040]+"))
 137 (defconst mime-attribute-char-regexp
 138   (concat "[^" mime-tspecial-char-list "\000-\040"
 139           "*'%"                         ; introduced in RFC 2231.
 140           "]"))
 141
 142 (defconst mime-charset-regexp
 143   (concat "[^" mime-tspecial-char-list "\000-\040"
 144           "*'%"                         ; should not include "%"?
 145           "]+"))
 146
 147 ;; More precisely, length of "[A-Za-z]+" is limited to at most 8.
 148 ;; (defconst mime-language-regexp "[A-Za-z]+\\(-[A-Za-z]+\\)*")
 149 (defconst mime-language-regexp "[-A-Za-z]+")
 150
 151 (defconst mime-encoding-regexp mime-token-regexp)
 152
 153
 154 ;;; @@ base64 / B
 155 ;;;
 156
 157 (defconst base64-token-regexp "[A-Za-z0-9+/]")
 158 (defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
 159
 160 (defconst B-encoded-text-regexp
 161   (concat "\\(\\("
 162           base64-token-regexp
 163           base64-token-regexp
 164           base64-token-regexp
 165           base64-token-regexp
 166           "\\)*"
 167           base64-token-regexp
 168           base64-token-regexp
 169           base64-token-padding-regexp
 170           base64-token-padding-regexp
 171           "\\)"))
 172
 173 ;; (defconst eword-B-encoding-and-encoded-text-regexp
 174 ;;   (concat "\\(B\\)\\?" eword-B-encoded-text-regexp))
 175
 176
 177 ;;; @@ Quoted-Printable / Q
 178 ;;;
 179
 180 (defconst quoted-printable-hex-chars "0123456789ABCDEF")
 181
 182 (defconst quoted-printable-octet-regexp
 183   (concat "=[" quoted-printable-hex-chars
 184           "][" quoted-printable-hex-chars "]"))
 185
 186 (defconst Q-encoded-text-regexp
 187   (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
 188
 189 ;; (defconst eword-Q-encoding-and-encoded-text-regexp
 190 ;;   (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp))
 191
 192
 193 ;;; @ Content-Type
 194 ;;;
 195
 196 (defsubst make-mime-content-type (type subtype &optional parameters)
 197   (cons (cons 'type type)
 198         (cons (cons 'subtype subtype)
 199               parameters)))
 200
 201 (defsubst mime-content-type-primary-type (content-type)
 202   "Return primary-type of CONTENT-TYPE."
 203   (cdr (car content-type)))
 204
 205 (defsubst mime-content-type-subtype (content-type)
 206   "Return subtype of CONTENT-TYPE."
 207   (cdr (car (cdr content-type))))
 208
 209 (defsubst mime-content-type-parameters (content-type)
 210   "Return parameters of CONTENT-TYPE."
 211   (cdr (cdr content-type)))
 212
 213 (defsubst mime-content-type-parameter (content-type parameter)
 214   "Return PARAMETER value of CONTENT-TYPE."
 215   (cdr (assoc parameter (cdr (cdr content-type)))))
 216
 217
 218 (defsubst mime-type/subtype-string (type &optional subtype)
 219   "Return type/subtype string from TYPE and SUBTYPE."
 220   (if type
 221       (if subtype
 222           (format "%s/%s" type subtype)
 223         (format "%s" type))))
 224
 225
 226 ;;; @ Content-Disposition
 227 ;;;
 228
 229 (defsubst make-mime-content-disposition (type &optional parameters)
 230   (cons (cons 'type type)
 231         parameters))
 232
 233 (defsubst mime-content-disposition-type (content-disposition)
 234   "Return disposition-type of CONTENT-DISPOSITION."
 235   (cdr (car content-disposition)))
 236
 237 (defsubst mime-content-disposition-parameters (content-disposition)
 238   "Return disposition-parameters of CONTENT-DISPOSITION."
 239   (cdr content-disposition))
 240
 241 (defsubst mime-content-disposition-parameter (content-disposition parameter)
 242   "Return PARAMETER value of CONTENT-DISPOSITION."
 243   (cdr (assoc parameter (cdr content-disposition))))
 244
 245 (defsubst mime-content-disposition-filename (content-disposition)
 246   "Return filename of CONTENT-DISPOSITION."
 247   (mime-content-disposition-parameter content-disposition "filename"))
 248
 249
 250 ;;; @ message structure
 251 ;;;
 252
 253 (defvar mime-message-structure nil
 254   "Information about structure of message.
 255 Please use reference function `mime-entity-SLOT' to get value of SLOT.
 256
 257 Following is a list of slots of the structure:
 258
 259 node-id                 node-id (list of integers)
 260 content-type            content-type (content-type)
 261 content-disposition     content-disposition (content-disposition)
 262 encoding                Content-Transfer-Encoding (string or nil)
 263 children                entities included in this entity (list of entity)
 264
 265 If an entity includes other entities in its body, such as multipart or
 266 message/rfc822, `mime-entity' structures of them are included in
 267 `children', so the `mime-entity' structure become a tree.")
 268
 269 (make-variable-buffer-local 'mime-message-structure)
 270
 271 (make-obsolete-variable 'mime-message-structure "should not use it.")
 272
 273
 274 ;;; @ for mel-backend
 275 ;;;
 276
 277 (defvar mel-service-list nil)
 278
 279 (defmacro mel-define-service (name &optional args &rest rest)
 280   "Define NAME as a service for Content-Transfer-Encodings.
 281 If ARGS is specified, NAME is defined as a generic function for the
 282 service."
 283   `(progn
 284      (add-to-list 'mel-service-list ',name)
 285      (defvar ,(intern (format "%s-obarray" name)) (make-vector 7 0))
 286      ,@(if args
 287            `((defun ,name ,args
 288                ,@rest
 289                (funcall (mel-find-function ',name ,(car (last args)))
 290                         ,@(luna-arglist-to-arguments (butlast args)))
 291                )))
 292      ))
 293
 294 (put 'mel-define-service 'lisp-indent-function 'defun)
 295
 296
 297 (defvar mel-encoding-module-alist nil)
 298
 299 (defsubst mel-find-function-from-obarray (ob-array encoding)
 300   (let* ((f (intern-soft encoding ob-array)))
 301     (or f
 302         (let ((rest (cdr (assoc encoding mel-encoding-module-alist))))
 303           (while (and rest
 304                       (progn
 305                         (require (car rest))
 306                         (null (setq f (intern-soft encoding ob-array)))
 307                         ))
 308             (setq rest (cdr rest))
 309             )
 310           f))))
 311
 312 (defsubst mel-copy-method (service src-backend dst-backend)
 313   (let* ((oa (symbol-value (intern (format "%s-obarray" service))))
 314          (f (mel-find-function-from-obarray oa src-backend))
 315          sym)
 316     (when f
 317       (setq sym (intern dst-backend oa))
 318       (or (fboundp sym)
 319           (fset sym (symbol-function f))
 320           ))))
 321
 322 (defsubst mel-copy-backend (src-backend dst-backend)
 323   (let ((services mel-service-list))
 324     (while services
 325       (mel-copy-method (car services) src-backend dst-backend)
 326       (setq services (cdr services)))))
 327
 328 (defmacro mel-define-backend (type &optional parents)
 329   "Define TYPE as a mel-backend.
 330 If PARENTS is specified, TYPE inherits PARENTS.
 331 Each parent must be backend name (string)."
 332   (cons 'progn
 333         (mapcar (lambda (parent)
 334                   `(mel-copy-backend ,parent ,type)
 335                   )
 336                 parents)))
 337
 338 (defmacro mel-define-method (name args &rest body)
 339   "Define NAME as a method function of (nth 1 (car (last ARGS))) backend.
 340 ARGS is like an argument list of lambda, but (car (last ARGS)) must be
 341 specialized parameter.  (car (car (last ARGS))) is name of variable
 342 and (nth 1 (car (last ARGS))) is name of backend (encoding)."
 343   (let* ((specializer (car (last args)))
 344          (class (nth 1 specializer)))
 345     `(progn
 346        (mel-define-service ,name)
 347        (fset (intern ,class ,(intern (format "%s-obarray" name)))
 348              (lambda ,(butlast args)
 349                ,@body)))))
 350
 351 (put 'mel-define-method 'lisp-indent-function 'defun)
 352
 353 (defmacro mel-define-method-function (spec function)
 354   "Set SPEC's function definition to FUNCTION.
 355 First element of SPEC is service.
 356 Rest of ARGS is like an argument list of lambda, but (car (last ARGS))
 357 must be specialized parameter.  (car (car (last ARGS))) is name of
 358 variable and (nth 1 (car (last ARGS))) is name of backend (encoding)."
 359   (let* ((name (car spec))
 360          (args (cdr spec))
 361          (specializer (car (last args)))
 362          (class (nth 1 specializer)))
 363     `(let (sym)
 364        (mel-define-service ,name)
 365        (setq sym (intern ,class ,(intern (format "%s-obarray" name))))
 366        (or (fboundp sym)
 367            (fset sym (symbol-function ,function))))))
 368
 369 (defmacro mel-define-function (function spec)
 370   (let* ((name (car spec))
 371          (args (cdr spec))
 372          (specializer (car (last args)))
 373          (class (nth 1 specializer)))
 374     `(progn
 375        (define-function ,function
 376          (intern ,class ,(intern (format "%s-obarray" name))))
 377        )))
 378
 379 (defvar base64-dl-module
 380   (if (and (fboundp 'base64-encode-string)
 381            (subrp (symbol-function 'base64-encode-string)))
 382       nil
 383     (if (fboundp 'dynamic-link)
 384         (let ((path (expand-file-name "base64.so" exec-directory)))
 385           (and (file-exists-p path)
 386                path)
 387           ))))
 388
 389
 390 ;;; @ end
 391 ;;;
 392
 393 (provide 'mime-def)
 394
 395 ;;; mime-def.el ends here