mime-def.el

   1 ;;; mime-def.el --- definition module about MIME
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
   5 ;; Licensed to the Free Software Foundation.
   6
   7 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   8 ;;         Keiichi Suzuki <keiichi@nanap.org>
   9 ;; Keywords: definition, MIME, multimedia, mail, news
  10
  11 ;; This file is part of FLIM (Faithful Library about Internet Message).
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Code:
  29
  30 (require 'poe)
  31 (require 'poem)
  32 (require 'pcustom)
  33 (require 'mcharset)
  34 (require 'alist)
  35
  36 (eval-when-compile (require 'cl))       ; list*
  37
  38 (eval-and-compile
  39   (defconst mime-library-product ["FLIM" (1 13 2) "Kasanui"]
  40     "Product name, version number and code name of MIME-library package.")
  41   )
  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
 110 (defconst mime-token-exclude-chars-regexp
 111   (eval-when-compile
 112     (concat mime-tspecial-char-list "\000-\040")))
 113
 114 (defconst mime-token-regexp
 115   (eval-when-compile
 116     (concat "[^" mime-token-exclude-chars-regexp "]+")))
 117
 118 (defconst mime-charset-regexp
 119   (eval-when-compile
 120     (concat "[^" mime-token-exclude-chars-regexp "*]+")))
 121
 122 (defconst mime-media-type/subtype-regexp
 123   (concat mime-token-regexp "/" mime-token-regexp))
 124
 125
 126 ;;; @@ base64 / B
 127 ;;;
 128
 129 (defconst base64-token-regexp "[A-Za-z0-9+/]")
 130 (defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
 131
 132 (defconst B-encoded-text-regexp
 133   (concat "\\(\\("
 134           base64-token-regexp
 135           base64-token-regexp
 136           base64-token-regexp
 137           base64-token-regexp
 138           "\\)*"
 139           base64-token-regexp
 140           base64-token-regexp
 141           base64-token-padding-regexp
 142           base64-token-padding-regexp
 143           "\\)"))
 144
 145 ;; (defconst eword-B-encoding-and-encoded-text-regexp
 146 ;;   (concat "\\(B\\)\\?" eword-B-encoded-text-regexp))
 147
 148
 149 ;;; @@ Quoted-Printable / Q
 150 ;;;
 151
 152 (defconst quoted-printable-hex-chars "0123456789ABCDEF")
 153
 154 (defconst quoted-printable-octet-regexp
 155   (concat "=[" quoted-printable-hex-chars
 156           "][" quoted-printable-hex-chars "]"))
 157
 158 (defconst Q-encoded-text-regexp
 159   (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
 160
 161 ;; (defconst eword-Q-encoding-and-encoded-text-regexp
 162 ;;   (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp))
 163
 164 ;;; @ Parameter
 165 ;;;
 166
 167 (defsubst make-mime-parameter (name &optional language charset
 168                                     raw-values encoded-value)
 169   (cons name
 170         (vector language charset raw-values encoded-value))
 171   )
 172
 173 (defsubst mime-parameter-language (parm)
 174   (aref (cdr parm) 0)
 175   )
 176
 177 (defsubst mime-parameter-set-language (parm language)
 178   (aset (cdr parm) 0 language)
 179   )
 180
 181 (defsubst mime-parameter-set-charset (parm mcs)
 182   (aset (cdr parm) 1 mcs)
 183   )
 184
 185 (defsubst mime-parameter-charset (parm)
 186   (aref (cdr parm) 1)
 187   )
 188
 189 (defsubst mime-parameter-set-raw-values (parm raw-values)
 190   (aset (cdr parm) 2 raw-values)
 191   )
 192
 193 (defsubst mime-parameter-raw-values (parm)
 194   (aref (cdr parm) 2)
 195   )
 196
 197 (defsubst mime-parameter-append-raw-value (parm no encoded raw-value)
 198   (aset (cdr parm) 2 (cons (cons no (cons encoded raw-value))
 199                            (mime-parameter-raw-values parm)))
 200   )
 201
 202 (defun mime-parameter-value (parm)
 203   (when parm
 204     (or (aref (cdr parm) 3)
 205         (let* ((mcs (mime-parameter-charset parm))
 206                (sorted-raw
 207                 (mime-parameter-set-raw-values
 208                  parm
 209                  (sort (mime-parameter-raw-values parm)
 210                        (function (lambda (a b)
 211                                    (< (car a) (car b)))))))
 212                (val
 213                 (if mcs
 214                     (with-temp-buffer
 215                       (let (s raw)
 216                         (while sorted-raw
 217                           (setq raw (cdar sorted-raw)
 218                                 s (point))
 219                           (insert (cdr raw))
 220                           (when (car raw)
 221                             (goto-char s)
 222                             (while (re-search-forward "%\\([0-9a-z][0-9a-z]\\)"
 223                                                       nil t)
 224                               (replace-match
 225                                (char-to-string
 226                                 (string-to-int (buffer-substring
 227                                                 (match-beginning 1)
 228                                                 (match-end 1))
 229                                                16))
 230                                t t))
 231                             (goto-char (point-max))
 232                             )
 233                           (setq sorted-raw (cdr sorted-raw)))
 234                         (decode-mime-charset-region (point-min) (point-max)
 235                                                     mcs)
 236                         (buffer-string)))
 237                   (mapconcat #'cddr sorted-raw "")))
 238                (language (mime-parameter-language parm)))
 239           (when language
 240             (put-text-property 0 (length val)
 241                                'mime-language language val))
 242           (aset (cdr parm) 3 val)
 243           ))))
 244
 245 (defsubst mime-parameters (parms)
 246   (mapcar (function (lambda (parm)
 247                       (cons (car parm)
 248                             (mime-parameter-value parm))))
 249           parms))
 250
 251 (defsubst mime-parameter (parms name)
 252   (let ((parm (assoc name parms)))
 253     (cons (car parm) (mime-parameter-value parm))))
 254
 255 ;;; @ Content-Type
 256 ;;;
 257
 258 (defsubst make-mime-content-type (type subtype &optional parameters)
 259   (list* (cons 'type type)
 260          (cons 'subtype subtype)
 261          (nreverse parameters))
 262   )
 263
 264 (defsubst mime-content-type-primary-type (content-type)
 265   "Return primary-type of CONTENT-TYPE."
 266   (cdr (car content-type)))
 267
 268 (defsubst mime-content-type-subtype (content-type)
 269   "Return primary-type of CONTENT-TYPE."
 270   (cdr (cadr content-type)))
 271
 272 (defsubst mime-content-type-parameters (content-type)
 273   "Return primary-type of CONTENT-TYPE."
 274   (mime-parameters (cddr content-type)))
 275
 276 (defsubst mime-content-type-parameter (content-type parameter)
 277   "Return PARAMETER value of CONTENT-TYPE."
 278   (mime-parameter-value (assoc parameter (cddr content-type))))
 279
 280
 281 (defsubst mime-type/subtype-string (type &optional subtype)
 282   "Return type/subtype string from TYPE and SUBTYPE."
 283   (if type
 284       (if subtype
 285           (format "%s/%s" type subtype)
 286         (format "%s" type))))
 287
 288
 289 ;;; @ Content-Disposition
 290 ;;;
 291
 292 (defsubst mime-content-disposition-type (content-disposition)
 293   "Return disposition-type of CONTENT-DISPOSITION."
 294   (cdr (car content-disposition)))
 295
 296 (defsubst mime-content-disposition-parameters (content-disposition)
 297   "Return disposition-parameters of CONTENT-DISPOSITION."
 298   (mime-parameters (cdr content-disposition)))
 299
 300 (defsubst mime-content-disposition-parameter (content-disposition parameter)
 301   "Return PARAMETER value of CONTENT-DISPOSITION."
 302   (mime-parameter-value (assoc parameter (cdr content-disposition))))
 303
 304 (defsubst mime-content-disposition-filename (content-disposition)
 305   "Return filename of CONTENT-DISPOSITION."
 306   (mime-content-disposition-parameter content-disposition "filename"))
 307
 308
 309 ;;; @ MIME entity
 310 ;;;
 311
 312 (require 'luna)
 313
 314 (autoload 'mime-entity-content-type "mime")
 315 (autoload 'mime-parse-multipart "mime-parse")
 316 (autoload 'mime-parse-encapsulated "mime-parse")
 317 (autoload 'mime-entity-content "mime")
 318
 319 (luna-define-class mime-entity ()
 320                    (location
 321                     content-type children parent
 322                     node-id
 323                     content-disposition encoding
 324                     ;; for other fields
 325                     original-header parsed-header))
 326
 327 (defalias 'mime-entity-representation-type-internal 'luna-class-name)
 328 (defalias 'mime-entity-set-representation-type-internal 'luna-set-class-name)
 329
 330 (luna-define-internal-accessors 'mime-entity)
 331
 332 (luna-define-method mime-entity-fetch-field ((entity mime-entity)
 333                                              field-name)
 334   (or (symbolp field-name)
 335       (setq field-name (intern (capitalize (capitalize field-name)))))
 336   (cdr (assq field-name
 337              (mime-entity-original-header-internal entity))))
 338
 339 (luna-define-method mime-entity-children ((entity mime-entity))
 340   (let* ((content-type (mime-entity-content-type entity))
 341          (primary-type (mime-content-type-primary-type content-type)))
 342     (cond ((eq primary-type 'multipart)
 343            (mime-parse-multipart entity)
 344            )
 345           ((and (eq primary-type 'message)
 346                 (memq (mime-content-type-subtype content-type)
 347                       '(rfc822 news external-body)
 348                       ))
 349            (mime-parse-encapsulated entity)
 350            ))
 351     ))
 352
 353 (luna-define-method mime-insert-text-content ((entity mime-entity))
 354   (insert
 355    (decode-mime-charset-string (mime-entity-content entity)
 356                                (or (mime-content-type-parameter
 357                                     (mime-entity-content-type entity)
 358                                     "charset")
 359                                    default-mime-charset)
 360                                'CRLF)
 361    ))
 362
 363
 364 ;;; @ for mm-backend
 365 ;;;
 366
 367 (defmacro mm-expand-class-name (type)
 368   `(intern (format "mime-%s-entity" ,type)))
 369
 370 (defmacro mm-define-backend (type &optional parents)
 371   `(luna-define-class ,(mm-expand-class-name type)
 372                       ,(nconc (mapcar (lambda (parent)
 373                                         (mm-expand-class-name parent)
 374                                         )
 375                                       parents)
 376                               '(mime-entity))))
 377
 378 (defmacro mm-define-method (name args &rest body)
 379   (or (eq name 'initialize-instance)
 380       (setq name (intern (format "mime-%s" name))))
 381   (let ((spec (car args)))
 382     (setq args
 383           (cons (list (car spec)
 384                       (mm-expand-class-name (nth 1 spec)))
 385                 (cdr args)))
 386     `(luna-define-method ,name ,args ,@body)
 387     ))
 388
 389 (put 'mm-define-method 'lisp-indent-function 'defun)
 390
 391 (def-edebug-spec mm-define-method
 392   (&define name ((arg symbolp)
 393                  [&rest arg]
 394                  [&optional ["&optional" arg &rest arg]]
 395                  &optional ["&rest" arg]
 396                  )
 397            def-body))
 398
 399
 400 ;;; @ message structure
 401 ;;;
 402
 403 (defvar mime-message-structure nil
 404   "Information about structure of message.
 405 Please use reference function `mime-entity-SLOT' to get value of SLOT.
 406
 407 Following is a list of slots of the structure:
 408
 409 node-id                 node-id (list of integers)
 410 content-type            content-type (content-type)
 411 content-disposition     content-disposition (content-disposition)
 412 encoding                Content-Transfer-Encoding (string or nil)
 413 children                entities included in this entity (list of entity)
 414
 415 If an entity includes other entities in its body, such as multipart or
 416 message/rfc822, `mime-entity' structures of them are included in
 417 `children', so the `mime-entity' structure become a tree.")
 418
 419 (make-variable-buffer-local 'mime-message-structure)
 420
 421 (make-obsolete-variable 'mime-message-structure "should not use it.")
 422
 423
 424 ;;; @ for mel-backend
 425 ;;;
 426
 427 (defvar mel-service-list nil)
 428
 429 (defmacro mel-define-service (name &optional args &rest rest)
 430   "Define NAME as a service for Content-Transfer-Encodings.
 431 If ARGS is specified, NAME is defined as a generic function for the
 432 service."
 433   `(progn
 434      (add-to-list 'mel-service-list ',name)
 435      (defvar ,(intern (format "%s-obarray" name)) (make-vector 7 0))
 436      ,@(if args
 437            `((defun ,name ,args
 438                ,@rest
 439                (funcall (mel-find-function ',name ,(car (last args)))
 440                         ,@(luna-arglist-to-arguments (butlast args)))
 441                )))
 442      ))
 443
 444 (put 'mel-define-service 'lisp-indent-function 'defun)
 445
 446
 447 (defvar mel-encoding-module-alist nil)
 448
 449 (defsubst mel-find-function-from-obarray (ob-array encoding)
 450   (let* ((f (intern-soft encoding ob-array)))
 451     (or f
 452         (let ((rest (cdr (assoc encoding mel-encoding-module-alist))))
 453           (while (and rest
 454                       (progn
 455                         (require (car rest))
 456                         (null (setq f (intern-soft encoding ob-array)))
 457                         ))
 458             (setq rest (cdr rest))
 459             )
 460           f))))
 461
 462 (defsubst mel-copy-method (service src-backend dst-backend)
 463   (let* ((oa (symbol-value (intern (format "%s-obarray" service))))
 464          (f (mel-find-function-from-obarray oa src-backend))
 465          sym)
 466     (when f
 467       (setq sym (intern dst-backend oa))
 468       (or (fboundp sym)
 469           (fset sym (symbol-function f))
 470           ))))
 471
 472 (defsubst mel-copy-backend (src-backend dst-backend)
 473   (let ((services mel-service-list))
 474     (while services
 475       (mel-copy-method (car services) src-backend dst-backend)
 476       (setq services (cdr services)))))
 477
 478 (defmacro mel-define-backend (type &optional parents)
 479   "Define TYPE as a mel-backend.
 480 If PARENTS is specified, TYPE inherits PARENTS.
 481 Each parent must be backend name (string)."
 482   (cons 'progn
 483         (mapcar (lambda (parent)
 484                   `(mel-copy-backend ,parent ,type)
 485                   )
 486                 parents)))
 487
 488 (defmacro mel-define-method (name args &rest body)
 489   "Define NAME as a method function of (nth 1 (car (last ARGS))) backend.
 490 ARGS is like an argument list of lambda, but (car (last ARGS)) must be
 491 specialized parameter.  (car (car (last ARGS))) is name of variable
 492 and (nth 1 (car (last ARGS))) is name of backend (encoding)."
 493   (let* ((specializer (car (last args)))
 494          (class (nth 1 specializer)))
 495     `(progn
 496        (mel-define-service ,name)
 497        (fset (intern ,class ,(intern (format "%s-obarray" name)))
 498              (lambda ,(butlast args)
 499                ,@body)))))
 500
 501 (put 'mel-define-method 'lisp-indent-function 'defun)
 502
 503 (defmacro mel-define-method-function (spec function)
 504   "Set SPEC's function definition to FUNCTION.
 505 First element of SPEC is service.
 506 Rest of ARGS is like an argument list of lambda, but (car (last ARGS))
 507 must be specialized parameter.  (car (car (last ARGS))) is name of
 508 variable and (nth 1 (car (last ARGS))) is name of backend (encoding)."
 509   (let* ((name (car spec))
 510          (args (cdr spec))
 511          (specializer (car (last args)))
 512          (class (nth 1 specializer)))
 513     `(let (sym)
 514        (mel-define-service ,name)
 515        (setq sym (intern ,class ,(intern (format "%s-obarray" name))))
 516        (or (fboundp sym)
 517            (fset sym (symbol-function ,function))))))
 518
 519 (defmacro mel-define-function (function spec)
 520   (let* ((name (car spec))
 521          (args (cdr spec))
 522          (specializer (car (last args)))
 523          (class (nth 1 specializer)))
 524     `(progn
 525        (define-function ,function
 526          (intern ,class ,(intern (format "%s-obarray" name))))
 527        )))
 528
 529 (defvar base64-dl-module
 530   (if (and (fboundp 'base64-encode-string)
 531            (subrp (symbol-function 'base64-encode-string)))
 532       nil
 533     (if (fboundp 'dynamic-link)
 534         (let ((path (expand-file-name "base64.so" exec-directory)))
 535           (and (file-exists-p path)
 536                path)
 537           ))))
 538
 539
 540 ;;; @ end
 541 ;;;
 542
 543 (provide 'mime-def)
 544
 545 ;;; mime-def.el ends here