;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs
-;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; Renamed: 1993/06/03 to tiny-mime.el
;; Renamed: 1995/10/03 from tiny-mime.el (split off encoder)
;; Renamed: 1997/02/22 from tm-ew-d.el
-;; Version: $Revision: 0.3 $
;; Keywords: encoded-word, MIME, multilingual, header, mail, news
-;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
+;; This file is part of SEMI (Spadework for Emacs MIME Interfaces).
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;;; Code:
-(require 'emu)
-(require 'std11)
+(require 'std11-parse)
(require 'mel)
(require 'mime-def)
-(require 'tl-str)
+(defgroup eword-decode nil
+ "Encoded-word decoding"
+ :group 'mime)
-;;; @ version
-;;;
-
-(defconst eword-decode-RCS-ID
- "$Id: eword-decode.el,v 0.3 1997-02-24 02:26:02 tmorioka Exp $")
-(defconst eword-decode-version (get-version-string eword-decode-RCS-ID))
+(defconst eword-decode-version
+ `,(mapconcat #'number-to-string (cddr mime-module-version) "."))
;;; @ MIME encoded-word definition
(regexp-quote "?=")))
+;;; @@ Base64
+;;;
+
+(defconst base64-token-regexp "[A-Za-z0-9+/]")
+(defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
+
+(defconst eword-B-encoded-text-regexp
+ (concat "\\(\\("
+ base64-token-regexp
+ base64-token-regexp
+ base64-token-regexp
+ base64-token-regexp
+ "\\)*"
+ base64-token-regexp
+ base64-token-regexp
+ base64-token-padding-regexp
+ base64-token-padding-regexp
+ "\\)"))
+
+;; (defconst eword-B-encoding-and-encoded-text-regexp
+;; (concat "\\(B\\)\\?" eword-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 eword-Q-encoded-text-regexp
+ (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
+;; (defconst eword-Q-encoding-and-encoded-text-regexp
+;; (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp))
+
+
;;; @ for string
;;;
(replace-match "\\1\\6")
(goto-char (point-min))
)
- (let (charset encoding text)
- (while (re-search-forward eword-encoded-word-regexp nil t)
- (insert (eword-decode-encoded-word
- (prog1
- (buffer-substring (match-beginning 0) (match-end 0))
- (delete-region (match-beginning 0) (match-end 0))
- ) must-unfold))
- ))
+ (while (re-search-forward eword-encoded-word-regexp nil t)
+ (insert (eword-decode-encoded-word
+ (prog1
+ (buffer-substring (match-beginning 0) (match-end 0))
+ (delete-region (match-beginning 0) (match-end 0))
+ ) must-unfold))
+ )
)))
;;; @ for message header
;;;
-(defun eword-decode-header (&optional separator)
+(defcustom eword-decode-ignored-field-list
+ '(newsgroups path lines nntp-posting-host message-id date)
+ "*List of field-names to be ignored when decoding.
+Each field name must be symbol."
+ :group 'eword-decode
+ :type '(repeat symbol))
+
+(defcustom eword-decode-structured-field-list
+ '(reply-to resent-reply-to from resent-from sender resent-sender
+ to resent-to cc resent-cc bcc resent-bcc dcc
+ mime-version content-type content-transfer-encoding
+ content-disposition)
+ "*List of field-names to decode as structured field.
+Each field name must be symbol."
+ :group 'eword-decode
+ :type '(repeat symbol))
+
+(defun eword-decode-header (&optional code-conversion separator)
"Decode MIME encoded-words in header fields.
+If CODE-CONVERSION is nil, it decodes only encoded-words. If it is
+mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
+Otherwise it decodes non-ASCII bit patterns as the
+default-mime-charset.
If SEPARATOR is not nil, it is used as header separator."
(interactive "*")
(save-excursion
(save-restriction
(std11-narrow-to-header separator)
- (eword-decode-region (point-min) (point-max) t)
- )))
+ (let ((default-charset
+ (if code-conversion
+ (if (mime-charset-to-coding-system code-conversion)
+ code-conversion
+ default-mime-charset))))
+ (if default-charset
+ (let (beg p end field-name len)
+ (goto-char (point-min))
+ (while (re-search-forward std11-field-head-regexp nil t)
+ (setq beg (match-beginning 0)
+ p (match-end 0)
+ field-name (buffer-substring beg (1- p))
+ len (string-width field-name)
+ field-name (intern (downcase field-name))
+ end (std11-field-end))
+ (cond ((memq field-name eword-decode-ignored-field-list)
+ ;; Don't decode
+ )
+ ((memq field-name eword-decode-structured-field-list)
+ ;; Decode as structured field
+ (let ((body (buffer-substring p end))
+ (default-mime-charset default-charset))
+ (delete-region p end)
+ (insert (eword-decode-and-fold-structured-field
+ body (1+ len)))
+ ))
+ (t
+ ;; Decode as unstructured field
+ (save-restriction
+ (narrow-to-region beg (1+ end))
+ (decode-mime-charset-region p end default-charset)
+ (goto-char p)
+ (if (re-search-forward eword-encoded-word-regexp
+ nil t)
+ (eword-decode-region beg (point-max) 'unfold))
+ )))))
+ (eword-decode-region (point-min) (point-max) t)
+ )))))
(defun eword-decode-unfold ()
(goto-char (point-min))
;;; @ encoded-word decoder
;;;
+(defvar eword-warning-face nil "Face used for invalid encoded-word.")
+
(defun eword-decode-encoded-word (word &optional must-unfold)
"Decode WORD if it is an encoded-word.
(condition-case err
(eword-decode-encoded-text charset encoding text must-unfold)
(error
- (and (tl:add-text-properties 0 (length word)
- (and tm:warning-face
- (list 'face tm:warning-face))
- word)
- word)))
+ (and
+ (add-text-properties 0 (length word)
+ (and eword-warning-face
+ (list 'face eword-warning-face))
+ word)
+ word)))
))
word))
))))))
+;;; @ lexical analyze
+;;;
+
+(defvar eword-lexical-analyze-cache nil)
+(defvar eword-lexical-analyze-cache-max 299
+ "*Max position of eword-lexical-analyze-cache.
+It is max size of eword-lexical-analyze-cache - 1.")
+
+(defcustom eword-lexical-analyzers
+ '(eword-analyze-quoted-string
+ eword-analyze-domain-literal
+ eword-analyze-comment
+ eword-analyze-spaces
+ eword-analyze-special
+ eword-analyze-encoded-word
+ eword-analyze-atom)
+ "*List of functions to return result of lexical analyze.
+Each function must have two arguments: STRING and MUST-UNFOLD.
+STRING is the target string to be analyzed.
+If MUST-UNFOLD is not nil, each function must unfold and eliminate
+bare-CR and bare-LF from the result even if they are included in
+content of the encoded-word.
+Each function must return nil if it can not analyze STRING as its
+format.
+
+Previous function is preferred to next function. If a function
+returns nil, next function is used. Otherwise the return value will
+be the result."
+ :group 'eword-decode
+ :type '(repeat function))
+
+(defun eword-analyze-quoted-string (string &optional must-unfold)
+ (let ((p (std11-check-enclosure string ?\" ?\")))
+ (if p
+ (cons (cons 'quoted-string
+ (decode-mime-charset-string
+ (std11-strip-quoted-pair (substring string 1 (1- p)))
+ default-mime-charset))
+ (substring string p))
+ )))
+
+(defun eword-analyze-domain-literal (string &optional must-unfold)
+ (std11-analyze-domain-literal string))
+
+(defun eword-analyze-comment (string &optional must-unfold)
+ (let ((p (std11-check-enclosure string ?\( ?\) t)))
+ (if p
+ (cons (cons 'comment
+ (eword-decode-string
+ (decode-mime-charset-string
+ (std11-strip-quoted-pair (substring string 1 (1- p)))
+ default-mime-charset)
+ must-unfold))
+ (substring string p))
+ )))
+
+(defun eword-analyze-spaces (string &optional must-unfold)
+ (std11-analyze-spaces string))
+
+(defun eword-analyze-special (string &optional must-unfold)
+ (std11-analyze-special string))
+
+(defun eword-analyze-encoded-word (string &optional must-unfold)
+ (if (eq (string-match eword-encoded-word-regexp string) 0)
+ (let ((end (match-end 0))
+ (dest (eword-decode-encoded-word (match-string 0 string)
+ must-unfold))
+ )
+ (setq string (substring string end))
+ (while (eq (string-match `,(concat "[ \t\n]*\\("
+ eword-encoded-word-regexp
+ "\\)")
+ string)
+ 0)
+ (setq end (match-end 0))
+ (setq dest
+ (concat dest
+ (eword-decode-encoded-word (match-string 1 string)
+ must-unfold))
+ string (substring string end))
+ )
+ (cons (cons 'atom dest) string)
+ )))
+
+(defun eword-analyze-atom (string &optional must-unfold)
+ (if (string-match std11-atom-regexp string)
+ (let ((end (match-end 0)))
+ (cons (cons 'atom (decode-mime-charset-string
+ (substring string 0 end)
+ default-mime-charset))
+ (substring string end)
+ ))))
+
+(defun eword-lexical-analyze-internal (string must-unfold)
+ (let (dest ret)
+ (while (not (string-equal string ""))
+ (setq ret
+ (let ((rest eword-lexical-analyzers)
+ func r)
+ (while (and (setq func (car rest))
+ (null (setq r (funcall func string must-unfold)))
+ )
+ (setq rest (cdr rest)))
+ (or r `((error . ,string) . ""))
+ ))
+ (setq dest (cons (car ret) dest))
+ (setq string (cdr ret))
+ )
+ (nreverse dest)
+ ))
+
+(defun eword-lexical-analyze (string &optional must-unfold)
+ "Return lexical analyzed list corresponding STRING.
+It is like std11-lexical-analyze, but it decodes non us-ascii
+characters encoded as encoded-words or invalid \"raw\" format.
+\"Raw\" non us-ascii characters are regarded as variable
+`default-mime-charset'."
+ (let ((key (copy-sequence string))
+ ret)
+ (set-text-properties 0 (length key) nil key)
+ (if (setq ret (assoc key eword-lexical-analyze-cache))
+ (cdr ret)
+ (setq ret (eword-lexical-analyze-internal key must-unfold))
+ (setq eword-lexical-analyze-cache
+ (cons (cons key ret)
+ (last eword-lexical-analyze-cache
+ eword-lexical-analyze-cache-max)))
+ ret)))
+
+(defun eword-decode-token (token)
+ (let ((type (car token))
+ (value (cdr token)))
+ (cond ((eq type 'quoted-string)
+ (std11-wrap-as-quoted-string value))
+ ((eq type 'comment)
+ (concat "(" (std11-wrap-as-quoted-pairs value '(?( ?))) ")"))
+ (t value))))
+
+(defun eword-decode-and-fold-structured-field
+ (string start-column &optional max-column must-unfold)
+ "Decode and fold (fill) STRING as structured field body.
+It decodes non us-ascii characters in FULL-NAME encoded as
+encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
+characters are regarded as variable `default-mime-charset'.
+
+If an encoded-word is broken or your emacs implementation can not
+decode the charset included in it, it is not decoded.
+
+If MAX-COLUMN is omitted, `fill-column' is used.
+
+If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
+if there are in decoded encoded-words (generated by bad manner MUA
+such as a version of Net$cape)."
+ (or max-column
+ (setq max-column fill-column))
+ (let ((c start-column)
+ (tokens (eword-lexical-analyze string must-unfold))
+ (result "")
+ token)
+ (while (and (setq token (car tokens))
+ (setq tokens (cdr tokens)))
+ (let* ((type (car token)))
+ (if (eq type 'spaces)
+ (let* ((next-token (car tokens))
+ (next-str (eword-decode-token next-token))
+ (next-len (string-width next-str))
+ (next-c (+ c next-len 1)))
+ (if (< next-c max-column)
+ (setq result (concat result " " next-str)
+ c next-c)
+ (setq result (concat result "\n " next-str)
+ c (1+ next-len)))
+ (setq tokens (cdr tokens))
+ )
+ (let* ((str (eword-decode-token token)))
+ (setq result (concat result str)
+ c (+ c (string-width str)))
+ ))))
+ (if token
+ (concat result (eword-decode-token token))
+ result)))
+
+(defun eword-decode-and-unfold-structured-field (string)
+ "Decode and unfold STRING as structured field body.
+It decodes non us-ascii characters in FULL-NAME encoded as
+encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
+characters are regarded as variable `default-mime-charset'.
+
+If an encoded-word is broken or your emacs implementation can not
+decode the charset included in it, it is not decoded."
+ (let ((tokens (eword-lexical-analyze string 'must-unfold))
+ (result ""))
+ (while tokens
+ (let* ((token (car tokens))
+ (type (car token)))
+ (setq tokens (cdr tokens))
+ (setq result
+ (if (eq type 'spaces)
+ (concat result " ")
+ (concat result (eword-decode-token token))
+ ))))
+ result))
+
+(defun eword-decode-structured-field-body (string &optional must-unfold
+ start-column max-column)
+ "Decode non us-ascii characters in STRING as structured field body.
+STRING is unfolded before decoding.
+
+It decodes non us-ascii characters in FULL-NAME encoded as
+encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
+characters are regarded as variable `default-mime-charset'.
+
+If an encoded-word is broken or your emacs implementation can not
+decode the charset included in it, it is not decoded.
+
+If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
+if there are in decoded encoded-words (generated by bad manner MUA
+such as a version of Net$cape)."
+ (if start-column
+ ;; fold with max-column
+ (eword-decode-and-fold-structured-field
+ string start-column max-column must-unfold)
+ ;; Don't fold
+ (mapconcat (function eword-decode-token)
+ (eword-lexical-analyze string must-unfold)
+ "")
+ ))
+
+(defun eword-decode-unstructured-field-body (string &optional must-unfold)
+ "Decode non us-ascii characters in STRING as unstructured field body.
+STRING is unfolded before decoding.
+
+It decodes non us-ascii characters in FULL-NAME encoded as
+encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
+characters are regarded as variable `default-mime-charset'.
+
+If an encoded-word is broken or your emacs implementation can not
+decode the charset included in it, it is not decoded.
+
+If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
+if there are in decoded encoded-words (generated by bad manner MUA
+such as a version of Net$cape)."
+ (eword-decode-string
+ (decode-mime-charset-string string default-mime-charset)
+ must-unfold))
+
+(defun eword-extract-address-components (string)
+ "Extract full name and canonical address from STRING.
+Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
+If no name can be extracted, FULL-NAME will be nil.
+It decodes non us-ascii characters in FULL-NAME encoded as
+encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
+characters are regarded as variable `default-mime-charset'."
+ (let* ((structure (car (std11-parse-address
+ (eword-lexical-analyze
+ (std11-unfold-string string) 'must-unfold))))
+ (phrase (std11-full-name-string structure))
+ (address (std11-address-string structure))
+ )
+ (list phrase address)
+ ))
+
+
;;; @ end
;;;
projects / elisp / semi.git / blobdiff