X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=eword-decode.el;h=aa638db15191ed9163301416513fc04a1eabcce0;hb=6f51fe62c098f93d16ed48c79041121c358ead7a;hp=a9ad5a10d742f4fd8a0c0a278b43f8456b18166b;hpb=5ab0142c5a13d42650dce71e4717989c5fafc8d5;p=elisp%2Fsemi.git

diff --git a/eword-decode.el b/eword-decode.el
index a9ad5a1..aa638db 100644
--- a/eword-decode.el
+++ b/eword-decode.el
@@ -1,6 +1,6 @@
 ;;; 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>
@@ -10,10 +10,9 @@
 ;;	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.1 $
 ;; 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
@@ -32,19 +31,16 @@
 
 ;;; 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.1 1997-02-24 01:46:59 tmorioka Exp $")
-(defconst eword-decode-version (get-version-string eword-decode-RCS-ID))
+(defconst eword-decode-version
+  `,(mapconcat #'number-to-string (cdr semi-version) "."))
 
 
 ;;; @ MIME encoded-word definition
@@ -65,6 +61,43 @@
 	  (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
 ;;;
 
@@ -132,29 +165,85 @@ such as a version of Net$cape)."
 	(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-message-header ()
-  "Decode MIME encoded-words in message header."
+(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
-      (narrow-to-region (goto-char (point-min))
-			(progn (re-search-forward "^$" nil t) (point)))
-      (eword-decode-region (point-min) (point-max) t)
-      )))
+      (std11-narrow-to-header separator)
+      (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))
@@ -177,6 +266,8 @@ such as a version of Net$cape)."
 ;;; @ 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.
 
@@ -200,11 +291,12 @@ as a version of Net$cape)."
             (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))
 
@@ -259,6 +351,269 @@ as a version of Net$cape)."
 		))))))
 
 
+;;; @ 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) . ""))
+	      ))
+      (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
 ;;;