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