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