;;;
-;;; A multilingual MIME message header encoder/decoder.
-;;; by Morioka Tomohiko (morioka@jaist.ac.jp)
+;;; tm-eword.el --- RFC 1522 based multilingual MIME message header
+;;; encoder/decoder for GNU Emacs
;;;
-;;; original MIME decoder is
-;;; mime.el,v 1.5 1992/07/18 07:52:08 by Enami Tsugutomo
+;;; Copyright (C) 1995 Free Software Foundation, Inc.
+;;; Copyright (C) 1993,1994,1995 MORIOKA Tomohiko
;;;
-
-;;; @ require modules
-;;;
-(require 'tl-misc)
-(require 'tl-822)
-(require 'tl-num)
-(require 'base64)
-(require 'qprint)
-
-
-;;; @ version
-;;;
-(defconst mime/RCS-ID
- "$Id: tm-eword.el,v 5.12 1995/05/21 16:06:27 morioka Exp morioka $")
-
-(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-regexp "[0123456789ABCDEF]")
-(defconst mime/Quoted-Printable-octet-regexp
- (concat "="
- mime/Quoted-Printable-hex-char-regexp
- mime/Quoted-Printable-hex-char-regexp))
-(defconst mime/Quoted-Printable-encoded-text-regexp
- (concat "\\([^=?]\\|" mime/Quoted-Printable-octet-regexp "\\)+"))
-(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 "?")
- "\\("
- 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/encoded-word-charset (str)
- (mime/nth-string str 1))
-
-(defun mime/encoded-word-encoding (str)
- (mime/nth-string str 2))
-
-(defun mime/encoded-word-encoded-text (str)
- (mime/nth-string str 3))
-
-(defun mime/rest-of-string (str)
- (if (stringp str)
- (substring str (match-end 0))
- (buffer-substring (match-end 0)(point-max))
- ))
-
-
-;;; @ variables
-;;;
-
-(defvar mime/no-encoding-header-fields '("X-Nsubject"))
-
-(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-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))
-
-(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)
- ))
-
-;;; @@ MIME header encoders
+;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;; Created: 1993/6/3 (1995/10/3 obsolete tiny-mime.el)
+;;; Version:
+;;; $Id: tm-eword.el,v 7.10 1995/12/06 08:20:02 morioka Exp $
+;;; Keywords: mail, news, MIME, RFC 1522, multilingual, encoded-word
+;;; Commentary: This module is obsoleted. tm-ew-d.el is part of
+;;; tm-view.el, and tm-ew-e.el is part of tm-edit.el.
;;;
-
-(defun mime/encode-string (string encoding &optional mode)
- (cond ((equal encoding "B")
- (base64-encode-string string)
- )
- ((equal encoding "Q")
- (quoted-printable-encode-string string (or mode 'phrase))
- )
- ))
-
-(defun mime/encode-field (str)
- (setq str (rfc822/unfolding-string str))
- (let ((ret (message/divide-field str))
- field-name field-body)
- (setq field-name (car ret))
- (setq field-body (nth 1 ret))
- (concat field-name " "
- (cond ((string= field-body "") "")
- ((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)
- )
- (t
- (catch 'tag
- (let ((r mime/no-encoding-header-fields) fn)
- (while r
- (setq fn (car r))
- (if (string-match (concat "^" fn ":$") field-name)
- (throw 'tag field-body)
- )
- (setq r (cdr r))
- ))
- (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
- (concat "^" (regexp-quote mail-header-separator) "$")
- nil t)
- (match-beginning 0)
- ))
- (goto-char (point-min))
- (let (beg end field)
- (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 (message/divide-field
- (mime/decode-string
- (rfc822/unfolding-string str))
- ))))
- ))
- )))
- )))
-
-
-;;; @ functions for message header encoding
+;;; This file is part of tm (Tools for MIME).
;;;
-
-(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)
- (setq i (+ i (char-bytes (elt string i))))
- )
- (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 &optional mode)
- (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))
- ;; 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 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 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 (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 (> (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
- 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))
- )
- ((= (length cell) 4)
- (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)
- '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))
- )
- (progn
- (setq dest (concat dest " ("))
- ))
- (setq dest (concat dest (nth 1 en-ret)))
- (setq n (car en-ret))
- (if (> (length r) 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))
- )
- (t
- (if (> (length r) 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 r (cdr r))
- )
- dest))
-
-
-;;; @ utility for encoder
+;;; 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.
;;;
-
-;;; @@ encoded-word length
+;;; 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.
;;;
-
-(defun mime/encoded-word-length (string encoding)
- (cond ((equal encoding "B") (base64-encoded-length string))
- ((equal encoding "Q") (quoted-printable-encoded-length string))
- ))
-
-;;; @@ separate by character set
+;;; 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:
-;; 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
- (get-lc chr)
- ))
+(require 'tl-822)
+(require 'tl-str)
+(require 'tm-def)
-(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)
- )))
+(autoload 'mime/encode-message-header "tm-ew-e" nil t)
+(autoload 'mime/decode-message-header "tm-ew-d" nil t)
+(autoload 'mime/encode-field "tm-ew-e" nil t)
-(defun mime/separate-string-by-charset (str)
- (let ((rl (mime/separate-string-by-chartype str))
- (i 1) len (pcell nil) cell ncell dpcell (dest nil) LC)
- (setq len (length rl))
- (setq dpcell (list (nth 0 rl)))
- (setq cell (nth 1 rl))
- (setq ncell (nth 2 rl))
- (while (< i len)
- (setq LC (car (car dpcell)))
- (cond ((and (not (eq LC lc-ascii))
- (eq (car cell) LC-space)
- (not (eq (car ncell) lc-ascii)))
- (setq dpcell (list (cons LC
- (concat (cdr (car dpcell)) (cdr cell))
- )))
- )
- ((and (not (eq LC lc-ascii))
- (eq LC (car cell)))
- (setq dpcell (list (cons LC
- (concat (cdr (car dpcell)) (cdr cell))
- )))
- )
- ((and (eq LC lc-ascii)
- (member (car cell) mime/latin-lc-list))
- (setq dpcell (list (cons (car cell)
- (concat (cdr (car dpcell)) (cdr cell))
- )))
- )
- ((and (member LC mime/latin-lc-list)
- (eq (car cell) lc-ascii))
- (setq dpcell (list (cons LC
- (concat (cdr (car dpcell)) (cdr cell))
- )))
- )
- (t
- (setq dest (append dest dpcell))
- (setq dpcell (list cell))
- ))
- (setq i (+ i 1))
- (setq cell ncell)
- (setq ncell (nth (+ i 1) rl))
- )
- (setq dest (append dest dpcell))
- ))
+(autoload 'mime-eword/decode-region "tm-ew-d" nil t)
+(autoload 'mime-eword/encode-string "tm-ew-e")
+(autoload 'mime-eword/decode-string "tm-ew-d")
-(defun mime/separate-string-for-encoder (string)
- (let (lastspace)
- (if (string-match "[ \t]+$" string)
- (progn
- (setq lastspace (substring string
- (match-beginning 0)
- (match-end 0)))
- (setq string (substring string 0 (match-beginning 0)))
- ))
- (let ((rl (mime/separate-string-by-charset 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 (not (eq (car cell0) lc-ascii))
- (eq (car cell1) LC-space)
- (not (eq (car cell2) lc-ascii))
- )
- (setq dest
- (append dest (list
- (cons
- (cdr (assoc (car cell0)
- mime/lc-charset-and-encoding-alist))
- (concat (cdr cell0) (cdr cell1))
- ))))
- (setq i (+ i 2))
- (setq cell0 (nth i rl))
- (setq cell1 (nth (+ i 1) rl))
- (setq cell2 (nth (+ i 2) rl))
- )
- (t
- (setq dest
- (append dest (list
- (cons
- (cdr (assoc (car cell0)
- mime/lc-charset-and-encoding-alist))
- (cdr cell0)))))
- (setq i (+ i 1))
- (setq cell0 cell1)
- (setq cell1 cell2)
- (setq cell2 (nth (+ i 2) rl))
- ))
- )
- (append dest
- (if lastspace
- (list (cons nil lastspace))))
- )))
-
-
+(autoload 'mime/exist-encoded-word-in-subject "tm-ew-e" nil t)
-;;;
-;;; basic functions for MIME header decoder
-;;;
-;;; @ utility for decoder
+;;; @ end
;;;
-(defun mime/unfolding ()
- (goto-char (point-min))
- (let (field beg end)
- (while (re-search-forward message/field-regexp 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[ \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 "?==?")
- )
- )
-
-(setq mime-charset-list
- (list (list "US-ASCII" lc-ascii)
- (list "ISO-8859-1" lc-ascii lc-ltn1)
- (list "ISO-8859-2" lc-ascii lc-ltn2)
- (list "ISO-8859-3" lc-ascii lc-ltn3)
- (list "ISO-8859-4" lc-ascii lc-ltn4)
- (list "ISO-8859-5" lc-ascii lc-crl)
- (list "ISO-8859-7" lc-ascii lc-grk)
- (list "ISO-8859-9" lc-ascii lc-ltn5)
- (list "ISO-2022-JP" lc-ascii lc-jp)
- (list "ISO-2022-KR" lc-ascii lc-kr)
- (list "ISO-2022-JP-2" lc-ascii lc-ltn1 lc-grk
- lc-jp lc-cn lc-kr lc-jp2)
- (list "ISO-2022-INT-1" lc-ascii lc-ltn1 lc-grk
- lc-jp lc-cn lc-kr lc-jp2 lc-cns1 lc-cns2)
- ))
-
-(setq eword-field-body-separator-regexp " / ")
-
-(if (string-match eword-field-body-separator-regexp str)
- (list (substring str 0 (match-beginning 0))
- (substring str (match-beginning 0)(match-end 0))
- (substring str (match-end 0))
- ))
-
-(defun find-lc-set-string (str)
- (let (dest (len (length str))(i 0) chr lc)
- (while (< i len)
- (setq chr (elt str i))
- (setq lc (get-lc chr))
- (if (not (memq lc dest))
- (setq dest (cons lc dest))
- )
- (setq i (+ i (char-bytes chr)))
- )
- dest))
-
-(defun mime/lc-set-to-charset (lc-set)
- (let ((rest mime-charset-list) cell)
- (catch 'tag
- (while rest
- (setq cell (car rest))
- (if (subsetp lc-set (cdr cell))
- (throw 'tag (car cell))
- )
- (setq rest (cdr rest))
- ))))
-
-(run-hooks 'mime/tiny-mime-load-hook)
-
-(provide 'tiny-mime)
-
-;;; @
-;;; Local Variables:
-;;; mode: emacs-lisp
-;;; mode: outline-minor
-;;; outline-regexp: ";;; @+\\|(......"
-;;; End:
+(provide 'tm-eword)
projects / elisp / tm.git / blobdiff