Newsgroups: fj.editor.emacs,fj.mail,fj.sources
Path: galaxy.trc.rwcp.or.jp!jaist-news!morioka
From: morioka@jaist.ac.jp (=?ISO-2022-JP?B?GyRCPGkyLBsoQiAbJEJDTkknGyhC?=
 (MORIOKA Tomohiko))
Subject: =?ISO-2022-JP?B?GyRCNEowVxsoQg==?= MIME header encoder/decoder:
 tiny-mime.el version 2.2 [2/2]
Content-Type: multipart/mixed; boundary="Multipart Tue Nov  9 09:18:18 1993"
Message-ID: <MORIOKA.93Nov9091818@is15e0s03.jaist.ac.jp>
Sender: news@jaist.ac.jp (News System Administrator)
X-Nsubject: $B4J0W(B MIME header encoder/decoder: tiny-mime.el version 2.2 [2/2]
Content-Transfer-Encoding: 7bit
Organization: Japan Advanced Institute of Science and Technology, Ishikawa,
	Japan
Mime-Version: 1.0
Date: Tue, 9 Nov 1993 14:18:18 GMT
Lines: 989
Xref: galaxy.trc.rwcp.or.jp fj.editor.emacs:4110 fj.mail:1434 fj.sources:2905
X-originally-archived-at: http://galaxy.rwcp.or.jp/text/cgi-bin/newsarticle2?ng=fj.mail&nb=1434&hd=a
X-reformat-date: Mon, 18 Oct 2004 15:18:22 +0900
X-reformat-comment: Tabs were expanded into 4 column tabstops by the Galaxy's archiver. See http://katsu.watanabe.name/ancientfj/galaxy-format.html for more info.

--Multipart Tue Nov  9 09:18:18 1993
Content-Type: text/plain; charset=ISO-2022-JP


$B!J$3$N(B message $B$O(B MIME $B$G=hM}$9$k$3$H$K$h$C$F!"<+F0E*$K(B file $B$r<h$j=P(B
$B$;$^$9!#HsBP1~$NJ}$O!"%(%G%#%?!<Ey$G!"@Z$j=P$7$F2<$5$$!K(B

--Multipart Tue Nov  9 09:18:18 1993
Content-Type: application/octet-stream; name="tiny-mime.el"
Content-Transfer-Encoding: 7bit

;; 
;; $Id: tiny-mime.el,v 2.2 1993/11/08 22:52:40 morioka Exp morioka $
;;
;;     A MIME style message header decoder/encoder package.
;;     Now encoder can encode only ISO-2022-JP string by Base64.
;;
;; before RCS version chanses:
;;
;;   version 0.3 1993/09/08; addtion about string decode functions
;;
;;   version 0.2 1993/07/08
;;      by Morita Masahiro (hiro@jaist-east.ac.jp) ;
;;                           removal decoding bug about pud
;;
;;   version 0.1 1993/06/05; removal encoding bug about pud,
;;                           and support for Mule
;;
;;   version 0.0 1993/06/03; addtion RFC-1342 style encoder,
;;                           only Base64 encoding
;;
;; original MIME decoder is
;;   mime.el,v 1.5 1992/07/18 07:52:08 by Enami Tsugutomo
;;

(provide 'tiny-mime)

;;; @ MIME encoded-word definition
;;;

(defconst mime/tspecials "()<>@,;:\\\"/[]?.=")
(defconst mime/charset-regexp "[A-Za-z0-9!#$%&'*+---^_`{}|~]")
(defconst mime/encoded-text-regexp "[!->@-~]+")
(defconst mime/encoded-word-regexp (concat (regexp-quote "=?")
   "\\("
   mime/charset-regexp
   "+\\)"
   (regexp-quote "?")
   "\\(B\\|Q\\)"
   (regexp-quote "?")
   "\\("
   mime/encoded-text-regexp
   "\\)"
   (regexp-quote "?=")))

(defun mime/nth-string (s n)
  (if (stringp s)
      (substring s (match-beginning n) (match-end n))
    (buffer-substring (match-beginning n) (match-end n))))

(defun mime/rest-of-string (str)
  (if (stringp str)
      (substring str (match-end 0))
    (buffer-substring (match-end 0))))

;;; @ variables
;;;

(defvar mime/no-encoding-header-fields '("X-Nsubject"))

(defvar mime/use-X-Nsubject nil)

(defvar mime/use-ISO-2022-JP-special-rule t
  "*decoding mode of MIME header including ISO-2022-JP .
If t, use ISO-2022-JP special rule.")

;;; @ compatible module among Mule, NEmacs and NEpoch 
;;;
(cond ((and (boundp 'MULE) MULE)
       ;; by mol. 1993/10/4
       (defun get-leading-character (charset)
 (cond ((string= charset "ISO-8859-1") lc-ltn1) ; Latin-1
       ((string= charset "ISO-8859-2") lc-ltn2) ; Latin-2
       ((string= charset "ISO-8859-3") lc-ltn3) ; Latin-3
       ((string= charset "ISO-8859-4") lc-ltn4) ; Latin-4
       ((string= charset "ISO-8859-5") lc-crl ) ; Cyrillic
       ((string= charset "ISO-8859-6") lc-arb ) ; Arabic
       ((string= charset "ISO-8859-7") lc-grk ) ; Greek
       ((string= charset "ISO-8859-8") lc-hbw ) ; Hebrew
       ((string= charset "ISO-8859-9") lc-ltn5) ; Latin-5
       (t nil)
       ))
       
       ;; by mol. 1993/10/4
       (defun mime/convert-string-to-emacs (charset str)
 (if (string= charset "ISO-2022-JP")
     (code-convert-string str *junet* *internal*)
   (let ((dest "")
 (LC (get-leading-character charset))
 LC-str
 (len (length str))(i 0) chr chr-str
 )
     (if (not (null LC))
 (progn
   (setq LC-str (char-to-string LC))
   (while (< i len)
     (setq chr (elt str i))
     (setq chr-str (char-to-string chr))
     (if (< chr 128)
 (setq dest (concat dest chr-str))
       (setq dest (concat dest LC-str chr-str))
       )
     (setq i (+ i 1))
     ))
       (setq dest str))
     dest)))
       
       ;; by mol. 1993/11/2
       (defun mime/convert-string-from-emacs (string charset)
 (cond ((equal charset "ISO-2022-JP")
(code-convert-string string *internal* *junet*))
       ((equal charset "US-ASCII") string)
       (t nil)
       ))
       
       ;; by mol. 1993/10/4
       (defun mime/decode-encoded-text (charset encoding str)
 (mime/convert-string-to-emacs
  charset
  (cond ((string= encoding "B") (mime/base64-decode-string str))
((string= encoding "Q") (mime/decode-Q-string str))
(t (message "unknown encoding %s" encoding) str)
)))
       )
      ((and (boundp 'NEMACS) NEMACS)
       ;; by mol. 1993/9/26
       (defun string-width (str)
 "Return number of columns STRING will occupy.\n(Mule compatible function in tiny-mime.el)"
 (length str))
       (defun char-bytes (chr)
 "Return number of bytes CHAR will occupy in a buffer.\n(Mule compatible function in tiny-mime.el)"
 (if (< chr 128) 1 2))
       (defun char-width (chr)
 "Return number of columns CHAR will occupy when displayed.\n(Mule compatible function in tiny-mime.el)"
 (if (< chr 128) 1 2))
       
       ;; by mol. 1993/10/16
       (defun char-leading-char (chr)
 "char-leading-char:\nReturn (extended) leading character of CHAR.\nIf CHAR is not a multi-byte code, 0 is returned.\n(Mule compatible function in tiny-mime.el)"
 (if (>= chr 128)
     lc-jp
   lc-ascii))
       
       ;; by mol. 1993/10/6
       (defconst *junet* 2)
       (defconst *internal* 3)
       (defconst *euc-japan* 3)
       
       ;; by mol. 1993/11/2
       (defconst lc-ascii 0)
       (defconst lc-jp  146)
       
       (defun code-convert-string (str ic oc)
 "Convert code in STRING from SOURCE code to TARGET code,\nOn successful converion, returns the result string,\nelse returns nil.\n(Mule compatible function in tiny-mime.el)"
 (if (not (eq ic oc))
     (convert-string-kanji-code str ic oc)
   str))
       
       ;; by mol. 1993/10/4
       (defun mime/convert-string-to-emacs (charset str)
 (if (string= charset "ISO-2022-JP")
     (convert-string-kanji-code str 2 3)
   str))
       
       ;; by mol. 1993/11/2
       (defun mime/convert-string-from-emacs (string charset)
 (cond ((equal charset "ISO-2022-JP")
(convert-string-kanji-code string 3 2))
       ((equal charset "US-ASCII") string)
       (t nil)
       ))
       
       ;; by mol. 1993/10/4
       (defun mime/decode-encoded-text (charset encoding str)
 (mime/convert-string-to-emacs
  charset
  (cond ((string= encoding "B") (mime/base64-decode-string str))
((string= encoding "Q")
 (message "Q-encoding is not supported")
 (concat "=?" charset "?" encoding "?" str "?=")
 )
(t
 (message "unknown encoding %s" encoding)
 (concat "=?" charset "?" encoding "?" str "?=")
 ))
  ))
       )
      (t
       ;; by mol. 1993/9/26
       (defun string-width (str) (length str))
       (defun char-bytes (chr) 1)
       (defun char-width (chr) 1)
       ))

;;; @ MIME header decoder
;;;

;;; @@ Application Interface
;;;

;; by mol. 1993/10/4
(defun mime/decode-encoded-word (word)
  (if (string-match mime/encoded-word-regexp word)
      (let ((charset (mime/nth-string word 1))
    (encoding (mime/nth-string word 2))
    (text (mime/nth-string word 3)))
(mime/decode-encoded-text charset encoding text))
    word))

(defun mime/decode-region (beg end)
  (interactive "*r")
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      (let (charset encoding text)
(while (re-search-forward mime/encoded-word-regexp nil t)
  (insert (mime/decode-encoded-word 
   (prog1
       (buffer-substring (match-beginning 0) (match-end 0))
     (delete-region (match-beginning 0) (match-end 0))
     )
  ))
  ))
      )))

(defun mime/decode-message-header ()
  (interactive "*")
  (save-excursion
    (save-restriction
      (narrow-to-region (goto-char (point-min))
(progn (re-search-forward "^$" nil t) (point)))
      (mime/prepare-decode-message-header)
      (mime/decode-region (point-min) (point-max))
      )))

(defun mime/decode-string (str)
  (let ((dest "")(ew nil)
beg end)
    (while (setq beg (string-match mime/encoded-word-regexp str))
      (if (> beg 0)
  (if (not (and (eq ew t) (string= (substring str 0 beg) " ")))
      (setq dest (concat dest (substring str 0 beg)
 ))
    )
)
      (setq end (match-end 0))
      (setq dest (concat dest (mime/decode-encoded-word (substring str beg end))
 ))
      (setq str (substring str end))
      (setq ew t)
      )
    (concat dest str)
    ))

;;; @@ Quoted-Printable (Q-encode) decoder
;;;by mol. 1993/10/4
;;;
(defun mime/decode-Q-string (str)
  (let ((dest "")
(len (length str))
(i 0) chr num h l)
    (while (< i len)
      (setq chr (elt str i))
      (if (eq chr ?=)
  (if (< (+ i 2) len)
      (progn
(setq h (hex-char-to-number (elt str (+ i 1))))
(setq l (hex-char-to-number (elt str (+ i 2))))
(setq num (+ (* h 16) l))
(setq dest (concat dest (char-to-string num)))
(setq i (+ i 3))
)
    (progn
      (setq dest (concat dest (char-to-string chr)))
      (setq i (+ i 1))
      ))
(progn
  (setq dest (concat dest (char-to-string chr)))
  (setq i (+ i 1))
  ))
      )
    dest))

;;; @@ Base64 (B-encode) decoder
;;;by Enami Tsugutomo
;;;
(defun mime/base64-decode-string (string)
  (mime/base64-mapconcat (function mime/base64-decode-chars) 4 string))

;;; @ MIME encoder
;;;

(defun mime/encode-string (string encoding)
  (cond ((equal encoding "B") (mime/base64-encode-string string))
(t nil)
))

;; (mime/base64-encode-string (mime/base64-decode-string "GyRAOjRGI0stGyhK"))
(defun mime/base64-encode-string (string)
  (let ((es (mime/base64-mapconcat (function mime/base64-encode-chars) 3 string))
m)
    (setq m (mod (length es) 4))
    (concat es
    (cond ((= m 3) "=")
  ((= m 2) "==")
  ))
    ))

(defun mime/encode-and-split-string (n string charset encoding)
  (let ((i 0) (j 0)
(len (length string))
(js (mime/convert-string-from-emacs string charset))
(cesl (+ (length charset) (length encoding) 6 ))
ewl m rest)
    (setq ewl (mime/encoded-word-length js encoding))
    (if (null ewl) nil
      (progn
(setq m (+ n ewl cesl))
(if (> m 76)
    (progn
      (while (and (< i len)
  (setq js (mime/convert-string-from-emacs
    (substring string 0 i) charset))
  (setq m (+ n (mime/encoded-word-length js encoding) cesl))
  (< m 76))
(setq j i)
(if (>= (elt string i) 128)
    (setq i (+ i 2))
  (setq i (+ i 1))
  )
)
      (setq js (mime/convert-string-from-emacs
(substring string 0 j) charset))
      (setq m (+ n (mime/encoded-word-length js encoding) cesl))
      (setq rest (substring string j))
      )
  (setq rest nil))
(if (string= js "")
    (list 1 "" string)
  (list m (concat "=?" charset "?" encoding "?"
  (mime/encode-string js encoding)
  "?=") rest))
))
    ))

(defun mime/encode-header-word (n string charset encoding)
  (let (dest str ret m)
    (if (null (setq ret (mime/encode-and-split-string n string charset encoding)))
nil
      (progn
(setq dest (nth 1 ret))
(setq m (car ret))
(setq str (nth 2 ret))
(while (and (stringp str)
    (setq ret (mime/encode-and-split-string 1 str charset encoding))
    )
  (setq dest (concat dest "\n " (nth 1 ret)))
  (setq m (car ret))
  (setq str (nth 2 ret))
  )
(list m dest)
))
    ))

(defun mime/encode-header-string (n string)
  (let ((ssl (mime/separate-string-for-encoder string))
i len cell et w ew (dest "") b l)
    (setq len (length ssl))
    (setq cell (nth 0 ssl))
    (setq et (car cell))
    (setq w (cdr cell))
    (if (eq et nil)
(progn
  (if (> (+ n (length w)) 76)
      (progn
(setq dest (concat dest "\n "))
(setq b 1)
)
    (setq b n))
  (setq dest (concat dest w))
  (setq b (+ b (length w)))
  )
      (progn
(setq ew (mime/encode-header-word n (cdr cell) (car et) (cdr et)))
(setq dest (nth 1 ew))
(setq b (car ew))
))
    (setq i 1)
    (while (< i len)
      (setq cell (nth i ssl))
      (setq et (car cell))
      (setq w (cdr cell))
      (cond ((string-match "^\\s *$" w)
     (setq b (+ b (length (cdr cell))))
     (setq dest (concat dest (cdr cell)))
     )
    ((eq et nil)
     (if (> (+ b (length w)) 76)
 (progn
   (if (eq (elt dest (- (length dest) 1)) 32)
       (setq dest (substring dest 0 (- (length dest) 1)))
     )
   (setq dest (concat dest "\n " w))
   (setq b (+ (length w) 1))
   )
       (progn
 (setq l (length dest))
 (if (and (eq (elt dest (- l 2)) ?\?)
  (eq (elt dest (- l 1)) ?=))
     (progn
       (setq dest (concat dest " "))
       (setq b (+ b 1))
       ))
 (setq dest (concat dest w))
 (setq b (+ b (length w)))
 ))
     )
    (t
     (if (not (eq (elt dest (- (length dest) 1)) 32))
 (progn
   (setq dest (concat dest " "))
   (setq b (+ b 1))
   ))
     (setq ew (mime/encode-header-word b (cdr cell) (car et) (cdr et)))
     (setq b (car ew)) 
     (if (string-match "^\n" (nth 1 ew))
 (setq dest (concat (substring dest 0 (- (length dest) 1))
    (nth 1 ew)))
       (setq dest (concat dest (nth 1 ew)))
       )
     ))
      (setq i (+ i 1))
      )
    (list b dest)))

(defun mime/encode-address-list (n str)
  (let ((ret (mime/parse-addresses str))
len (i 0) cell j cl (dest "") s)
    (setq len (length ret))
    (while (< i len)
      (setq cell (nth i ret))
      (if (string= (nth 1 cell) "<")
  (progn
    (setq en-ret (mime/encode-header-string n (nth 0 cell)))
    (setq dest (concat dest (nth 1 en-ret)))
    (setq n (car en-ret))
    (if (< i (- len 1))
(setq en-ret 
      (mime/encode-header-string
       n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell) ", ")))
      (setq en-ret (mime/encode-header-string
    n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell))))
      )
    (if (and (eq (elt (nth 1 en-ret) 0) ?\n)
     (eq (elt dest (- (length dest) 1)) 32))
(setq dest (substring dest 0 (- (length dest) 1)))
      )
    (setq dest (concat dest (nth 1 en-ret)))
    (setq n (car en-ret))
    )
(progn
  (if (= (length cell) 4)
      (progn
(setq en-ret (mime/encode-header-string n (nth 0 cell)))
(setq dest (concat dest (nth 1 en-ret)))
(setq n (car en-ret))

(setq en-ret (mime/encode-header-string (+ n 2) (nth 2 cell)))
(if (eq (elt (nth 1 en-ret) 0) ?\n)
    (progn
      (setq dest (concat dest "\n ("))
      (setq en-ret (mime/encode-header-string 2 (nth 2 cell)))
      )
  (progn
    (setq dest (concat dest " ("))
    ))
(setq dest (concat dest (nth 1 en-ret)))
(setq n (car en-ret))
(if (< i (- len 1))
    (setq en-ret
  (mime/encode-header-string n (concat (nth 3 cell) ", ")))
  (setq en-ret (mime/encode-header-string n (nth 3 cell)))
  )
(setq dest (concat dest (nth 1 en-ret)))
(setq n (car en-ret))
)
    (progn
      (if (< i (- len 1))
  (setq en-ret
(mime/encode-header-string n (concat (nth 0 cell) ", ")))
(setq en-ret (mime/encode-header-string n (nth 0 cell)))
)
      (setq dest (concat dest (nth 1 en-ret)))
      (setq n (car en-ret))
      ))
  ))
      (setq i (+ i 1))
      )
    dest))

(defun mime/encode-field (str)
  (setq str (mime/unfolding-string str))
  (let ((ret (mime/divide-field str))
field-name field-body)
    (setq field-name (car ret))
    (setq field-body (nth 1 ret))
    (concat field-name " "
    (if (or (string-match "^Reply-To:$" field-name)
    (string-match "^From:$" field-name)
    (string-match "^Sender:$" field-name)
    (string-match "^Resent-Reply-To:$" field-name)
    (string-match "^Resent-From:$" field-name)
    (string-match "^Resent-Sender:$" field-name)
    (string-match "^To:$" field-name)
    (string-match "^Resent-To:$" field-name)
    (string-match "^cc:$" field-name)
    (string-match "^Resent-cc:$" field-name)
    (string-match "^bcc:$" field-name)
    (string-match "^Resent-bcc:$" field-name)
    )
(mime/encode-address-list (+ (length field-name) 1)
  field-body)
      (catch 'label
(let ((i 0)
      (n (length mime/no-encoding-header-fields))
      fn)
  (while (< i n)
    (setq fn (nth i mime/no-encoding-header-fields))
    (if (string-match (concat "^" fn ":$") field-name)
(progn
  (throw 'label field-body)
  ))
    (setq i (+ i 1))
    )
  (nth 1 (mime/encode-header-string (+ (length field-name) 1)
    field-body))
  ))
      ))
    ))

(defun mime/encode-message-header ()
  (interactive "*")
  (save-excursion
    (save-restriction
      (narrow-to-region (goto-char (point-min))
(progn
  (re-search-forward mail-header-separator nil t)
  (match-beginning 0)
  ))
      (goto-char (point-min))
      (let (beg end)
(while (re-search-forward "^.+:.*\\(\n\\s +.*\\)*" nil t)
  (setq beg (match-beginning 0))
  (setq end  (match-end 0))
  (setq field (buffer-substring beg end))
  (insert (mime/encode-field
   (prog1
       (buffer-substring beg end)
     (delete-region beg end)
     )))
  ))
      (if mime/use-X-Nsubject
  (progn
    (goto-char (point-min))
    (if (re-search-forward "^Subject:.*\\(\n\\s +.*\\)*" nil t)
(let ((str (buffer-substring (match-beginning 0)(match-end 0))))
  (if (string-match mime/encoded-word-regexp str)
      (insert (concat
       "\nX-Nsubject: "
       (nth 1 (mime/divide-field
       (mime/decode-string
(mime/unfolding-string str))
       ))))
    ))
      )))
      )))

;;; @ low level functions for Base64 (B-encode)
;;;by Enami Tsugutomo
;;;

;; (char-to-string (mime/base64-bit-to-char 26))
(defun mime/base64-bit-to-char (n)
  (cond ((eq n nil) ?=)
((< n 26) (+ ?A n))
((< n 52) (+ ?a (- n 26)))
((< n 62) (+ ?0 (- n 52)))
((= n 62) ?+)
((= n 63) ?/)
(t (error "not a base64 integer %d" n))))

(defun mime/base64-char-to-bit (c)
  (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A))
((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26))
((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52))
((= c ?+) 62)
((= c ?/) 63)
((= c ?=) nil)
(t (error "not a base64 character %c" c))))

;;; (and nil
;;; (let ((n 0))
;;;   (while (< n 64) 
;;;     (if (/= n 
;;;     (mime/base64-char-to-bit (mime/base64-bit-to-char n)))
;;; (error "%d" n))
;;;     (setq n (1+ n))))
;;; )

(defun mime/mask (i n) (logand i (1- (ash 1 n))))
(defun mime/base64-encode-1 (a &optional b &optional c)
  (cons (ash a -2)
(cons (logior (ash (mime/mask a 2) (- 6 2))
      (if b (ash b -4) 0))
      (if b
  (cons (logior (ash (mime/mask b 4) (- 6 4))
(if c (ash c -6) 0))
(if c
    (cons (mime/mask c (- 6 0))
  nil)))))))

(defun mime/base64-decode-1 (a b &optional c &optional d)
  (cons (logior (ash a 2) (ash b (- 2 6)))
(if c (cons (logior (ash (mime/mask b 4) 4)
    (mime/mask (ash c (- 4 6)) 4))
    (if d (cons (logior (ash (mime/mask c 2) 6) d)
nil))))))
;;; (and nil
;;; (let ((l '(?\e ?$ ?@)) m n)
;;;   (setq m (mapcar (function char-to-string)
;;;   (mapcar (function mime/base64-bit-to-char)
;;;   (apply (function mime/base64-encode-1) l))))
;;;   (setq n (mapcar (function identity)
;;;   (apply (function mime/base64-decode-1)
;;;  (mapcar (function mime/base64-char-to-bit)
;;;  (mapcar (function string-to-char) m)))))
;;;   (message "%s %s %s" l m n))
;;; )

;; (mime/base64-decode-chars ?G ?y ?R ?A)
(defun mime/base64-decode-chars (a b c d)
  (apply (function mime/base64-decode-1)
 (mapcar (function mime/base64-char-to-bit)
 (list a b c d))))

;; (mapcar (function char-to-string) (mime/base64-encode-chars 27 36 64))
(defun mime/base64-encode-chars (a b c)
  (mapcar (function mime/base64-bit-to-char) (mime/base64-encode-1 a b c)))

(defun mime/base64-fecth-from (func from pos len)
  (let (ret)
    (while (< 0 len)
      (setq len (1- len)
    ret (cons (funcall func from (+ pos len)) ret)))
    ret))

(defun mime/base64-fecth-from-buffer (from pos len)
  (mime/base64-fecth-from (function (lambda (f p) (char-after p)))
  from pos len))

;;; (and nil
;;; (mapcar (function (lambda (x) (if (integerp x) (char-to-string x)
;;; x)))
;;; (mime/base64-fecth-from-string "hoge" 1 4))
;;; )

(defun mime/base64-fecth-from-string (from pos len)
  (mime/base64-fecth-from (function (lambda (f p)
      (if (< p (length f)) (aref f p))))
  from pos len))

(defun mime/base64-fecth (source pos len)
  (cond ((stringp source) (mime/base64-fecth-from-string source pos len))
(t (mime/base64-fecth-from-buffer source pos len))))

(defun mime/base64-mapconcat (func unit string)
  (let ((i 0) ret)
    (while (< i (length string))
      (setq ret 
    (apply (function concat)
   ret
   (mapcar (function char-to-string)
   (apply func (mime/base64-fecth string i unit)))))
      (setq i (+ i unit)))
    ret))

;;; @ RFC 822 field parser
;;;

(defconst mime/field-name-regexp "^[!-9;-~]+:")
(defconst mime/word-regexp "[!#-'*+0-9=?A-Z^-~---]+")
(defconst mime/local-part-regexp (concat mime/word-regexp
 "\\(\\."
 mime/word-regexp
 "\\)*"))
(defconst mime/domain-regexp (concat "@" mime/local-part-regexp))
(defconst mime/addr-spec-regexp (concat mime/local-part-regexp
"\\("
    mime/domain-regexp
    "\\)?"
   ))

(defun mime/divide-field (str)
  (let (field-name field-body)
    (if (string-match mime/field-name-regexp str)
(progn
  (setq field-name (substring str 0 (match-end 0)))
  (setq field-body (substring str (match-end 0)))
  (if (string-match "^\\s +" field-body)
      (setq field-body (substring field-body (match-end 0)))
    )
  (list field-name field-body)
  )
      nil)
      ))

(defun mime/parse-addr-spec (str)
  (if (string-match "^\\s +" str)
      (setq str (substring str (match-end 0)))
    )
  (if (eq (string-match mime/addr-spec-regexp str) 0)
      (list (list (substring str 0 (match-end 0)))
    (substring str (match-end 0))
    )
    ))

(defun mime/parse-phrase-route-addr (str)
  (let ((p (and (string-match "^[^,]*<" str)
(match-end 0)))
phrase ad)
    (if (and p
     (setq ad (mime/parse-addr-spec (substring str p)))
     (eq (elt (cadr ad) 0) ?>))
(list (list (substring str 0 (- p 1))
    "<"
    (caar ad)
    ">")
      (substring (cadr ad) 1)
      )
      nil)
    ))

(defun mime/parse-comment (str)
  (if (string-match "^\\s +" str)
      (setq str (substring str (match-end 0)))
    )
  (if (string-match "^([^,]*)" str)
      (list (list "(" (substring str 1 (- (match-end 0) 1)) ")")
    (substring str (match-end 0))
    )
    ))

(defun mime/parse-address (str)
  (let ((ret (or
      (mime/parse-phrase-route-addr str)
      (mime/parse-addr-spec str)
      ))
n rest type cret)
    (if ret
(progn
  (setq rest (cdr ret))
  (setq cret (mime/parse-comment (car rest)))
  (if cret
      (list (append (car ret) (car cret))
    (cdr cret))
    (list (car ret) rest)
    )
  ))
    ))

(defun mime/parse-addresses (str)
  (let (dest
(ret (mime/parse-address str))
rs)
    (if ret
(progn
  (setq dest (list (car ret)))
  (setq rs (car (nth 1 ret)))
  (while (and (string-match "^\\s *,\\s *" rs)
      (setq ret (mime/parse-address
 (substring rs (match-end 0))))
      )
    (setq dest (append dest (list (car ret))))
    (setq rs (car (nth 1 ret)))
    )
  (if (string-match "^\\s *$" rs)
      dest)
  ))
    ))

(defun mime/unfolding-string (str)
  (let ((dest ""))
    (while (string-match "\n\\s +" str)
      (setq dest (concat dest (substring str 0 (match-beginning 0)) " "))
      (setq str (substring str (match-end 0)))
      )
    (concat dest str)
    ))

;;; @ utility functions
;;;

;; by mol. 1993/10/4
(defun hex-char-to-number (chr)
  (cond ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0))
((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10))
((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10))
))

;; by mol. 1993/9/26
(defun rightful-boundary-short-string (str width)
  (substring str 0 
     (let ((i 0) (w 0) chr (len (length str)))
       (catch 'label
 (while (< i len)
   (setq chr (elt str i))
   (setq w (+ w (char-width chr)))
   (if (> w width)
       (throw 'label i))
   (setq i (+ i (char-bytes chr)))
   )
 i))
     ))

;;; @ utility for encoder
;;;

;;; @@ encoded-word length
;;;

(defun mime/encoded-word-length (string encoding)
  (cond ((equal encoding "B") (mime/base64-length string))
(t nil)
))

(defun mime/base64-length (string)
  (let ((l (length string))
)
    (* (+ (/ l 3)
  (if (= (mod l 3) 0) 0 1)
  ) 4)
    ))

;;; @@ separate by character set
;;;

;; by mol. 1993/11/2
(defconst LC-space 2)

;; by mol. 1993/10/16
(defun mime/char-type (chr)
  (if (or (= chr 32)(= chr ?\t))
      LC-space
    (char-leading-char chr)
    ))

(defun mime/separate-string-by-chartype (string)
  (let ((len (length string))
(dest nil) (ds "") s
pcs i j cs chr)
    (if (= len 0) nil
      (progn (setq chr (elt string 0))
     (setq pcs (mime/char-type chr))
     (setq i (char-bytes chr))
     (setq ds (substring string 0 i))
     (while (< i len)
       (setq chr (elt string i))
       (setq cs (mime/char-type chr))
       (setq j (+ i (char-bytes chr)))
       (setq s (substring string i j))
       (setq i j)
       (if (= cs pcs)
   (setq ds (concat ds s))
 (progn (setq dest (append dest (list (cons pcs ds))))
(setq pcs cs)
(setq ds s)
))
       )
     (if (not (string= ds ""))
 (setq dest (append dest (list (cons pcs ds)))))
     dest)
      )))

(defun mime/charset-and-encoding-name (LC)
  (cond ((eq LC lc-ascii) nil)
((eq LC lc-jp) (cons "ISO-2022-JP" "B"))
(t nil))
  )

(defun mime/separate-string-for-encoder (string)
  (let ((rl (mime/separate-string-by-chartype string))
(i 0) len cell0 cell1 cell2 (dest nil))
    (setq len (length rl))
    (setq cell0 (nth 0 rl))
    (setq cell1 (nth 1 rl))
    (setq cell2 (nth 2 rl))
    (while (< i len)
      (cond ((and (eq (car cell0) lc-jp)
  (eq (car cell1) LC-space)
  (eq (car cell2) lc-jp))
     (setq dest
   (append dest (list
 (cons
  (mime/charset-and-encoding-name lc-jp)
  (concat (cdr cell0) (cdr cell1) (cdr cell2)
  ))
 )))
     (setq i (+ i 3))
     (setq cell0 (nth i rl))
     (setq cell1 (nth (+ i 1) rl))
     (setq cell2 (nth (+ i 2) rl))
     )
    (t
     (setq dest
   (append dest (list
 (cons (mime/charset-and-encoding-name (car cell0))
       (cdr cell0)))))
     (setq i (+ i 1))
     (setq cell0 cell1)
     (setq cell1 cell2)
     (setq cell2 (nth (+ i 2) rl))
     ))
      )
    dest))

;;;
;;; basic functions for MIME header decoder
;;;

;;; @ utility for decoder
;;;

(defun mime/unfolding ()
  (goto-char (point-min))
  (let (field beg end)
    (while (re-search-forward "^.+:.*\\(\n\\(\\s \\|\t\\)+.*\\)*" nil t)
      (setq beg (match-beginning 0))
      (setq end  (match-end 0))
      (setq field (buffer-substring beg end))
      (if (string-match mime/encoded-word-regexp field)
  (progn
    (save-excursion
      (save-restriction
(narrow-to-region (goto-char beg) end)
(while (re-search-forward "\n\\(\\s \\|\t\\)+" nil t)
  (replace-match " ")
  )
))
    ))
      ))
  )

(defun mime/prepare-decode-message-header ()
  (mime/unfolding)
  (goto-char (point-min))
  (while (re-search-forward
  (concat (regexp-quote "?=")
  "\\s +"
  (regexp-quote "=?"))
  nil t)
    (replace-match "?==?")
    )
  )

;;; @
;;; Local Variables:
;;; mode: emacs-lisp
;;; mode: outline-minor
;;; outline-regexp: ";;; @+\\|(......"
;;; End:
--Multipart Tue Nov  9 09:18:18 1993
Content-Type: text/plain; charset=ISO-2022-JP

$B(.!X7r9/$HH~MF$N$?$a$K?)8e$K0lGU$N9HCc!Y(,(,(,(,(,(,(,(,(,(,(,(,(,(,(/(B
$B(-(B                    $B<i2,(B $BCNI'(B (MORIOKA Tomohiko)                  $B(-(B
$B(-!!(B                                    Email: <morioka@jaist.ac.jp>$B(-(B
$B(1(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(0(B
--Multipart Tue Nov  9 09:18:18 1993--
