;;;
;;; tm-def.el --- definition module for tm
;;;
;;; Copyright (C) 1995 Free Software Foundation, Inc.
;;; Copyright (C) 1995,1996 MORIOKA Tomohiko
;;;
;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
;;; Version:
;;;	$Id: tm-def.el,v 7.45 1996/05/31 17:52:07 morioka Exp $
;;; Keywords: mail, news, MIME, multimedia, definition
;;;
;;; This file is part of tm (Tools for MIME).
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 2, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with This program.  If not, write to the Free Software
;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;
;;; Code:

(require 'emu)
(require 'tl-822)


;;; @ variables
;;;

(defvar mime/tmp-dir (or (getenv "TM_TMP_DIR") "/tmp/"))

(defvar mime/use-multi-frame
  (and (>= emacs-major-version 19) window-system))

(defvar mime/find-file-function
  (if mime/use-multi-frame
      (function find-file-other-frame)
    (function find-file)
    ))


;;; @ constants
;;;

(defconst mime/output-buffer-name "*MIME-out*")
(defconst mime/temp-buffer-name " *MIME-temp*")


;;; @ leading-character and charset
;;;

(defvar mime/lc-charset-alist
  (foldr (function
	  (lambda (a cell)
	    (or (catch 'tag
		  (cons (cons (foldr (function
				      (lambda (a sym)
					(if (boundp sym)
					    (cons (symbol-value sym) a)
					  (throw 'tag nil)
					  )))
				     nil
				     (car cell))
			      (cdr cell))
			a))
		a)
	    ))
	 nil
	 '(((charset-ascii)   . "US-ASCII")
	   ((charset-ascii
	     charset-latin-1) . "ISO-8859-1")
	   ((charset-ascii
	     charset-latin-2) . "ISO-8859-2")
	   ((charset-ascii
	     charset-latin-3) . "ISO-8859-3")
	   ((charset-ascii
	     charset-latin-4) . "ISO-8859-4")
;;;        ((charset-ascii
;;;	     charset-cyrillic) . "ISO-8859-5")
	   ((charset-ascii
	     charset-cyrillic) . "KOI8-R")
	   ((charset-ascii
	     charset-arabic)   . "ISO-8859-6")
	   ((charset-ascii
	     charset-greek)    . "ISO-8859-7")
	   ((charset-ascii
	     charset-hebrew)   . "ISO-8859-8")
	   ((charset-ascii
	     charset-latin-5)  . "ISO-8859-9")
	   ((charset-ascii
	     charset-jisx0208) . "ISO-2022-JP")
	   ((charset-ascii
	     charset-ksc5601)  . "EUC-KR")
	   ((charset-ascii
	     charset-big5-1
	     charset-big5-2)   . "BIG5")
	   ((charset-ascii
	     charset-gb2312
	     charset-jisx0208
	     charset-ksc5601
	     charset-jisx0212
	     charset-latin-1
	     charset-greek)    . "ISO-2022-JP-2")
	   ((charset-ascii
	     charset-gb2312
	     charset-jisx0208
	     charset-ksc5601
	     charset-jisx0212
	     charset-cns11643-1
	     charset-cns11643-2
	     charset-latin-1
	     charset-greek)    . "ISO-2022-INT-1")
	   )))

(defvar mime/unknown-charset "ISO-2022-INT-1")


;;; @ charset and encoding
;;;

(defun mime/find-charset (lcl)
  (if lcl
      (or (cdr (some-element
		(function
		 (lambda (elt)
		   (subsetp lcl (car elt))
		   ))
		mime/lc-charset-alist)
	       )
	  mime/unknown-charset)
    ))

(defun mime/find-charset-region (beg end)
  (mime/find-charset (cons charset-ascii (find-charset-region beg end)))
  )

(defvar mime/charset-type-list
  '(("US-ASCII"       7 nil)
    ("ISO-8859-1"     8 "quoted-printable")
    ("ISO-8859-2"     8 "quoted-printable")
    ("ISO-8859-3"     8 "quoted-printable")
    ("ISO-8859-4"     8 "quoted-printable")
    ("ISO-8859-5"     8 "quoted-printable")
    ("KOI8-R"         8 "quoted-printable")
    ("ISO-8859-7"     8 "quoted-printable")
    ("ISO-8859-8"     8 "quoted-printable")
    ("ISO-8859-9"     8 "quoted-printable")
    ("ISO-2022-JP"    7 "base64")
    ("ISO-2022-KR"    7 "base64")
    ("EUC-KR"         8 "base64")
    ("BIG5"           8 "base64")
    ("ISO-2022-JP-2"  7 "base64")
    ("ISO-2022-INT-1" 7 "base64")
    ))

(defun mime/encoding-name (transfer-level &optional not-omit)
  (cond ((> transfer-level 8) "binary")
	((= transfer-level 8) "8bit")
	(not-omit "7bit")
	))

(defun mime/make-charset-default-encoding-alist (transfer-level)
  (mapcar (function
	   (lambda (charset-type)
	     (let ((charset  (car charset-type))
		   (type     (nth 1 charset-type))
		   (encoding (nth 2 charset-type))
		   )
	       (if (<= type transfer-level)
		   (cons charset (mime/encoding-name type))
		 (cons charset encoding)
		 ))))
	  mime/charset-type-list))


;;; @ coding-system
;;;

(defvar mime/charset-coding-system-alist
  (let* (csl
	 (f (if (and running-xemacs-20 (featurep 'mule))
		(progn
		  (setq csl (coding-system-list))
		  (function
		   (lambda (a cell)
		     (if (memq (cdr cell) csl)
			 (cons cell a)
		       a))))
	      (function
	       (lambda (a cell)
		 (let ((sym (symbol-concat "*" (cdr cell) "*")))
		   (if (boundp sym)
		       (cons (cons (car cell) (symbol-value sym)) a)
		     a))))
	      )))
    (foldr f nil
	   '(("ISO-2022-JP"     . junet)
	     ("ISO-2022-KR"     . iso-2022-kr)
	     ("EUC-KR"          . euc-kr)
	     ("ISO-8859-1"      . ctext)
	     ("ISO-8859-2"      . iso-8859-2)
	     ("ISO-8859-3"      . iso-8859-3)
	     ("ISO-8859-4"      . iso-8859-4)
	     ("ISO-8859-5"      . iso-8859-5)
	     ("KOI8-R"          . koi8)
	     ("ISO-8859-7"      . iso-8859-7)
	     ("ISO-8859-8"      . iso-8859-8)
	     ("ISO-8859-9"      . iso-8859-9)
	     ("ISO-2022-JP-2"   . iso-2022-ss2-7)
	     ("X-ISO-2022-JP-2" . iso-2022-ss2-7)
	     ("ISO-2022-INT-1"  . iso-2022-int-1)
	     ("SHIFT_JIS"       . sjis)
	     ("X-SHIFTJIS"      . sjis)
	     ("BIG5"            . big5)
	     ))))

(defvar mime/default-coding-system *ctext*)

(defun mime-charset-encode-string (str charset)
  (let ((cs (assoc charset mime/charset-coding-system-alist)))
    (if cs
	(character-encode-string str (cdr cs))
      )))

(defun mime-charset-decode-string (str charset)
  (let ((cs (assoc charset mime/charset-coding-system-alist)))
    (if cs
	(character-decode-string str (cdr cs))
      )))

(defun mime-charset-encode-region (beg end charset &optional encoding)
  (let ((ct
	 (if (stringp charset)
	     (cdr (assoc (upcase charset) mime/charset-coding-system-alist))
	   mime/default-coding-system)))
    (if ct
	(character-encode-region beg end ct)
      )))

(defun mime-charset-decode-region (beg end charset &optional encoding)
  (let ((ct
	 (if (stringp charset)
	     (cdr (assoc (upcase charset) mime/charset-coding-system-alist))
	   mime/default-coding-system)))
    (if ct
	(character-decode-region beg end ct)
      )))


;;; @ button
;;;

(defun tm:set-face-region (b e face)
  (let ((overlay (tl:make-overlay b e)))
    (tl:overlay-put overlay 'face face)
    ))

(setq tm:button-face 'bold)
(setq tm:mouse-face 'highlight)

(defun tm:add-button (from to func &optional data)
  "Create a button between FROM and TO with callback FUNC and data DATA."
  (and tm:button-face
       (tl:overlay-put (tl:make-overlay from to) 'face tm:button-face))
  (tl:add-text-properties from to
			  (append (and tm:mouse-face
				       (list 'mouse-face tm:mouse-face))
				  (list 'tm-callback func)
				  (and data (list 'tm-data data))
				  ))
  )

(defvar tm:mother-button-dispatcher nil)

(defun tm:button-dispatcher (event)
  "Select the button under point."
  (interactive "e")
  (mouse-set-point event)
  (let ((func (get-text-property (point) 'tm-callback))
	(data (get-text-property (point) 'tm-data))
	)
    (if func
	(apply func data)
      (if (fboundp tm:mother-button-dispatcher)
	  (funcall tm:mother-button-dispatcher event)
	)
      )))


;;; @ for URL
;;;

(defvar tm:URL-regexp
  "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]")

(defvar browse-url-browser-function nil)

(defun tm:browse-url (&optional url)
  (if (fboundp browse-url-browser-function)
      (if url 
        (funcall browse-url-browser-function url)
      (call-interactively browse-url-browser-function))
    (if (fboundp tm:mother-button-dispatcher)
	(call-interactively tm:mother-button-dispatcher)
      )
    ))


;;; @ 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/content-parameter-value-regexp
  (concat "\\("
	  rfc822/quoted-string-regexp
	  "\\|[^; \t\n]*\\)"))

(defconst mime/disposition-type-regexp mime/token-regexp)


;;; @@ Base64
;;;

(defconst base64-token-regexp "[A-Za-z0-9+/=]")

(defconst mime/B-encoded-text-regexp
  (concat "\\("
	  base64-token-regexp
	  base64-token-regexp
	  base64-token-regexp
	  base64-token-regexp
	  "\\)+"))
(defconst mime/B-encoding-and-encoded-text-regexp
  (concat "\\(B\\)\\?" mime/B-encoded-text-regexp))


;;; @@ Quoted-Printable
;;;

(defconst quoted-printable-hex-chars "0123456789ABCDEF")
(defconst quoted-printable-octet-regexp
  (concat "=[" quoted-printable-hex-chars
	  "][" quoted-printable-hex-chars "]"))

(defconst mime/Q-encoded-text-regexp
  (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
(defconst mime/Q-encoding-and-encoded-text-regexp
  (concat "\\(Q\\)\\?" mime/Q-encoded-text-regexp))


;;; @ rot13-47
;;;
;; caesar-region written by phr@prep.ai.mit.edu  Nov 86
;; modified by tower@prep Nov 86
;; gnus-caesar-region
;; Modified by umerin@flab.flab.Fujitsu.JUNET for ROT47.
(defun tm:caesar-region (&optional n)
  "Caesar rotation of region by N, default 13, for decrypting netnews.
ROT47 will be performed for Japanese text in any case."
  (interactive (if current-prefix-arg	; Was there a prefix arg?
		   (list (prefix-numeric-value current-prefix-arg))
		 (list nil)))
  (cond ((not (numberp n)) (setq n 13))
	(t (setq n (mod n 26))))	;canonicalize N
  (if (not (zerop n))		; no action needed for a rot of 0
      (progn
	(if (or (not (boundp 'caesar-translate-table))
		(/= (aref caesar-translate-table ?a) (+ ?a n)))
	    (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper)
	      (message "Building caesar-translate-table...")
	      (setq caesar-translate-table (make-vector 256 0))
	      (while (< i 256)
		(aset caesar-translate-table i i)
		(setq i (1+ i)))
	      (setq lower (concat lower lower) upper (upcase lower) i 0)
	      (while (< i 26)
		(aset caesar-translate-table (+ ?a i) (aref lower (+ i n)))
		(aset caesar-translate-table (+ ?A i) (aref upper (+ i n)))
		(setq i (1+ i)))
	      ;; ROT47 for Japanese text.
	      ;; Thanks to ichikawa@flab.fujitsu.junet.
	      (setq i 161)
	      (let ((t1 (logior ?O 128))
		    (t2 (logior ?! 128))
		    (t3 (logior ?~ 128)))
		(while (< i 256)
		  (aset caesar-translate-table i
			(let ((v (aref caesar-translate-table i)))
			  (if (<= v t1) (if (< v t2) v (+ v 47))
			    (if (<= v t3) (- v 47) v))))
		  (setq i (1+ i))))
	      (message "Building caesar-translate-table...done")))
	(let ((from (region-beginning))
	      (to (region-end))
	      (i 0) str len)
	  (setq str (buffer-substring from to))
	  (setq len (length str))
	  (while (< i len)
	    (aset str i (aref caesar-translate-table (aref str i)))
	    (setq i (1+ i)))
	  (goto-char from)
	  (delete-region from to)
	  (insert str)))))


;;; @ field
;;;

(defun tm:set-fields (sym field-list &optional regexp-sym)
  (or regexp-sym
      (setq regexp-sym
	    (let ((name (symbol-name sym)))
	      (intern
	       (concat (if (string-match "\\(.*\\)-list" name)
			   (substring name 0 (match-end 1))
			 name)
		       "-regexp")
	       )))
      )
  (set sym field-list)
  (set regexp-sym
       (concat "^" (apply (function regexp-or) field-list) ":"))
  )

(defun tm:add-fields (sym field-list &optional regexp-sym)
  (or regexp-sym
      (setq regexp-sym
	    (let ((name (symbol-name sym)))
	      (intern
	       (concat (if (string-match "\\(.*\\)-list" name)
			   (substring name 0 (match-end 1))
			 name)
		       "-regexp")
	       )))
      )
  (let ((fields (eval sym)))
    (mapcar (function
	     (lambda (field)
	       (or (member field fields)
		   (setq fields (cons field fields))
		   )
	       ))
	    (reverse field-list)
	    )
    (set regexp-sym
	 (concat "^" (apply (function regexp-or) fields) ":"))
    (set sym fields)
    ))

(defun tm:delete-fields (sym field-list &optional regexp-sym)
  (or regexp-sym
      (setq regexp-sym
	    (let ((name (symbol-name sym)))
	      (intern
	       (concat (if (string-match "\\(.*\\)-list" name)
			   (substring name 0 (match-end 1))
			 name)
		       "-regexp")
	       )))
      )
  (let ((fields (eval sym)))
    (mapcar (function
	     (lambda (field)
	       (setq fields (delete field fields))
	       ))
	    field-list)
    (set regexp-sym
	 (concat "^" (apply (function regexp-or) fields) ":"))
    (set sym fields)
    ))


;;; @ end
;;;

(provide 'tm-def)

;;; tm-def.el ends here