;;; mime.el,v 1.5 1992/07/18 07:52:08 by Enami Tsugutomo
;;;
-(provide 'tiny-mime)
-
;;; @ require modules
;;;
+
+(require 'emu)
+(require 'mel)
(require 'tl-header)
(require 'tl-str)
-(if (not (fboundp 'member))
- (require 'tl-18)
- )
+(require 'tm-def)
;;; @ version
;;;
+
(defconst mime/RCS-ID
- "$Id: tiny-mime.el,v 5.3 1994/10/25 11:51:05 morioka Exp $")
+ "$Id: tiny-mime.el,v 6.7 1995/09/20 12:17:28 morioka Exp $")
(defconst mime/tiny-mime-version (get-version-string mime/RCS-ID))
;;; @ MIME encoded-word definition
;;;
-(defconst mime/charset-regexp "[A-Za-z0-9!#$%&'*+---^_`{}|~]")
(defconst mime/encoded-text-regexp "[!->@-~]+")
-
-(defconst mime/Base64-token-regexp "[A-Za-z0-9+/=]")
-(defconst mime/Base64-encoded-text-regexp
- (concat "\\("
- mime/Base64-token-regexp
- mime/Base64-token-regexp
- mime/Base64-token-regexp
- mime/Base64-token-regexp
- "\\)+"))
-(defconst mime/Base64-encoding-and-encoded-text-regexp
- (concat "\\(B\\)\\?" mime/Base64-encoded-text-regexp))
-
-(defconst mime/Quoted-Printable-hex-char "[0123456789ABCDEF]")
-(defconst mime/Quoted-Printable-encoded-text-regexp
- (concat "\\([^=?_]\\|="
- mime/Quoted-Printable-hex-char
- mime/Quoted-Printable-hex-char
- "\\)+"))
-(defconst mime/Quoted-Printable-encoding-and-encoded-text-regexp
- (concat "\\(Q\\)\\?" mime/Quoted-Printable-encoded-text-regexp))
-
(defconst mime/encoded-word-regexp (concat (regexp-quote "=?")
"\\("
mime/charset-regexp
- "+\\)"
+ "\\)"
(regexp-quote "?")
"\\(B\\|Q\\)"
(regexp-quote "?")
(defun mime/rest-of-string (str)
(if (stringp str)
(substring str (match-end 0))
- (buffer-substring (match-end 0))))
+ (buffer-substring (match-end 0)(point-max))
+ ))
+
;;; @ variables
;;;
-(defvar mime/no-encoding-header-fields '("X-Nsubject"))
+(defvar mime/no-encoding-header-fields '("X-Nsubject" "Newsgroups"))
(defvar mime/use-X-Nsubject nil)
-;;; @ compatible module among Mule, NEmacs and NEpoch
-;;;
-(cond ((boundp 'MULE) (require 'tm-mule))
- ((boundp 'NEMACS)(require 'tm-nemacs))
- (t (require 'tm-orig))
- )
-
-
;;; @ Application Interface
;;;
;;; @@ MIME header decoders
;;;
-;; by mol. 1993/10/4
+(defun mime/decode-encoded-text (charset encoding str)
+ (let ((dest
+ (cond ((string= "B" encoding)
+ (base64-decode-string str))
+ ((string= "Q" encoding)
+ (q-encoding-decode-string str))
+ (t (message "unknown encoding %s" encoding)
+ nil))))
+ (if dest
+ (mime/convert-string-to-emacs charset dest)
+ )))
+
(defun mime/decode-encoded-word (word)
- (if (string-match mime/encoded-word-regexp word)
- (let ((charset (upcase (mime/encoded-word-charset word)))
- (encoding (mime/encoded-word-encoding word))
- (text (mime/encoded-word-encoded-text word)))
- (mime/decode-encoded-text charset encoding text))
- word))
+ (or (if (string-match mime/encoded-word-regexp word)
+ (let ((charset (upcase (mime/encoded-word-charset word)))
+ (encoding (upcase (mime/encoded-word-encoding word)))
+ (text (mime/encoded-word-encoded-text word)))
+ (mime/decode-encoded-text charset encoding text)
+ ))
+ word))
(defun mime/decode-region (beg end)
(interactive "*r")
)
)
(setq end (match-end 0))
- (setq dest (concat dest (mime/decode-encoded-word (substring str beg end))
+ (setq dest (concat dest
+ (mime/decode-encoded-word (substring str beg end))
))
(setq str (substring str end))
(setq ew t)
;;;
(defun mime/encode-string (string encoding &optional mode)
- (cond ((equal encoding "B") (mime/base64-encode-string string))
- ((equal encoding "Q") (mime/Quoted-Printable-encode-string string mode))
- (t nil)
+ (cond ((string= encoding "B") (base64-encode-string string))
+ ((string= encoding "Q") (q-encoding-encode-string string mode))
))
(defun mime/encode-field (str)
))
))
+(defun mime/exist-encoded-word-in-subject ()
+ (let ((str (message/get-field-body "Subject")))
+ (if (and str (string-match mime/encoded-word-regexp str))
+ str)))
+
(defun mime/encode-message-header ()
(interactive "*")
(save-excursion
(narrow-to-region (goto-char (point-min))
(progn
(re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$")
+ (concat
+ "^" (regexp-quote mail-header-separator) "$")
nil t)
(match-beginning 0)
))
)))
))
(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 (message/divide-field
- (mime/decode-string
- (message/unfolding-string str))
- ))))
- ))
- )))
+ (let ((str (mime/exist-encoded-word-in-subject)))
+ (if str
+ (insert (concat
+ "\nX-Nsubject: "
+ (mime/decode-string (message/unfolding-string str))
+ )))))
)))
-;;; @ Base64 (B-encode) decoder/encoder
-;;; by Enami Tsugutomo
-;;; modified by mol.
-
-(defun mime/base64-decode-string (string)
- (mime/base64-mapconcat (function mime/base64-decode-chars) 4 string))
-
-;; (mime/base64-encode-string (mime/base64-decode-string "GyRAOjRGI0stGyhK"))
-(defun mime/base64-encode-string (string &optional mode)
- (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) "==")
- ))
- ))
-
-;; (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))))
-
-(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))))))
-
-;; (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))
-
-(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))
-
-;;; @ Quoted-Printable (Q-encode) encoder/decoder
-;;;
-
-(defun mime/Quoted-Printable-decode-string (str)
- (let ((dest "")
- (len (length str))
- (i 0) chr num h l)
- (while (< i len)
- (setq chr (elt str i))
- (cond ((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))
- )))
- ((eq chr ?_)
- (setq dest (concat dest (char-to-string 32)))
- (setq i (+ i 1))
- )
- (t
- (setq dest (concat dest (char-to-string chr)))
- (setq i (+ i 1))
- ))
- )
- dest))
-
-(defun mime/Quoted-Printable-encode-string (str &optional mode)
- (if (null mode)
- (setq mode 'phrase))
- (let ((dest "")
- (len (length str))
- (i 0) chr)
- (while (< i len)
- (setq chr (elt str i))
- (cond ((eq chr 32)
- (setq dest (concat dest "_"))
- )
- ((or (eq chr ?=)
- (eq chr ??)
- (eq chr ?_)
- (and (eq mode 'comment)
- (or (eq chr ?\()
- (eq chr ?\))
- (eq chr ?\\)
- ))
- (and (eq mode 'phrase)
- (not (string-match "[A-Za-z0-9!*+/=_---]"
- (char-to-string chr)))
- )
- (< chr 32)
- (> chr 126))
- (setq dest (concat dest
- "="
- (char-to-string (number-to-hex-char (/ chr 16)))
- (char-to-string (number-to-hex-char (% chr 16)))
- ))
- )
- (t (setq dest (concat dest (char-to-string chr)))
- ))
- (setq i (+ i 1))
- )
- dest))
;;; @ functions for message header encoding
;;;
(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))
+ (setq m (+ n
+ (mime/encoded-word-length js encoding)
+ cesl))
(< m 76))
(setq j i)
(setq i (+ i (char-bytes (elt string i))))
(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)))
+ (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 ret
+ (mime/encode-and-split-string
+ 1 str charset encoding))
)
(setq dest (concat dest "\n " (nth 1 ret)))
(setq m (car ret))
))
(defun mime/encode-header-string (n string &optional mode)
- (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 (string-width w)) 76)
- (progn
- (setq dest (concat dest "\n "))
- (setq b 1)
- )
- (setq b n))
- (setq dest (concat dest w))
- (setq b (+ b (string-width 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))
+ (if (string= string "")
+ (list n "")
+ (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))
- (cond ((string-match "^[ \t]*$" w)
- (setq b (+ b (string-width (cdr cell))))
- (setq dest (concat dest (cdr cell)))
- )
- ((eq et nil)
- (if (> (+ b (string-width w)) 76)
- (progn
- (if (eq (elt dest (- (length dest) 1)) 32)
- (setq dest (substring dest 0 (- (length dest) 1)))
+ ;; string-width crashes when the argument is nil,
+ ;; so replace the argument
+ ;; (original modification by Kenji Rikitake 9-JAN-1995)
+ (setq w (or (cdr cell) ""))
+ (if (eq et nil)
+ (progn
+ (if (> (+ n (string-width w)) 76)
+ (progn
+ (setq dest (concat dest "\n "))
+ (setq b 1)
+ )
+ (setq b n))
+ (setq dest (concat dest w))
+ (setq b (+ b (string-width 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 "^[ \t]*$" w)
+ (setq b (+ b (string-width (cdr cell))))
+ (setq dest (concat dest (cdr cell)))
+ )
+ ((eq et nil)
+ (if (> (+ b (string-width 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))
)
- (setq dest (concat dest "\n " w))
- (setq b (+ (length w) 1))
- )
- (setq l (length dest))
- (if (and (>= l 2)
- (eq (elt dest (- l 2)) ?\?)
- (eq (elt dest (- l 1)) ?=)
- )
+ (setq l (length dest))
+ (if (and (>= l 2)
+ (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 (string-width w)))
+ ))
+ (t
+ (if (not (eq (elt dest (- (length dest) 1)) 32))
(progn
(setq dest (concat dest " "))
(setq b (+ b 1))
))
- (setq dest (concat dest w))
- (setq b (+ b (string-width w)))
+ (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)))
+ )
))
- (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)))
+ (setq i (+ i 1))
+ )
+ (list b dest)
+ )))
(defun mime/encode-address-list (n str)
- (let ((ret (message/parse-addresses str))
- len (i 0) cell en-ret j cl (dest "") s)
- (setq len (length ret))
- (while (< i len)
- (setq cell (nth i ret))
+ (let* ((ret (message/parse-addresses str))
+ (r ret) cell en-ret j cl (dest "") s)
+ (while r
+ (setq cell (car r))
(cond ((string= (nth 1 cell) "<")
(setq en-ret (mime/encode-header-string n (nth 0 cell) 'phrase))
(setq dest (concat dest (nth 1 en-ret)))
(setq n (car en-ret))
- (if (< i (- len 1))
- (setq en-ret
+ (if (> (length r) 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
(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) 'comment))
+ (setq en-ret (mime/encode-header-string (+ n 2) (nth 2 cell)
+ 'comment))
(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) 'comment))
+ (setq en-ret (mime/encode-header-string 2 (nth 2 cell)
+ 'comment))
)
(progn
(setq dest (concat dest " ("))
))
(setq dest (concat dest (nth 1 en-ret)))
(setq n (car en-ret))
- (if (< i (- len 1))
+ (if (> (length r) 1)
(setq en-ret
- (mime/encode-header-string n (concat (nth 3 cell) ", ")))
+ (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))
)
(t
- (if (< i (- len 1))
+ (if (> (length r) 1)
(setq en-ret
- (mime/encode-header-string n (concat (nth 0 cell) ", ")))
+ (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)) )
+ (setq r (cdr r))
+ )
dest))
-;;; @ 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))
- ))
-
-(defun number-to-hex-char (n)
- (if (< n 10)
- (+ ?0 n)
- (+ ?A (- n 10))))
-
;;; @ utility for encoder
;;;
(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)
+ (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/separate-string-by-charset (str)
(defun mime/unfolding ()
(goto-char (point-min))
(let (field beg end)
- (while (re-search-forward message/field-regexp nil t)
+ (while (re-search-forward message/field-name-regexp nil t)
(setq beg (match-beginning 0))
- (setq end (match-end 0))
+ (setq end (message/field-end))
(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[ \t]+" nil t)
- (replace-match " ")
- )
- ))
+ (save-restriction
+ (narrow-to-region (goto-char beg) end)
+ (while (re-search-forward "\n[ \t]+" nil t)
+ (replace-match " ")
+ )
+ (goto-char (point-max))
))
- ))
- )
+ )))
(defun mime/prepare-decode-message-header ()
(mime/unfolding)
(run-hooks 'mime/tiny-mime-load-hook)
+(provide 'tiny-mime)
+
;;; @
;;; Local Variables:
;;; mode: emacs-lisp
projects / elisp / tm.git / blobdiff