Mercurial > emacs

--- a/lisp/gnus/ChangeLog	Fri Sep 01 20:49:06 2006 +0000
+++ b/lisp/gnus/ChangeLog	Fri Sep 01 23:52:28 2006 +0000
@@ -1,3 +1,33 @@
+2006-09-01  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+	* rfc2047.el (rfc2047-quote-special-characters-in-quoted-strings):
+	Use standard-syntax-table.
+
+2006-09-01  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+	* gnus-art.el (gnus-decode-address-function): New variable.
+	(article-decode-encoded-words): Use it to decode headers which are
+	assumed to contain addresses.
+	(gnus-mime-delete-part): Remove useless `or'.
+
+	* gnus-sum.el (gnus-decode-encoded-address-function): New variable.
+	(gnus-summary-from-or-to-or-newsgroups): Use it to decode To header.
+	(gnus-nov-parse-line): Use it to decode From header.
+	(gnus-get-newsgroup-headers): Ditto.
+	(gnus-summary-enter-digest-group): Use it to decode `to-address'.
+
+	* mail-parse.el (mail-decode-encoded-address-region): New alias.
+	(mail-decode-encoded-address-string): New alias.
+
+	* rfc2047.el (rfc2047-quote-special-characters-in-quoted-strings):
+	New function.
+	(rfc2047-encode-message-header, rfc2047-encode-region): Use it.
+	(rfc2047-strip-backslashes-in-quoted-strings): New fnction.
+	(rfc2047-decode-region): Use it; add optional argument `address-mime'.
+	(rfc2047-decode-string): Ditto.
+	(rfc2047-decode-address-region): New function.
+	(rfc2047-decode-address-string): New function.
+
 2006-08-23  Andreas Seltenreich  <uwi7@rz.uni-karlsruhe.de>

 	[ Backported bug fix from No Gnus. ]
--- a/lisp/gnus/gnus-art.el	Fri Sep 01 20:49:06 2006 +0000
+++ b/lisp/gnus/gnus-art.el	Fri Sep 01 23:52:28 2006 +0000
@@ -853,6 +853,9 @@
 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region
   "Function used to decode headers.")

+(defvar gnus-decode-address-function 'mail-decode-encoded-address-region
+  "Function used to decode addresses.")
+
 (defvar gnus-article-dumbquotes-map
   '(("\200" "EUR")
     ("\202" ",")
@@ -2377,10 +2380,23 @@
 			     (set-buffer gnus-summary-buffer)
 			   (error))
 			 gnus-newsgroup-ignored-charsets))
-	(inhibit-read-only t))
+	(inhibit-read-only t)
+	start)
     (save-restriction
       (article-narrow-to-head)
-      (funcall gnus-decode-header-function (point-min) (point-max)))))
+      (while (not (eobp))
+	(setq start (point))
+	(if (prog1
+		(looking-at "\
+\\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\
+\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):")
+	      (while (progn
+		       (forward-line)
+		       (if (eobp)
+			   nil
+			 (memq (char-after) '(?\t ? ))))))
+	    (funcall gnus-decode-address-function start (point))
+	  (funcall gnus-decode-header-function start (point)))))))

 (defun article-decode-group-name ()
   "Decode group names in `Newsgroups:'."
@@ -4324,9 +4340,8 @@
 	   (handles gnus-article-mime-handles)
 	   (none "(none)")
 	   (description
-	    (or
-	     (mail-decode-encoded-word-string (or (mm-handle-description data)
-						  none))))
+	    (mail-decode-encoded-word-string (or (mm-handle-description data)
+						 none)))
 	   (filename
 	    (or (mail-content-type-get (mm-handle-disposition data) 'filename)
 		none))
--- a/lisp/gnus/gnus-sum.el	Fri Sep 01 20:49:06 2006 +0000
+++ b/lisp/gnus/gnus-sum.el	Fri Sep 01 23:52:28 2006 +0000
@@ -992,7 +992,11 @@
   :group 'gnus-summary)

 (defvar gnus-decode-encoded-word-function 'mail-decode-encoded-word-string
-  "Variable that says which function should be used to decode a string with encoded words.")
+  "Function used to decode a string with encoded words.")
+
+(defvar gnus-decode-encoded-address-function
+  'mail-decode-encoded-address-string
+  "Function used to decode addresses with encoded words.")

 (defcustom gnus-extra-headers '(To Newsgroups)
   "*Extra headers to parse."
@@ -1001,7 +1005,7 @@
   :type '(repeat symbol))

 (defcustom gnus-ignored-from-addresses
-  (and user-mail-address
+  (and user-mail-address
        (not (string= user-mail-address ""))
        (regexp-quote user-mail-address))
   "*Regexp of From headers that may be suppressed in favor of To headers."
@@ -3436,7 +3440,7 @@
 	      (concat "-> "
 		      (inline
 			(gnus-summary-extract-address-component
-			 (funcall gnus-decode-encoded-word-function to)))))
+			 (funcall gnus-decode-encoded-address-function to)))))
 	     ((setq newsgroups (cdr (assq 'Newsgroups extra-headers)))
 	      (concat "=> " newsgroups)))))
      (inline (gnus-summary-extract-address-component gnus-tmp-from)))))
@@ -4182,7 +4186,7 @@
 		   (error x))
 		 (condition-case ()	; from
 		     (gnus-remove-odd-characters
-		      (funcall gnus-decode-encoded-word-function
+		      (funcall gnus-decode-encoded-address-function
 			       (setq x (nnheader-nov-field))))
 		   (error x))
 		 (nnheader-nov-field)	; date
@@ -5956,7 +5960,7 @@
 	    (progn
 	      (goto-char p)
 	      (if (search-forward "\nfrom:" nil t)
-		  (funcall gnus-decode-encoded-word-function
+		  (funcall gnus-decode-encoded-address-function
 			   (nnheader-header-value))
 		"(nobody)"))
 	    ;; Date.
@@ -8449,10 +8453,11 @@
 	;; the parent article.
 	(when (setq to-address (or (gnus-fetch-field "reply-to")
 				   (gnus-fetch-field "from")))
-	  (setq params (append
-			(list (cons 'to-address
-				    (funcall gnus-decode-encoded-word-function
-					     to-address))))))
+	  (setq params
+		(append
+		 (list (cons 'to-address
+			     (funcall gnus-decode-encoded-address-function
+				      to-address))))))
 	(setq dig (nnheader-set-temp-buffer " *gnus digest buffer*"))
 	(insert-buffer-substring gnus-original-article-buffer)
 	;; Remove lines that may lead nndoc to misinterpret the
--- a/lisp/gnus/mail-parse.el	Fri Sep 01 20:49:06 2006 +0000
+++ b/lisp/gnus/mail-parse.el	Fri Sep 01 23:52:28 2006 +0000
@@ -70,6 +70,8 @@
 (defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string)
 (defalias 'mail-decode-encoded-word-region 'rfc2047-decode-region)
 (defalias 'mail-decode-encoded-word-string 'rfc2047-decode-string)
+(defalias 'mail-decode-encoded-address-region 'rfc2047-decode-address-region)
+(defalias 'mail-decode-encoded-address-string 'rfc2047-decode-address-string)

 (provide 'mail-parse)
--- a/lisp/gnus/rfc2047.el	Fri Sep 01 20:49:06 2006 +0000
+++ b/lisp/gnus/rfc2047.el	Fri Sep 01 23:52:28 2006 +0000
@@ -171,6 +171,40 @@
       (re-search-forward ":[ \t\n]*" nil t)
       (buffer-substring-no-properties (point) (point-max)))))

+(defun rfc2047-quote-special-characters-in-quoted-strings (&optional
+							   encodable-regexp)
+  "Quote special characters with `\\'s in quoted strings.
+Quoting will not be done in a quoted string if it contains characters
+matching ENCODABLE-REGEXP."
+  (goto-char (point-min))
+  (let ((tspecials (concat "[" ietf-drums-tspecials "]"))
+	beg)
+    (with-syntax-table (standard-syntax-table)
+      (while (search-forward "\"" nil t)
+	(unless (eq (char-before) ?\\)
+	  (setq beg (match-end 0))
+	  (goto-char (match-beginning 0))
+	  (condition-case nil
+	      (progn
+		(forward-sexp)
+		(save-restriction
+		  (narrow-to-region beg (1- (point)))
+		  (goto-char beg)
+		  (unless (and encodable-regexp
+			       (re-search-forward encodable-regexp nil t))
+		    (while (re-search-forward tspecials nil 'move)
+		      (unless (and (eq (char-before) ?\\) ;; Already quoted.
+				   (looking-at tspecials))
+			(goto-char (match-beginning 0))
+			(unless (or (eq (char-before) ?\\)
+				    (and rfc2047-encode-encoded-words
+					 (eq (char-after) ??)
+					 (eq (char-before) ?=)))
+			  (insert "\\")))
+		      (forward-char)))))
+	    (error
+	     (goto-char beg))))))))
+
 (defvar rfc2047-encoding-type 'address-mime
   "The type of encoding done by `rfc2047-encode-region'.
 This should be dynamically bound around calls to
@@ -187,8 +221,18 @@
       (while (not (eobp))
 	(save-restriction
 	  (rfc2047-narrow-to-field)
+	  (setq method nil
+		alist rfc2047-header-encoding-alist)
+	  (while (setq elem (pop alist))
+	    (when (or (and (stringp (car elem))
+			   (looking-at (car elem)))
+		      (eq (car elem) t))
+	      (setq alist nil
+		    method (cdr elem))))
 	  (if (not (rfc2047-encodable-p))
-	      (prog1
+	      (prog2
+		  (when (eq method 'address-mime)
+		    (rfc2047-quote-special-characters-in-quoted-strings))
 		  (if (and (eq (mm-body-7-or-8) '8bit)
 			   (mm-multibyte-p)
 			   (mm-coding-system-p
@@ -209,14 +253,6 @@
 		     (point))
 		   (point-max))))
 	    ;; We found something that may perhaps be encoded.
-	    (setq method nil
-		  alist rfc2047-header-encoding-alist)
-	    (while (setq elem (pop alist))
-	      (when (or (and (stringp (car elem))
-			     (looking-at (car elem)))
-			(eq (car elem) t))
-		(setq alist nil
-		      method (cdr elem))))
 	    (re-search-forward "^[^:]+: *" nil t)
 	    (cond
 	     ((eq method 'address-mime)
@@ -347,6 +383,7 @@
 		  (rfc2047-encode start (point))
 		(goto-char end))))
 	;; `address-mime' case -- take care of quoted words, comments.
+	(rfc2047-quote-special-characters-in-quoted-strings encodable-regexp)
 	(with-syntax-table rfc2047-syntax-table
 	  (goto-char (point-min))
 	  (condition-case err		; in case of unbalanced quotes
@@ -821,6 +858,29 @@
 the decoder will fully decode each encoded-word before concatenating
 them.")

+(defun rfc2047-strip-backslashes-in-quoted-strings ()
+  "Strip backslashes in quoted strings.  `\\\"' and `\\\\' remain."
+  (goto-char (point-min))
+  (let (beg)
+    (with-syntax-table (standard-syntax-table)
+      (while (search-forward "\"" nil t)
+	(unless (eq (char-before) ?\\)
+	  (setq beg (match-end 0))
+	  (goto-char (match-beginning 0))
+	  (condition-case nil
+	      (progn
+		(forward-sexp)
+		(save-restriction
+		  (narrow-to-region beg (1- (point)))
+		  (goto-char beg)
+		  (while (search-forward "\\" nil 'move)
+		    (unless (memq (char-after) '(?\" ?\\))
+		      (delete-backward-char 1))
+		    (forward-char)))
+		(forward-char))
+	    (error
+	     (goto-char beg))))))))
+
 (defun rfc2047-charset-to-coding-system (charset)
   "Return coding-system corresponding to MIME CHARSET.
 If your Emacs implementation can't decode CHARSET, return nil."
@@ -898,8 +958,10 @@
 ;; and worthwhile (is it more correct or not?), e.g. something like
 ;; `=?iso-8859-1?q?foo?=@'.

-(defun rfc2047-decode-region (start end)
-  "Decode MIME-encoded words in region between START and END."
+(defun rfc2047-decode-region (start end &optional address-mime)
+  "Decode MIME-encoded words in region between START and END.
+If ADDRESS-MIME is non-nil, strip backslashes which precede characters
+other than `\"' and `\\' in quoted strings."
   (interactive "r")
   (let ((case-fold-search t)
 	(eword-regexp (eval-when-compile
@@ -910,6 +972,8 @@
     (save-excursion
       (save-restriction
 	(narrow-to-region start end)
+	(when address-mime
+	  (rfc2047-strip-backslashes-in-quoted-strings))
 	(goto-char (setq b start))
 	;; Look for the encoded-words.
 	(while (setq match (re-search-forward eword-regexp nil t))
@@ -995,8 +1059,16 @@
 		   (not (eq mail-parse-charset 'gnus-decoded)))
 	  (mm-decode-coding-region b (point-max) mail-parse-charset))))))

-(defun rfc2047-decode-string (string)
-  "Decode the quoted-printable-encoded STRING and return the results."
+(defun rfc2047-decode-address-region (start end)
+  "Decode MIME-encoded words in region between START and END.
+Backslashes which precede characters other than `\"' and `\\' in quoted
+strings are stripped."
+  (rfc2047-decode-region start end t))
+
+(defun rfc2047-decode-string (string &optional address-mime)
+  "Decode MIME-encoded STRING and return the result.
+If ADDRESS-MIME is non-nil, strip backslashes which precede characters
+other than `\"' and `\\' in quoted strings."
   (let ((m (mm-multibyte-p)))
     (if (string-match "=\\?" string)
 	(with-temp-buffer
@@ -1010,8 +1082,16 @@
 	    (mm-enable-multibyte))
 	  (insert string)
 	  (inline
-	    (rfc2047-decode-region (point-min) (point-max)))
+	    (rfc2047-decode-region (point-min) (point-max) address-mime))
 	  (buffer-string))
+      (when address-mime
+	(setq string
+	      (with-temp-buffer
+		(when (mm-multibyte-string-p string)
+		  (mm-enable-multibyte))
+		(insert string)
+		(rfc2047-strip-backslashes-in-quoted-strings)
+		(buffer-string))))
       ;; Fixme: As above, `m' here is inappropriate.
       (if (and m
 	       mail-parse-charset
@@ -1033,6 +1113,12 @@
 	    (mm-decode-coding-string string mail-parse-charset))
 	(mm-string-as-multibyte string)))))

+(defun rfc2047-decode-address-string (string)
+  "Decode MIME-encoded STRING and return the result.
+Backslashes which precede characters other than `\"' and `\\' in quoted
+strings are stripped."
+  (rfc2047-decode-string string t))
+
 (defun rfc2047-pad-base64 (string)
   "Pad STRING to quartets."
   ;; Be more liberal to accept buggy base64 strings. If