X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-def.el;h=28f7ef188e90f42bd438c119e2dcff525629850f;hb=87db7e6f5e35a4eda35e0c4ab5d06b3b42ee094d;hp=33c44f18a90c3d5b02c53d80c923a4712ddadca7;hpb=84c2657807b24fa75e4f4249d46129f574c83802;p=elisp%2Fsemi.git

diff --git a/mime-def.el b/mime-def.el
index 33c44f1..28f7ef1 100644
--- a/mime-def.el
+++ b/mime-def.el
@@ -3,7 +3,7 @@
 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
 
 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Id: mime-def.el,v 0.17 1997-02-26 04:14:11 tmorioka Exp $
+;; Version: $Id: mime-def.el,v 0.35 1997-02-28 06:46:48 tmorioka Exp $
 ;; Keywords: definition, MIME, multimedia, mail, news
 
 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
@@ -25,7 +25,7 @@
 
 ;;; Code:
 
-(require 'emu)
+(require 'cl)
 
 
 ;;; @ variables
@@ -53,31 +53,145 @@
 (defconst mime/temp-buffer-name " *MIME-temp*")
 
 
+;;; @ definitions about MIME
+;;;
+
+(defconst mime/tspecials "][\000-\040()<>@,\;:\\\"/?.=")
+(defconst mime/token-regexp (concat "[^" mime/tspecials "]+"))
+(defconst mime-charset-regexp mime/token-regexp)
+
+(defconst mime/content-type-subtype-regexp
+  (concat mime/token-regexp "/" mime/token-regexp))
+
+(defconst mime/disposition-type-regexp mime/token-regexp)
+
+
+;;; @ MIME charset
+;;;
+
+(defvar charsets-mime-charset-alist
+  '(((ascii)						. us-ascii)
+    ((ascii latin-iso8859-1)				. iso-8859-1)
+    ((ascii latin-iso8859-2)				. iso-8859-2)
+    ((ascii latin-iso8859-3)				. iso-8859-3)
+    ((ascii latin-iso8859-4)				. iso-8859-4)
+;;; ((ascii cyrillic-iso8859-5)				. iso-8859-5)
+    ((ascii cyrillic-iso8859-5)				. koi8-r)
+    ((ascii arabic-iso8859-6)				. iso-8859-6)
+    ((ascii greek-iso8859-7)				. iso-8859-7)
+    ((ascii hebrew-iso8859-8)				. iso-8859-8)
+    ((ascii latin-iso8859-9)				. iso-8859-9)
+    ((ascii latin-jisx0201
+	    japanese-jisx0208-1978 japanese-jisx0208)	. iso-2022-jp)
+    ((ascii korean-ksc5601)				. euc-kr)
+    ((ascii chinese-gb2312)				. cn-gb-2312)
+    ((ascii chinese-big5-1 chinese-big5-2)		. cn-big5)
+    ((ascii latin-iso8859-1 greek-iso8859-7
+	    latin-jisx0201 japanese-jisx0208-1978
+	    chinese-gb2312 japanese-jisx0208
+	    korean-ksc5601 japanese-jisx0212)		. iso-2022-jp-2)
+    ((ascii latin-iso8859-1 greek-iso8859-7
+	    latin-jisx0201 japanese-jisx0208-1978
+	    chinese-gb2312 japanese-jisx0208
+	    korean-ksc5601 japanese-jisx0212
+	    chinese-cns11643-1 chinese-cns11643-2)	. iso-2022-int-1)
+    ((ascii latin-iso8859-1 latin-iso8859-2
+	    cyrillic-iso8859-5 greek-iso8859-7
+	    latin-jisx0201 japanese-jisx0208-1978
+	    chinese-gb2312 japanese-jisx0208
+	    korean-ksc5601 japanese-jisx0212
+	    chinese-cns11643-1 chinese-cns11643-2
+	    chinese-cns11643-3 chinese-cns11643-4
+	    chinese-cns11643-5 chinese-cns11643-6
+	    chinese-cns11643-7)				. iso-2022-cjk)
+    ))
+
+(defvar default-mime-charset 'x-ctext)
+
+(defvar mime-charset-coding-system-alist
+  '((x-ctext		. ctext)
+    (gb2312		. cn-gb-2312)
+    (iso-2022-jp-2	. iso-2022-ss2-7)
+    ))
+
+(defun mime-charset-to-coding-system (charset &optional lbt)
+  (if (stringp charset)
+      (setq charset (intern (downcase charset)))
+    )
+  (let ((cs
+	 (or (cdr (assq charset mime-charset-coding-system-alist))
+	     (and (coding-system-p charset) charset)
+	     )))
+    (if lbt
+	(intern (concat (symbol-name cs) "-" (symbol-name lbt)))
+      cs)))
+
+(defun detect-mime-charset-region (start end)
+  "Return MIME charset for region between START and END."
+  (charsets-to-mime-charset
+   (find-charset-string (buffer-substring start end))
+   ))
+
+(defun encode-mime-charset-region (start end charset)
+  "Encode the text between START and END as MIME CHARSET."
+  (let ((cs (mime-charset-to-coding-system charset)))
+    (if cs
+	(encode-coding-region start end cs)
+      )))
+
+(defun decode-mime-charset-region (start end charset)
+  "Decode the text between START and END as MIME CHARSET."
+  (let ((cs (mime-charset-to-coding-system charset)))
+    (if cs
+	(decode-coding-region start end cs)
+      )))
+
+(defun encode-mime-charset-string (string charset)
+  "Encode the STRING as MIME CHARSET."
+  (let ((cs (mime-charset-to-coding-system charset)))
+    (if cs
+	(encode-coding-string string cs)
+      string)))
+
+(defun decode-mime-charset-string (string charset)
+  "Decode the STRING as MIME CHARSET."
+  (let ((cs (mime-charset-to-coding-system charset)))
+    (if cs
+	(decode-coding-string string cs)
+      string)))
+
+
 ;;; @ button
 ;;;
 
+(defvar running-xemacs (string-match "XEmacs" emacs-version))
+
+(if running-xemacs
+    (require 'overlay)
+  )
+
 (defvar mime-button-face 'bold
-  "Face used for content-button or URL-button of MIME-Preview buffer.
-\[mime-def.el]")
+  "Face used for content-button or URL-button of MIME-Preview buffer.")
 
-(defvar tm:mouse-face 'highlight
-  "Face used for MIME-preview buffer mouse highlighting. [mime-def.el]")
+(defvar mime-button-mouse-face 'highlight
+  "Face used for MIME-preview buffer mouse highlighting.")
 
-(defun tm:add-button (from to func &optional data)
+(defun mime-add-button (from to func &optional data)
   "Create a button between FROM and TO with callback FUNC and data DATA."
   (and mime-button-face
        (overlay-put (make-overlay from to) 'face mime-button-face))
-  (tl:add-text-properties from to
-			  (append (and tm:mouse-face
-				       (list 'mouse-face tm:mouse-face))
-				  (list 'semi-callback func)
-				  (and data (list 'semi-data data))
-				  ))
+  (add-text-properties from to
+		       (nconc
+			(and mime-button-mouse-face
+			     (list 'mouse-face mime-button-mouse-face))
+			(list 'mime-button-callback func)
+			(and data (list 'mime-button-data data))
+			))
   )
 
-(defvar tm:mother-button-dispatcher nil)
+(defvar mime-button-mother-dispatcher nil)
 
-(defun tm:button-dispatcher (event)
+(defun mime-button-dispatcher (event)
   "Select the button under point."
   (interactive "e")
   (let (buf point func data)
@@ -85,8 +199,8 @@
       (mouse-set-point event)
       (setq buf (current-buffer)
 	    point (point)
-	    func (get-text-property (point) 'semi-callback)
-	    data (get-text-property (point) 'semi-data)
+	    func (get-text-property (point) 'mime-button-callback)
+	    data (get-text-property (point) 'mime-button-data)
 	    )
       )
     (save-excursion
@@ -94,8 +208,8 @@
       (goto-char point)
       (if func
 	  (apply func data)
-	(if (fboundp tm:mother-button-dispatcher)
-	    (funcall tm:mother-button-dispatcher event)
+	(if (fboundp mime-button-mother-dispatcher)
+	    (funcall mime-button-mother-dispatcher event)
 	  )
 	))))
 
@@ -111,9 +225,9 @@
     (fetch-key		mc-pgp-fetch-key		"mc-pgp")
     (snarf-keys		mc-snarf-keys			"mc-toplev")
     ;; for mime-edit
-    (mime-sign		tm:mc-pgp-sign-region		"mime-edit-mc")
+    (mime-sign		tm:mc-pgp-sign-region		"mime-mc")
     (traditional-sign	mc-pgp-sign-region		"mc-pgp")
-    (encrypt		tm:mc-pgp-encrypt-region	"mime-edit-mc")
+    (encrypt		tm:mc-pgp-encrypt-region	"mime-mc")
     (insert-key		mc-insert-public-key		"mc-toplev")
     )
   "Alist of service names vs. corresponding functions and its filenames.
@@ -140,17 +254,160 @@ FUNCTION.")
 	pgp-function-alist)
 
 
-;;; @ definitions about MIME
+;;; @ method selector kernel
 ;;;
 
-(defconst mime/tspecials "][\000-\040()<>@,\;:\\\"/?.=")
-(defconst mime/token-regexp (concat "[^" mime/tspecials "]+"))
-(defconst mime-charset-regexp mime/token-regexp)
+;;; @@ field unifier
+;;;
 
-(defconst mime/content-type-subtype-regexp
-  (concat mime/token-regexp "/" mime/token-regexp))
+(defun field-unifier-for-default (a b)
+  (let ((ret
+	 (cond ((equal a b)    a)
+	       ((null (cdr b)) a)
+	       ((null (cdr a)) b)
+	       )))
+    (if ret
+	(list nil ret nil)
+      )))
+
+(defun field-unifier-for-mode (a b)
+  (let ((va (cdr a)))
+    (if (if (consp va)
+	    (member (cdr b) va)
+	  (equal va (cdr b))
+	  )
+	(list nil b nil)
+      )))
+
+(defun field-unify (a b)
+  (let ((sym (intern (concat "field-unifier-for-" (symbol-name (car a))))))
+    (or (fboundp sym)
+	(setq sym (function field-unifier-for-default))
+	)
+    (funcall sym a b)
+    ))
 
-(defconst mime/disposition-type-regexp mime/token-regexp)
+
+;;; @@ type unifier
+;;;
+
+(defun assoc-unify (class instance)
+  (catch 'tag
+    (let ((cla (copy-alist class))
+	  (ins (copy-alist instance))
+	  (r class)
+	  cell aret ret prev rest)
+      (while r
+	(setq cell (car r))
+	(setq aret (assoc (car cell) ins))
+	(if aret
+	    (if (setq ret (field-unify cell aret))
+		(progn
+		  (if (car ret)
+		      (setq prev (put-alist (car (car ret))
+					    (cdr (car ret))
+					    prev))
+		    )
+		  (if (nth 2 ret)
+		      (setq rest (put-alist (car (nth 2 ret))
+					    (cdr (nth 2 ret))
+					    rest))
+		    )
+		  (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla))
+		  (setq ins (del-alist (car cell) ins))
+		  )
+	      (throw 'tag nil)
+	      ))
+	(setq r (cdr r))
+	)
+      (setq r (copy-alist ins))
+      (while r
+	(setq cell (car r))
+	(setq aret (assoc (car cell) cla))
+	(if aret
+	    (if (setq ret (field-unify cell aret))
+		(progn
+		  (if (car ret)
+		      (setq prev (put-alist (car (car ret))
+					    (cdr (car ret))
+					    prev))
+		    )
+		  (if (nth 2 ret)
+		      (setq rest (put-alist (car (nth 2 ret))
+					    (cdr (nth 2 ret))
+					    rest))
+		    )
+		  (setq cla (del-alist (car cell) cla))
+		  (setq ins (put-alist (car cell)(cdr (nth 1 ret)) ins))
+		  )
+	      (throw 'tag nil)
+	      ))
+	(setq r (cdr r))
+	)
+      (list prev (append cla ins) rest)
+      )))
+
+(defun get-unified-alist (db al)
+  (let ((r db) ret)
+    (catch 'tag
+      (while r
+	(if (setq ret (nth 1 (assoc-unify (car r) al)))
+	    (throw 'tag ret)
+	  )
+	(setq r (cdr r))
+	))))
+
+(defun delete-atype (atl al)
+  (let* ((r atl) ret oal)
+    (setq oal
+	  (catch 'tag
+	    (while r
+	      (if (setq ret (nth 1 (assoc-unify (car r) al)))
+		  (throw 'tag (car r))
+		)
+	      (setq r (cdr r))
+	      )))
+    (delete oal atl)
+    ))
+
+(defun remove-atype (sym al)
+  (and (boundp sym)
+       (set sym (delete-atype (eval sym) al))
+       ))
+
+(defun replace-atype (atl old-al new-al)
+  (let* ((r atl) ret oal)
+    (if (catch 'tag
+	  (while r
+	    (if (setq ret (nth 1 (assoc-unify (car r) old-al)))
+		(throw 'tag (rplaca r new-al))
+	      )
+	    (setq r (cdr r))
+	    ))
+	atl)))
+
+(defun set-atype (sym al &rest options)
+  (if (null (boundp sym))
+      (set sym al)
+    (let* ((replacement (memq 'replacement options))
+	   (ignore-fields (car (cdr (memq 'ignore options))))
+	   (remove (or (car (cdr (memq 'remove options)))
+		       (let ((ral (copy-alist al)))
+			 (mapcar (function
+				  (lambda (type)
+				    (setq ral (del-alist type ral))
+				    ))
+				 ignore-fields)
+			 ral)))
+	   )
+      (set sym
+	   (or (if replacement
+		   (replace-atype (eval sym) remove al)
+		 )
+	       (cons al
+		     (delete-atype (eval sym) remove)
+		     )
+	       )))))
 
 
 ;;; @ rot13-47
@@ -211,6 +468,9 @@ ROT47 will be performed for Japanese text in any case."
 ;;; @ field
 ;;;
 
+(defsubst regexp-or (&rest args)
+  (concat "\\(" (mapconcat (function identity) args "\\|") "\\)"))
+
 (defun tm:set-fields (sym field-list &optional regexp-sym)
   (or regexp-sym
       (setq regexp-sym
@@ -285,6 +545,45 @@ ROT47 will be performed for Japanese text in any case."
        ))
 
 
+;;; @ Other Utility
+;;;
+
+(defun call-after-loaded (module func &optional hook-name)
+  "If MODULE is provided, then FUNC is called.
+Otherwise func is set to MODULE-load-hook.
+If optional argument HOOK-NAME is specified,
+it is used as hook to set."
+  (if (featurep module)
+      (funcall func)
+    (or hook-name
+	(setq hook-name (intern (concat (symbol-name module) "-load-hook")))
+	)
+    (add-hook hook-name func)
+    ))
+
+(defmacro defun-maybe (name &rest everything-else)
+  (or (and (fboundp name)
+	   (not (get name 'defun-maybe))
+	   )
+      `(or (fboundp (quote ,name))
+	   (progn
+	     (defun ,name ,@everything-else)
+	     (put (quote ,name) 'defun-maybe t)
+	     ))
+      ))
+
+(put 'defun-maybe 'lisp-indent-function 'defun)
+
+(defun-maybe functionp (obj)
+  "Returns t if OBJ is a function, nil otherwise.
+\[XEmacs emulating function]"
+  (or (subrp obj)
+      (byte-code-function-p obj)
+      (and (symbolp obj)(fboundp obj))
+      (and (consp obj)(eq (car obj) 'lambda))
+      ))
+
+
 ;;; @ end
 ;;;