X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Frfc2047.el;h=3344753952656e3891c4ae6b56e5c5aa68a92250;hb=3304290c446e3fd89151ebe599b3c0cea8522329;hp=a85f6a5fcaf348ef2026e4ab9482a540571237d7;hpb=8105541ee890397f15d41f6ac2d1a818ce80e0f4;p=elisp%2Fgnus.git-

diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el
index a85f6a5..3344753 100644
--- a/lisp/rfc2047.el
+++ b/lisp/rfc2047.el
@@ -1,5 +1,5 @@
 ;;; rfc2047.el --- Functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1998,99 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -24,12 +24,15 @@
 
 ;;; Code:
 
-(require 'base64)
+(eval-and-compile
+  (eval
+   '(unless (fboundp 'base64-decode-string)
+      (require 'base64))))
+
 (require 'qp)
 (require 'mm-util)
-
-(defvar rfc2047-unencoded-charsets '(ascii latin-iso8859-1)
-  "List of MULE charsets not to encode.")
+(require 'ietf-drums)
+(require 'mail-prsvr)
 
 (defvar rfc2047-header-encoding-alist
   '(("Newsgroups" . nil)
@@ -53,8 +56,8 @@ The values can be:
     (iso-8859-2 . Q)
     (iso-8859-3 . Q)
     (iso-8859-4 . Q)
-    (iso-8859-5 . Q)
-    (koi8-r . Q)
+    (iso-8859-5 . B)
+    (koi8-r . B)
     (iso-8859-7 . Q)
     (iso-8859-8 . Q)
     (iso-8859-9 . Q)
@@ -71,13 +74,13 @@ Valid encodings are nil, `Q' and `B'.")
 
 (defvar rfc2047-encoding-function-alist
   '((Q . rfc2047-q-encode-region)
-    (B . base64-encode-region)
+    (B . rfc2047-b-encode-region)
     (nil . ignore))
   "Alist of RFC2047 encodings to encoding functions.")
 
 (defvar rfc2047-q-encoding-alist
-  '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "[^-A-Za-z0-9!*+/=_]")
-    ("." . "[\000-\007\013\015-\037\200-\377=_?]"))
+  '(("\\(From\\|Cc\\|To\\|Bcc\||Reply-To\\):" . "-A-Za-z0-9!*+/=_")
+    ("." . "^\000-\007\013\015-\037\200-\377=_?"))
   "Alist of header regexps and valid Q characters.")
 
 ;;;
@@ -98,13 +101,13 @@ Valid encodings are nil, `Q' and `B'.")
        (point-max))))
   (goto-char (point-min)))
 
-;;;###autoload
 (defun rfc2047-encode-message-header ()
   "Encode the message header according to `rfc2047-header-encoding-alist'.
 Should be called narrowed to the head of the message."
   (interactive "*")
   (when (featurep 'mule)
     (save-excursion
+      (goto-char (point-min))
       (let ((alist rfc2047-header-encoding-alist)
 	    elem method)
 	(while (not (eobp))
@@ -121,51 +124,57 @@ Should be called narrowed to the head of the message."
 	      (when method
 		(cond
 		 ((eq method 'mime)
-		  (rfc2047-encode-region (point-min) (point-max)))
+		  (rfc2047-encode-region (point-min) (point-max))
+		  (rfc2047-fold-region (point-min) (point-max)))
 		 ;; Hm.
 		 (t))))
-	    (goto-char (point-max))))))))
+	    (goto-char (point-max)))))
+      (when mail-parse-charset
+	(encode-coding-region (point-min) (point-max)
+			      mail-parse-charset)))))
 
 (defun rfc2047-encodable-p ()
   "Say whether the current (narrowed) buffer contains characters that need encoding."
-  (let ((charsets (find-charset-region (point-min) (point-max)))
-	(cs rfc2047-unencoded-charsets)
+  (let ((charsets
+	 (mapcar
+	  'mm-mime-charset
+	  (mm-find-charset-region (point-min) (point-max))))
+	(cs (list 'us-ascii mail-parse-charset))
 	found)
     (while charsets
       (unless (memq (pop charsets) cs)
 	(setq found t)))
     found))
 
+(defun rfc2047-dissect-region (b e)
+  "Dissect the region between B and E into words."
+  (let (words)
+    (save-restriction
+      (narrow-to-region b e)
+      (goto-char (point-min))
+      (while (re-search-forward
+	      (concat "[^" ietf-drums-tspecials " \t\n]+") nil t)
+	(push
+	 (list (match-beginning 0) (match-end 0)
+	       (car (delq 'ascii (mm-find-charset-region
+				  (match-beginning 0) (match-end 0)))))
+	 words))
+      words)))
+
 (defun rfc2047-encode-region (b e)
   "Encode all encodable words in REGION."
-  (let (prev c start qstart qprev qend)
-    (save-excursion
-      (goto-char b)
-      (while (re-search-forward "[^ \t\n]+" nil t)
-	(save-restriction
-	  (narrow-to-region (match-beginning 0) (match-end 0))
-	  (goto-char (setq start (point-min)))
-	  (setq prev nil)
-	  (while (not (eobp))
-	    (unless (eq (setq c (char-charset (following-char))) 'ascii)
-	      (cond
-	       ((eq c prev)
-		)
-	       ((null prev)
-		(setq qstart (or qstart start)
-		      qend (point-max)
-		      qprev c)
-		(setq prev c))
-	       (t
-		;(rfc2047-encode start (setq start (point)) prev)
-		(setq prev c))))
-	    (forward-char 1)))
-	(when (and (not prev) qstart)
-	  (rfc2047-encode qstart qend qprev)
-	  (setq qstart nil)))
-      (when qstart
-	(rfc2047-encode qstart qend qprev)
-	(setq qstart nil)))))
+  (let ((words (rfc2047-dissect-region b e))
+	beg end current word)
+    (while (setq word (pop words))
+      (if (equal (nth 2 word) current)
+	  (setq beg (nth 0 word))
+	(when current
+	  (rfc2047-encode beg end current))
+	(setq current (nth 2 word)
+	      beg (nth 0 word)
+	      end (nth 1 word))))
+    (when current
+      (rfc2047-encode beg end current))))
 
 (defun rfc2047-encode-string (string)
   "Encode words in STRING."
@@ -176,29 +185,66 @@ Should be called narrowed to the head of the message."
 
 (defun rfc2047-encode (b e charset)
   "Encode the word in the region with CHARSET."
-  (let* ((mime-charset (mm-mule-charset-to-mime-charset charset))
-	 (encoding (cdr (assq mime-charset
-			      rfc2047-charset-encoding-alist)))
+  (let* ((mime-charset (mm-mime-charset charset))
+	 (encoding (or (cdr (assq mime-charset
+				  rfc2047-charset-encoding-alist))
+		       'B))
 	 (start (concat
 		 "=?" (downcase (symbol-name mime-charset)) "?"
-		 (downcase (symbol-name encoding)) "?")))
+		 (downcase (symbol-name encoding)) "?"))
+	 (first t))
     (save-restriction
       (narrow-to-region b e)
-      (mm-encode-coding-region b e mime-charset)
+      (when (eq encoding 'B)
+	;; break into lines before encoding
+	(goto-char (point-min))
+	(while (not (eobp))
+	  (goto-char (min (point-max) (+ 15 (point))))
+	  (unless (eobp)
+	    (insert "\n"))))
+      (mm-encode-coding-region (point-min) (point-max) mime-charset)
       (funcall (cdr (assq encoding rfc2047-encoding-function-alist))
 	       (point-min) (point-max))
       (goto-char (point-min))
-      (insert start)
-      (goto-char (point-max))
-      (insert "?=")
-      ;; Encoded words can't be more than 75 chars long, so we have to
-      ;; split the long ones up.
-      (end-of-line)
-      (while (> (current-column) 74)
-	(beginning-of-line)
-	(forward-char 73)
-	(insert "?=\n " start)
-	(end-of-line)))))
+      (while (not (eobp))
+	(unless first
+	  (insert " "))
+	(setq first nil)
+	(insert start)
+	(end-of-line)
+	(insert "?=")
+	(forward-line 1)))))
+
+(defun rfc2047-fold-region (b e)
+  "Fold the long lines in the region."
+  (save-restriction
+    (narrow-to-region b e)
+    (goto-char (point-min))
+    (let ((break nil))
+      (while (not (eobp))
+	(cond
+	 ((memq (char-after) '(?  ?\t))
+	  (setq break (point)))
+	 ((and (not break)
+	       (looking-at "=\\?"))
+	  (setq break (point)))
+	 ((and (looking-at "\\?=")
+	       (> (- (point) (save-excursion (beginning-of-line) (point))) 76))
+	  (goto-char break)
+	  (insert "\n ")
+	  (forward-line 1)))
+	(unless (eobp)
+	  (forward-char 1))))))
+
+(defun rfc2047-b-encode-region (b e)
+  "Encode the header contained in REGION with the B encoding."
+  (save-restriction
+    (narrow-to-region (goto-char b) e)
+    (while (not (eobp))
+      (base64-encode-region (point) (progn (end-of-line) (point)) t)
+      (if (and (bolp) (eolp))
+	  (delete-backward-char 1))
+      (forward-line))))
 
 (defun rfc2047-q-encode-region (b e)
   "Encode the header contained in REGION with the Q encoding."
@@ -209,48 +255,68 @@ Should be called narrowed to the head of the message."
 	(while alist
 	  (when (looking-at (caar alist))
 	    (quoted-printable-encode-region b e nil (cdar alist))
-	    (subst-char-in-region (point-min) (point-max) ?  ?_))
-	  (pop alist))))))
+	    (subst-char-in-region (point-min) (point-max) ?  ?_)
+	    (setq alist nil))
+	  (pop alist))
+	(goto-char (point-min))
+	(while (not (eobp))
+	  (goto-char (min (point-max) (+ 64 (point))))
+	  (search-backward "=" (- (point) 2) t)
+	  (unless (eobp)
+	    (insert "\n")))))))
 
 ;;;
 ;;; Functions for decoding RFC2047 messages
 ;;;
 
 (defvar rfc2047-encoded-word-regexp
-  "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~]+\\)\\?=")
+  "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~ +]+\\)\\?=")
 
-;;;###autoload
 (defun rfc2047-decode-region (start end)
   "Decode MIME-encoded words in region between START and END."
   (interactive "r")
-  (save-excursion
-    (save-restriction
-      (narrow-to-region start end)
-      (goto-char (point-min))
-      ;; Remove whitespace between encoded words.
-      (while (re-search-forward
-	      (concat "\\(" rfc2047-encoded-word-regexp "\\)"
-		      "\\(\n?[ \t]\\)+"
-		      "\\(" rfc2047-encoded-word-regexp "\\)")
-	      nil t)
-	(delete-region (goto-char (match-end 1)) (match-beginning 6)))
-      ;; Decode the encoded words.
-      (goto-char (point-min))
-      (while (re-search-forward rfc2047-encoded-word-regexp nil t)
-	(insert (rfc2047-parse-and-decode
-		 (prog1
-		     (match-string 0)
-		   (delete-region (match-beginning 0) (match-end 0)))))))))
+  (let ((case-fold-search t)
+	b e)
+    (save-excursion
+      (save-restriction
+	(narrow-to-region start end)
+	(goto-char (point-min))
+	;; Remove whitespace between encoded words.
+	(while (re-search-forward
+		(concat "\\(" rfc2047-encoded-word-regexp "\\)"
+			"\\(\n?[ \t]\\)+"
+			"\\(" rfc2047-encoded-word-regexp "\\)")
+		nil t)
+	  (delete-region (goto-char (match-end 1)) (match-beginning 6)))
+	;; Decode the encoded words.
+	(setq b (goto-char (point-min)))
+	(while (re-search-forward rfc2047-encoded-word-regexp nil t)
+	  (setq e (match-beginning 0))
+	  (insert (rfc2047-parse-and-decode
+		   (prog1
+		       (match-string 0)
+		     (delete-region (match-beginning 0) (match-end 0)))))
+	  (when (and (mm-multibyte-p)
+		     mail-parse-charset
+		     (not (eq mail-parse-charset 'gnus-decoded)))
+	    (mm-decode-coding-region b e mail-parse-charset))
+	  (setq b (point)))
+	(when (and (mm-multibyte-p)
+		   mail-parse-charset
+		   (not (eq mail-parse-charset 'us-ascii))
+		   (not (eq mail-parse-charset 'gnus-decoded)))
+	  (mm-decode-coding-region b (point-max) mail-parse-charset))))))
 
-;;;###autoload
 (defun rfc2047-decode-string (string)
- "Decode the quoted-printable-encoded STRING and return the results."
- (with-temp-buffer
-   (mm-enable-multibyte)
-   (insert string)
-   (inline
-     (rfc2047-decode-region (point-min) (point-max)))
-   (buffer-string)))
+  "Decode the quoted-printable-encoded STRING and return the results."
+  (let ((m (mm-multibyte-p)))
+    (with-temp-buffer
+      (when m
+	(mm-enable-multibyte))
+      (insert string)
+      (inline
+	(rfc2047-decode-region (point-min) (point-max)))
+      (buffer-string))))
 
 (defun rfc2047-parse-and-decode (word)
   "Decode WORD and return it if it is an encoded word.
@@ -270,12 +336,26 @@ Return WORD if not."
   "Decode STRING that uses CHARSET with ENCODING.
 Valid ENCODINGs are \"B\" and \"Q\".
 If your Emacs implementation can't decode CHARSET, it returns nil."
+  (if (stringp charset)
+    (setq charset (intern (downcase charset))))
+  (if (or (not charset) 
+	  (eq 'gnus-all mail-parse-ignored-charsets)
+	  (memq 'gnus-all mail-parse-ignored-charsets)
+	  (memq charset mail-parse-ignored-charsets))
+      (setq charset mail-parse-charset))
   (let ((cs (mm-charset-to-coding-system charset)))
+    (if (and (not cs) charset 
+	     (listp mail-parse-ignored-charsets)
+	     (memq 'gnus-unknown mail-parse-ignored-charsets))
+      (setq cs (mm-charset-to-coding-system mail-parse-charset)))
     (when cs
+      (when (and (eq cs 'ascii)
+		 mail-parse-charset)
+	(setq cs mail-parse-charset))
       (mm-decode-coding-string
        (cond
 	((equal "B" encoding)
-	 (base64-decode string))
+	 (base64-decode-string string))
 	((equal "Q" encoding)
 	 (quoted-printable-decode-string
 	  (mm-replace-chars-in-string string ?_ ? )))