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