mime-def.el

   1 ;;; mime-def.el --- definition module about MIME
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: definition, MIME, multimedia, mail, news
   7
   8 ;; This file is part of FLAM (Faithful Library About MIME).
   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 (defconst mime-library-version
  28   '("FLAM-DOODLE" "\e$B4;;R\e(B 7.5YR7.0/11.0" 1 10 0)
  29   "Implementation name, version name and numbers of MIME-library package.")
  30
  31 (defconst mime-library-version-string
  32   `,(concat (car mime-library-version) " "
  33             (mapconcat #'number-to-string
  34                        (cddr mime-library-version) ".")
  35             " - \"" (cadr mime-library-version) "\""))
  36
  37
  38 ;;; @ variables
  39 ;;;
  40
  41 (require 'custom)
  42
  43 (eval-when-compile (require 'cl))
  44
  45 (defgroup mime nil
  46   "Emacs MIME Interfaces"
  47   :group 'news
  48   :group 'mail)
  49
  50 (custom-handle-keyword 'default-mime-charset :group 'mime
  51                        'custom-variable)
  52
  53 (defcustom mime-temp-directory (or (getenv "MIME_TMP_DIR")
  54                                    (getenv "TM_TMP_DIR")
  55                                    (getenv "TMPDIR")
  56                                    (getenv "TMP")
  57                                    (getenv "TEMP")
  58                                    "/tmp/")
  59   "*Directory for temporary files."
  60   :group 'mime
  61   :type 'directory)
  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 ;;; @ required functions
  70 ;;;
  71
  72 (defsubst eliminate-top-spaces (string)
  73   "Eliminate top sequence of space or tab in STRING."
  74   (if (string-match "^[ \t]+" string)
  75       (substring string (match-end 0))
  76     string))
  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 (defconst std11-quoted-pair-regexp "\\\\.")
  89 (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
  90 (defconst std11-qtext-regexp
  91   (concat "[^" (char-list-to-string std11-non-qtext-char-list) "]"))
  92 (defconst std11-quoted-string-regexp
  93   (concat "\""
  94           (regexp-*
  95            (regexp-or std11-qtext-regexp std11-quoted-pair-regexp))
  96           "\""))
  97
  98
  99 ;;; @ about MIME
 100 ;;;
 101
 102 (defconst mime-tspecials "][()<>@,\;:\\\"/?=")
 103 (defconst mime-token-regexp (concat "[^" mime-tspecials "\000-\040]+"))
 104 (defconst mime-charset-regexp mime-token-regexp)
 105
 106 (defconst mime-media-type/subtype-regexp
 107   (concat mime-token-regexp "/" mime-token-regexp))
 108
 109
 110 ;;; @@ base64 / B
 111 ;;;
 112
 113 (defconst base64-token-regexp "[A-Za-z0-9+/]")
 114 (defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
 115
 116 (defconst B-encoded-text-regexp
 117   (concat "\\(\\("
 118           base64-token-regexp
 119           base64-token-regexp
 120           base64-token-regexp
 121           base64-token-regexp
 122           "\\)*"
 123           base64-token-regexp
 124           base64-token-regexp
 125           base64-token-padding-regexp
 126           base64-token-padding-regexp
 127           "\\)"))
 128
 129 ;; (defconst eword-B-encoding-and-encoded-text-regexp
 130 ;;   (concat "\\(B\\)\\?" eword-B-encoded-text-regexp))
 131
 132
 133 ;;; @@ Quoted-Printable / Q
 134 ;;;
 135
 136 (defconst quoted-printable-hex-chars "0123456789ABCDEF")
 137
 138 (defconst quoted-printable-octet-regexp
 139   (concat "=[" quoted-printable-hex-chars
 140           "][" quoted-printable-hex-chars "]"))
 141
 142 (defconst Q-encoded-text-regexp
 143   (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
 144
 145 ;; (defconst eword-Q-encoding-and-encoded-text-regexp
 146 ;;   (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp))
 147
 148
 149 ;;; @ Content-Type
 150 ;;;
 151
 152 (defsubst make-mime-content-type (type subtype &optional parameters)
 153   (list* (cons 'type type)
 154          (cons 'subtype subtype)
 155          (nreverse parameters))
 156   )
 157
 158 (defsubst mime-content-type-primary-type (content-type)
 159   "Return primary-type of CONTENT-TYPE."
 160   (cdr (car content-type)))
 161
 162 (defsubst mime-content-type-subtype (content-type)
 163   "Return primary-type of CONTENT-TYPE."
 164   (cdr (cadr content-type)))
 165
 166 (defsubst mime-content-type-parameters (content-type)
 167   "Return primary-type of CONTENT-TYPE."
 168   (cddr content-type))
 169
 170 (defsubst mime-content-type-parameter (content-type parameter)
 171   "Return PARAMETER value of CONTENT-TYPE."
 172   (cdr (assoc parameter (mime-content-type-parameters content-type))))
 173
 174
 175 (defsubst mime-type/subtype-string (type &optional subtype)
 176   "Return type/subtype string from TYPE and SUBTYPE."
 177   (if type
 178       (if subtype
 179           (format "%s/%s" type subtype)
 180         (format "%s" type))))
 181
 182
 183 ;;; @ Content-Disposition
 184 ;;;
 185
 186 (defsubst mime-content-disposition-type (content-disposition)
 187   "Return disposition-type of CONTENT-DISPOSITION."
 188   (cdr (car content-disposition)))
 189
 190 (defsubst mime-content-disposition-parameters (content-disposition)
 191   "Return disposition-parameters of CONTENT-DISPOSITION."
 192   (cdr content-disposition))
 193
 194 (defsubst mime-content-disposition-parameter (content-disposition parameter)
 195   "Return PARAMETER value of CONTENT-DISPOSITION."
 196   (cdr (assoc parameter (cdr content-disposition))))
 197
 198 (defsubst mime-content-disposition-filename (content-disposition)
 199   "Return filename of CONTENT-DISPOSITION."
 200   (mime-content-disposition-parameter content-disposition "filename"))
 201
 202
 203 ;;; @ MIME entity
 204 ;;;
 205
 206 (defsubst make-mime-entity-internal (representation-type location
 207                                      &optional content-type
 208                                      children parent node-id
 209                                      buffer
 210                                      header-start header-end
 211                                      body-start body-end)
 212   (vector representation-type location
 213           content-type nil nil children parent node-id
 214           buffer header-start header-end body-start body-end
 215           nil nil))
 216
 217 (defsubst mime-entity-representation-type-internal (entity)
 218   (aref entity 0))
 219 (defsubst mime-entity-set-representation-type-internal (entity type)
 220   (aset entity 0 type))
 221 (defsubst mime-entity-location-internal (entity)
 222   (aref entity 1))
 223
 224 (defsubst mime-entity-content-type-internal (entity)
 225   (aref entity 2))
 226 (defsubst mime-entity-set-content-type-internal (entity type)
 227   (aset entity 2 type))
 228 (defsubst mime-entity-content-disposition-internal (entity)
 229   (aref entity 3))
 230 (defsubst mime-entity-set-content-disposition-internal (entity disposition)
 231   (aset entity 3 disposition))
 232 (defsubst mime-entity-encoding-internal (entity)
 233   (aref entity 4))
 234 (defsubst mime-entity-set-encoding-internal (entity encoding)
 235   (aset entity 4 encoding))
 236
 237 (defsubst mime-entity-children-internal (entity)
 238   (aref entity 5))
 239 (defsubst mime-entity-set-children-internal (entity children)
 240   (aset entity 5 children))
 241 (defsubst mime-entity-parent-internal (entity)
 242   (aref entity 6))
 243 (defsubst mime-entity-node-id-internal (entity)
 244   (aref entity 7))
 245
 246 (defsubst mime-entity-buffer-internal (entity)
 247   (aref entity 8))
 248 (defsubst mime-entity-set-buffer-internal (entity buffer)
 249   (aset entity 8 buffer))
 250 (defsubst mime-entity-header-start-internal (entity)
 251   (aref entity 9))
 252 (defsubst mime-entity-set-header-start-internal (entity point)
 253   (aset entity 9 point))
 254 (defsubst mime-entity-header-end-internal (entity)
 255   (aref entity 10))
 256 (defsubst mime-entity-set-header-end-internal (entity point)
 257   (aset entity 10 point))
 258 (defsubst mime-entity-body-start-internal (entity)
 259   (aref entity 11))
 260 (defsubst mime-entity-set-body-start-internal (entity point)
 261   (aset entity 11 point))
 262 (defsubst mime-entity-body-end-internal (entity)
 263   (aref entity 12))
 264 (defsubst mime-entity-set-body-end-internal (entity point)
 265   (aset entity 12 point))
 266
 267 (defsubst mime-entity-original-header-internal (entity)
 268   (aref entity 13))
 269 (defsubst mime-entity-set-original-header-internal (entity header)
 270   (aset entity 13 header))
 271 (defsubst mime-entity-parsed-header-internal (entity)
 272   (aref entity 14))
 273 (defsubst mime-entity-set-parsed-header-internal (entity header)
 274   (aset entity 14 header))
 275
 276
 277 ;;; @ message structure
 278 ;;;
 279
 280 (defvar mime-message-structure nil
 281   "Information about structure of message.
 282 Please use reference function `mime-entity-SLOT' to get value of SLOT.
 283
 284 Following is a list of slots of the structure:
 285
 286 buffer                  buffer includes this entity (buffer).
 287 node-id                 node-id (list of integers)
 288 header-start            minimum point of header in raw-buffer
 289 header-end              maximum point of header in raw-buffer
 290 body-start              minimum point of body in raw-buffer
 291 body-end                maximum point of body in raw-buffer
 292 content-type            content-type (content-type)
 293 content-disposition     content-disposition (content-disposition)
 294 encoding                Content-Transfer-Encoding (string or nil)
 295 children                entities included in this entity (list of entity)
 296
 297 If an entity includes other entities in its body, such as multipart or
 298 message/rfc822, `mime-entity' structures of them are included in
 299 `children', so the `mime-entity' structure become a tree.")
 300
 301 (make-variable-buffer-local 'mime-message-structure)
 302
 303
 304 ;;; @ for mm-backend
 305 ;;;
 306
 307 (require 'alist)
 308
 309 (defvar mime-entity-implementation-alist nil)
 310
 311 (defmacro mm-define-backend (type &optional parents)
 312   (if parents
 313       `(let ((rest ',(reverse parents)))
 314          (while rest
 315            (set-alist 'mime-entity-implementation-alist
 316                       ',type
 317                       (copy-alist
 318                        (cdr (assq (car rest)
 319                                   mime-entity-implementation-alist))))
 320            (setq rest (cdr rest))
 321            ))))
 322
 323 (defmacro mm-define-method (name args &rest body)
 324   (let* ((specializer (car args))
 325          (class (nth 1 specializer))
 326          (self (car specializer)))
 327     `(let ((imps (cdr (assq ',class mime-entity-implementation-alist)))
 328            (func (lambda ,(if self
 329                               (cons self (cdr args))
 330                             (cdr args))
 331                    ,@body)))
 332        (if imps
 333            (set-alist 'mime-entity-implementation-alist
 334                       ',class (put-alist ',name func imps))
 335          (set-alist 'mime-entity-implementation-alist
 336                     ',class
 337                     (list (cons ',name func)))
 338          ))))
 339
 340 (put 'mm-define-method 'lisp-indent-function 'defun)
 341 (put 'mm-define-method 'edebug-form-spec
 342      '(&define name ((arg symbolp) &rest arg) def-body))
 343
 344 (defsubst mm-arglist-to-arguments (arglist)
 345   (let (dest)
 346     (while arglist
 347       (let ((arg (car arglist)))
 348         (or (memq arg '(&optional &rest))
 349             (setq dest (cons arg dest)))
 350         )
 351       (setq arglist (cdr arglist)))
 352     (nreverse dest)))
 353
 354
 355 ;;; @ for mel-backend
 356 ;;;
 357
 358 (defmacro mel-define-service (name &optional args &rest rest)
 359   (if args
 360       `(progn
 361          (defvar ,(intern (format "%s-obarray" name)) (make-vector 1 nil))
 362          (defun ,name ,args
 363            ,@rest
 364            (funcall (mel-find-function ',name ,(car (last args)))
 365                     ,@(mm-arglist-to-arguments (butlast args)))
 366            ))
 367     `(defvar ,(intern (format "%s-obarray" name)) (make-vector 1 nil))
 368     ))
 369
 370 (put 'mel-define-service 'lisp-indent-function 'defun)
 371
 372 (defmacro mel-define-method (name args &rest body)
 373   (let* ((specializer (car (last args)))
 374          (class (nth 1 specializer)))
 375     `(progn
 376        (mel-define-service ,name)
 377        (fset (intern ,class ,(intern (format "%s-obarray" name)))
 378              (lambda ,(butlast args)
 379                ,@body)))))
 380
 381 (put 'mel-define-method 'lisp-indent-function 'defun)
 382
 383 (defmacro mel-define-method-function (spec function)
 384   (let* ((name (car spec))
 385          (args (cdr spec))
 386          (specializer (car (last args)))
 387          (class (nth 1 specializer)))
 388     `(let (sym)
 389        (mel-define-service ,name)
 390        (setq sym (intern ,class ,(intern (format "%s-obarray" name))))
 391        (or (fboundp sym)
 392            (fset sym (symbol-function ,function))))))
 393
 394 (defmacro mel-define-function (function spec)
 395   (let* ((name (car spec))
 396          (args (cdr spec))
 397          (specializer (car (last args)))
 398          (class (nth 1 specializer)))
 399     `(progn
 400        (define-function ,function
 401          (intern ,class ,(intern (format "%s-obarray" name))))
 402        )))
 403
 404
 405 ;;; @ end
 406 ;;;
 407
 408 (provide 'mime-def)
 409
 410 ;;; mime-def.el ends here