release.

[elisp/flim.git] / mime-def.el

diff --git a/mime-def.el b/mime-def.el
index 3106078..35bda0d 100644 (file)
--- a/mime-def.el
+++ b/mime-def.el
@@ -1,8 +1,10 @@
 ;;; mime-def.el --- definition module about MIME
 
 ;;; mime-def.el --- definition module about MIME
 

-;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
+;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.

 
 

-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>

 ;; Keywords: definition, MIME, multimedia, mail, news
 
 ;; This file is part of FLIM (Faithful Library about Internet Message).
 ;; Keywords: definition, MIME, multimedia, mail, news
 
 ;; This file is part of FLIM (Faithful Library about Internet Message).

@@ -24,24 +26,30 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

+(require 'poe)
+(require 'poem)
+(require 'pcustom)
+(require 'mcharset)
+(require 'alist)
+

 (eval-and-compile
 (eval-and-compile

-  (defconst mime-library-product ["FLIM" (1 10 4) "Shin-H\e.D\8eòsono"]
+  (defconst mime-library-product ["CLIME" (1 13 3) "\e$BJ?C<\e(B"]

     "Product name, version number and code name of MIME-library package.")
   )
 
 (defmacro mime-product-name (product)
     "Product name, version number and code name of MIME-library package.")
   )
 
 (defmacro mime-product-name (product)

-  `(aref ,product 0))
+  (` (aref (, product) 0)))

 
 (defmacro mime-product-version (product)
 
 (defmacro mime-product-version (product)

-  `(aref ,product 1))
+  (` (aref (, product) 1)))

 
 (defmacro mime-product-code-name (product)
 
 (defmacro mime-product-code-name (product)

-  `(aref ,product 2))
+  (` (aref (, product) 2)))

 
 (defconst mime-library-version
   (eval-when-compile
     (concat (mime-product-name mime-library-product) " "
 
 (defconst mime-library-version
   (eval-when-compile
     (concat (mime-product-name mime-library-product) " "

-           (mapconcat #'number-to-string
+           (mapconcat (function int-to-string)

                       (mime-product-version mime-library-product) ".")
            " - \"" (mime-product-code-name mime-library-product) "\"")))
 
                       (mime-product-version mime-library-product) ".")
            " - \"" (mime-product-code-name mime-library-product) "\"")))
 

@@ -49,28 +57,11 @@
 ;;; @ variables
 ;;;
 
 ;;; @ variables
 ;;;
 

-(require 'custom)
-
-(eval-when-compile (require 'cl))
-
-(defgroup mime nil
+(defgroup mime '((default-mime-charset custom-variable))

   "Emacs MIME Interfaces"
   :group 'news
   :group 'mail)
 
   "Emacs MIME Interfaces"
   :group 'news
   :group 'mail)
 

-(custom-handle-keyword 'default-mime-charset :group 'mime
-                      'custom-variable)
-
-(defcustom mime-temp-directory (or (getenv "MIME_TMP_DIR")
-                                  (getenv "TM_TMP_DIR")
-                                  (getenv "TMPDIR")
-                                  (getenv "TMP")
-                                  (getenv "TEMP")
-                                  "/tmp/")
-  "*Directory for temporary files."
-  :group 'mime
-  :type 'directory)
-

 (defcustom mime-uuencode-encoding-name-list '("x-uue" "x-uuencode")
   "*List of encoding names for uuencode format."
   :group 'mime
 (defcustom mime-uuencode-encoding-name-list '("x-uue" "x-uuencode")
   "*List of encoding names for uuencode format."
   :group 'mime

@@ -80,12 +71,6 @@
 ;;; @ required functions
 ;;;
 
 ;;; @ required functions
 ;;;
 

-(defsubst eliminate-top-spaces (string)
-  "Eliminate top sequence of space or tab in STRING."
-  (if (string-match "^[ \t]+" string)
-      (substring string (match-end 0))
-    string))
-

 (defsubst regexp-* (regexp)
   (concat regexp "*"))
 
 (defsubst regexp-* (regexp)
   (concat regexp "*"))
 

@@ -96,22 +81,29 @@
 ;;; @ about STD 11
 ;;;
 
 ;;; @ about STD 11
 ;;;
 

-(defconst std11-quoted-pair-regexp "\\\\.")
-(defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
-(defconst std11-qtext-regexp
-  (concat "[^" (char-list-to-string std11-non-qtext-char-list) "]"))
+(eval-and-compile
+  (defconst std11-quoted-pair-regexp "\\\\.")
+  (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
+  (defconst std11-qtext-regexp
+    (eval-when-compile
+      (concat "[^" std11-non-qtext-char-list "]"))))

 (defconst std11-quoted-string-regexp
 (defconst std11-quoted-string-regexp

-  (concat "\""
-         (regexp-*
-          (regexp-or std11-qtext-regexp std11-quoted-pair-regexp))
-         "\""))
+  (eval-when-compile
+    (concat "\""
+           (regexp-*
+            (regexp-or std11-qtext-regexp std11-quoted-pair-regexp))
+           "\"")))

 
 
 ;;; @ about MIME
 ;;;
 
 
 
 ;;; @ about MIME
 ;;;
 

-(defconst mime-tspecials "][()<>@,\;:\\\"/?=")
-(defconst mime-token-regexp (concat "[^" mime-tspecials "\000-\040]+"))
+(eval-and-compile
+  (defconst mime-tspecial-char-list
+    '(?\] ?\[ ?\( ?\) ?< ?> ?@ ?, ?\; ?: ?\\ ?\" ?/ ?? ?=)))
+(defconst mime-token-regexp
+  (eval-when-compile
+    (concat "[^" mime-tspecial-char-list "\000-\040]+")))

 (defconst mime-charset-regexp mime-token-regexp)
 
 (defconst mime-media-type/subtype-regexp
 (defconst mime-charset-regexp mime-token-regexp)
 
 (defconst mime-media-type/subtype-regexp

@@ -161,10 +153,9 @@
 ;;;
 
 (defsubst make-mime-content-type (type subtype &optional parameters)
 ;;;
 
 (defsubst make-mime-content-type (type subtype &optional parameters)

-  (list* (cons 'type type)
-        (cons 'subtype subtype)
-        (nreverse parameters))
-  )
+  (cons (cons 'type type)
+       (cons (cons 'subtype subtype)
+             (nreverse parameters))))

 
 (defsubst mime-content-type-primary-type (content-type)
   "Return primary-type of CONTENT-TYPE."
 
 (defsubst mime-content-type-primary-type (content-type)
   "Return primary-type of CONTENT-TYPE."

@@ -214,75 +205,93 @@
 ;;; @ MIME entity
 ;;;
 
 ;;; @ MIME entity
 ;;;
 

-(defsubst make-mime-entity-internal (representation-type location
-                                    &optional content-type
-                                    children parent node-id
-                                    buffer
-                                    header-start header-end
-                                    body-start body-end)
-  (vector representation-type location
-         content-type nil nil children parent node-id
-         buffer header-start header-end body-start body-end
-         nil nil))
-
-(defsubst mime-entity-representation-type-internal (entity)
-  (aref entity 0))
-(defsubst mime-entity-set-representation-type-internal (entity type)
-  (aset entity 0 type))
-(defsubst mime-entity-location-internal (entity)
-  (aref entity 1))
-
-(defsubst mime-entity-content-type-internal (entity)
-  (aref entity 2))
-(defsubst mime-entity-set-content-type-internal (entity type)
-  (aset entity 2 type))
-(defsubst mime-entity-content-disposition-internal (entity)
-  (aref entity 3))
-(defsubst mime-entity-set-content-disposition-internal (entity disposition)
-  (aset entity 3 disposition))
-(defsubst mime-entity-encoding-internal (entity)
-  (aref entity 4))
-(defsubst mime-entity-set-encoding-internal (entity encoding)
-  (aset entity 4 encoding))
-
-(defsubst mime-entity-children-internal (entity)
-  (aref entity 5))
-(defsubst mime-entity-set-children-internal (entity children)
-  (aset entity 5 children))
-(defsubst mime-entity-parent-internal (entity)
-  (aref entity 6))
-(defsubst mime-entity-node-id-internal (entity)
-  (aref entity 7))
-
-(defsubst mime-entity-buffer-internal (entity)
-  (aref entity 8))
-(defsubst mime-entity-set-buffer-internal (entity buffer)
-  (aset entity 8 buffer))
-(defsubst mime-entity-header-start-internal (entity)
-  (aref entity 9))
-(defsubst mime-entity-set-header-start-internal (entity point)
-  (aset entity 9 point))
-(defsubst mime-entity-header-end-internal (entity)
-  (aref entity 10))
-(defsubst mime-entity-set-header-end-internal (entity point)
-  (aset entity 10 point))
-(defsubst mime-entity-body-start-internal (entity)
-  (aref entity 11))
-(defsubst mime-entity-set-body-start-internal (entity point)
-  (aset entity 11 point))
-(defsubst mime-entity-body-end-internal (entity)
-  (aref entity 12))
-(defsubst mime-entity-set-body-end-internal (entity point)
-  (aset entity 12 point))
-
-(defsubst mime-entity-original-header-internal (entity)
-  (aref entity 13))
-(defsubst mime-entity-set-original-header-internal (entity header)
-  (aset entity 13 header))
-(defsubst mime-entity-parsed-header-internal (entity)
-  (aref entity 14))
-(defsubst mime-entity-set-parsed-header-internal (entity header)
-  (aset entity 14 header))
+(require 'luna)
+
+(autoload 'mime-entity-content-type "mime")
+(autoload 'mime-parse-multipart "mime-parse")
+(autoload 'mime-parse-encapsulated "mime-parse")
+(autoload 'mime-entity-content "mime")
+
+(luna-define-class mime-entity ()
+                  (location
+                   content-type children parent
+                   node-id
+                   content-disposition encoding
+                   ;; for other fields
+                   original-header parsed-header))
+
+(defalias 'mime-entity-representation-type-internal 'luna-class-name)
+(defalias 'mime-entity-set-representation-type-internal 'luna-set-class-name)
+
+(luna-define-internal-accessors 'mime-entity)
+
+(luna-define-method mime-entity-fetch-field ((entity mime-entity)
+                                            field-name)
+  (or (symbolp field-name)
+      (setq field-name (intern (capitalize (capitalize field-name)))))
+  (cdr (assq field-name
+            (mime-entity-original-header-internal entity))))
+
+(luna-define-method mime-entity-children ((entity mime-entity))
+  (let* ((content-type (mime-entity-content-type entity))
+        (primary-type (mime-content-type-primary-type content-type)))
+    (cond ((eq primary-type 'multipart)
+          (mime-parse-multipart entity)
+          )
+         ((and (eq primary-type 'message)
+               (memq (mime-content-type-subtype content-type)
+                     '(rfc822 news external-body)
+                     ))
+          (mime-parse-encapsulated entity)
+          ))
+    ))
+
+(luna-define-method mime-insert-text-content ((entity mime-entity))
+  (insert
+   (decode-mime-charset-string (mime-entity-content entity)
+                              (or (mime-content-type-parameter
+                                   (mime-entity-content-type entity)
+                                   "charset")
+                                  default-mime-charset)
+                              'CRLF)
+   ))
+
+
+;;; @ for mm-backend
+;;;
+
+(defmacro mm-expand-class-name (type)
+  (` (intern (format "mime-%s-entity" (, type)))))
+
+(defmacro mm-define-backend (type &optional parents)
+  (` (luna-define-class (, (mm-expand-class-name type))
+                       (, (nconc (mapcar (function
+                                          (lambda (parent)
+                                            (mm-expand-class-name parent)
+                                            ))
+                                         parents)
+                                 '(mime-entity))))))
+
+(defmacro mm-define-method (name args &rest body)
+  (or (eq name 'initialize-instance)
+      (setq name (intern (format "mime-%s" name))))
+  (let ((spec (car args)))
+    (setq args
+         (cons (list (car spec)
+                     (mm-expand-class-name (nth 1 spec)))
+               (cdr args)))
+    (` (luna-define-method (, name) (, args) (,@ body)))
+    ))
+
+(put 'mm-define-method 'lisp-indent-function 'defun)
+
+(def-edebug-spec mm-define-method
+  (&define name ((arg symbolp)
+                [&rest arg]
+                [&optional ["&optional" arg &rest arg]]
+                &optional ["&rest" arg]
+                )
+          def-body))

 
 
 ;;; @ message structure
 
 
 ;;; @ message structure

@@ -294,12 +303,7 @@ Please use reference function `mime-entity-SLOT' to get value of SLOT.
 
 Following is a list of slots of the structure:
 
 
 Following is a list of slots of the structure:
 

-buffer                 buffer includes this entity (buffer).

 node-id                        node-id (list of integers)
 node-id                        node-id (list of integers)

-header-start           minimum point of header in raw-buffer
-header-end             maximum point of header in raw-buffer
-body-start             minimum point of body in raw-buffer
-body-end               maximum point of body in raw-buffer

 content-type           content-type (content-type)
 content-disposition    content-disposition (content-disposition)
 encoding               Content-Transfer-Encoding (string or nil)
 content-type           content-type (content-type)
 content-disposition    content-disposition (content-disposition)
 encoding               Content-Transfer-Encoding (string or nil)

@@ -311,64 +315,7 @@ message/rfc822, `mime-entity' structures of them are included in
 
 (make-variable-buffer-local 'mime-message-structure)
 
 
 (make-variable-buffer-local 'mime-message-structure)
 

-
-;;; @ for mm-backend
-;;;
-
-(require 'alist)
-
-(defvar mime-entity-implementation-alist nil)
-
-(defmacro mm-define-backend (type &optional parents)
-  "Define TYPE as a mm-backend.
-If PARENTS is specified, TYPE inherits PARENTS.
-Each parent must be backend name (symbol)."
-  (if parents
-      `(let ((rest ',(reverse parents)))
-        (while rest
-          (set-alist 'mime-entity-implementation-alist
-                     ',type
-                     (copy-alist
-                      (cdr (assq (car rest)
-                                 mime-entity-implementation-alist))))
-          (setq rest (cdr rest))
-          ))))
-
-(defmacro mm-define-method (name args &rest body)
-  "Define NAME as a method function of (nth 1 (car ARGS)) backend.
-
-ARGS is like an argument list of lambda, but (car ARGS) must be
-specialized parameter.  (car (car ARGS)) is name of variable and (nth
-1 (car ARGS)) is name of backend."
-  (let* ((specializer (car args))
-        (class (nth 1 specializer))
-        (self (car specializer)))
-    `(let ((imps (cdr (assq ',class mime-entity-implementation-alist)))
-          (func (lambda ,(if self
-                             (cons self (cdr args))
-                           (cdr args))
-                  ,@body)))
-       (if imps
-          (set-alist 'mime-entity-implementation-alist
-                     ',class (put-alist ',name func imps))
-        (set-alist 'mime-entity-implementation-alist
-                   ',class
-                   (list (cons ',name func)))
-        ))))
-
-(put 'mm-define-method 'lisp-indent-function 'defun)
-(put 'mm-define-method 'edebug-form-spec
-     '(&define name ((arg symbolp) &rest arg) def-body))
-
-(defsubst mm-arglist-to-arguments (arglist)
-  (let (dest)
-    (while arglist
-      (let ((arg (car arglist)))
-       (or (memq arg '(&optional &rest))
-           (setq dest (cons arg dest)))
-       )
-      (setq arglist (cdr arglist)))
-    (nreverse dest)))
+(make-obsolete-variable 'mime-message-structure "should not use it.")

 
 
 ;;; @ for mel-backend
 
 
 ;;; @ for mel-backend

@@ -380,16 +327,17 @@ specialized parameter.  (car (car ARGS)) is name of variable and (nth
   "Define NAME as a service for Content-Transfer-Encodings.
 If ARGS is specified, NAME is defined as a generic function for the
 service."
   "Define NAME as a service for Content-Transfer-Encodings.
 If ARGS is specified, NAME is defined as a generic function for the
 service."

-  `(progn
-     (add-to-list 'mel-service-list ',name)
-     (defvar ,(intern (format "%s-obarray" name)) (make-vector 1 nil))
-     ,@(if args
-          `((defun ,name ,args
-              ,@rest
-              (funcall (mel-find-function ',name ,(car (last args)))
-                       ,@(mm-arglist-to-arguments (butlast args)))
-              )))
-     ))
+  (` (progn
+       (add-to-list 'mel-service-list '(, name))
+       (defvar (, (intern (format "%s-obarray" name))) (make-vector 7 0))
+       (,@ (if args
+              (` ((defun (, name) (, args)
+                    (,@ rest)
+                    (funcall (mel-find-function '(, name)
+                                                (, (car (last args))))
+                             (,@ (luna-arglist-to-arguments (butlast args))))
+                    )))))
+       )))

 
 (put 'mel-define-service 'lisp-indent-function 'defun)
 
 
 (put 'mel-define-service 'lisp-indent-function 'defun)
 

@@ -430,9 +378,10 @@ service."
 If PARENTS is specified, TYPE inherits PARENTS.
 Each parent must be backend name (string)."
   (cons 'progn
 If PARENTS is specified, TYPE inherits PARENTS.
 Each parent must be backend name (string)."
   (cons 'progn

-       (mapcar (lambda (parent)
-                 `(mel-copy-backend ,parent ,type)
-                 )
+       (mapcar (function
+                (lambda (parent)
+                  (` (mel-copy-backend (, parent) (, type)))
+                  ))

                parents)))
 
 (defmacro mel-define-method (name args &rest body)
                parents)))
 
 (defmacro mel-define-method (name args &rest body)

@@ -442,11 +391,12 @@ specialized parameter.  (car (car (last ARGS))) is name of variable
 and (nth 1 (car (last ARGS))) is name of backend (encoding)."
   (let* ((specializer (car (last args)))
         (class (nth 1 specializer)))
 and (nth 1 (car (last ARGS))) is name of backend (encoding)."
   (let* ((specializer (car (last args)))
         (class (nth 1 specializer)))

-    `(progn
-       (mel-define-service ,name)
-       (fset (intern ,class ,(intern (format "%s-obarray" name)))
-            (lambda ,(butlast args)
-              ,@body)))))
+    (` (progn
+        (mel-define-service (, name))
+        (fset (intern (, class) (, (intern (format "%s-obarray" name))))
+              (function
+               (lambda (, (butlast args))
+                 (,@ body))))))))

 
 (put 'mel-define-method 'lisp-indent-function 'defun)
 
 
 (put 'mel-define-method 'lisp-indent-function 'defun)
 

@@ -460,27 +410,31 @@ variable and (nth 1 (car (last ARGS))) is name of backend (encoding)."
         (args (cdr spec))
         (specializer (car (last args)))
         (class (nth 1 specializer)))
         (args (cdr spec))
         (specializer (car (last args)))
         (class (nth 1 specializer)))

-    `(let (sym)
-       (mel-define-service ,name)
-       (setq sym (intern ,class ,(intern (format "%s-obarray" name))))
-       (or (fboundp sym)
-          (fset sym (symbol-function ,function))))))
+    (` (let (sym)
+        (mel-define-service (, name))
+        (setq sym (intern (, class) (, (intern (format "%s-obarray" name)))))
+        (or (fboundp sym)
+            (fset sym (symbol-function (, function))))))))

 
 (defmacro mel-define-function (function spec)
   (let* ((name (car spec))
         (args (cdr spec))
         (specializer (car (last args)))
         (class (nth 1 specializer)))
 
 (defmacro mel-define-function (function spec)
   (let* ((name (car spec))
         (args (cdr spec))
         (specializer (car (last args)))
         (class (nth 1 specializer)))

-    `(progn
-       (define-function ,function
-        (intern ,class ,(intern (format "%s-obarray" name))))
-       )))
+    (` (progn
+        (define-function (, function)
+          (intern (, class) (, (intern (format "%s-obarray" name)))))
+        ))))

 
 (defvar base64-dl-module
 
 (defvar base64-dl-module

-  (and (fboundp 'dynamic-link)
-       (let ((path (expand-file-name "base64.so" exec-directory)))
-        (and (file-exists-p path)
-             path))))
+  (if (and (fboundp 'base64-encode-string)
+          (subrp (symbol-function 'base64-encode-string)))
+      nil
+    (if (fboundp 'dynamic-link)
+       (let ((path (expand-file-name "base64.so" exec-directory)))
+         (and (file-exists-p path)
+              path)
+         ))))

 
 
 ;;; @ end
 
 
 ;;; @ end