Revision: emacs@sv.gnu.org/emacs--devo--0--patch-57

Merge from gnus--rel--5.10

Patches applied:

 * gnus--rel--5.10  (patch 18-21)

   - Update from CVS
   - Merge from emacs--devo--0

lisp/gnus/ChangeLog

@@ -1,3 +1,47 @@
+2006-02-07  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+	* gnus-art.el (article-decode-charset): Don't use ignore-errors
+	when calling mail-header-parse-content-type.
+	(article-de-quoted-unreadable): Ditto.
+	(article-de-base64-unreadable): Ditto.
+	(article-wash-html): Ditto.
+
+	* mm-decode.el (mm-dissect-buffer): Don't use ignore-errors when
+	calling mail-header-parse-content-type and
+	mail-header-parse-content-disposition.
+	(mm-find-raw-part-by-type): Don't use ignore-errors when calling
+	mail-header-parse-content-type.
+
+	* mml.el (mml-insert-mime-headers): Use mml-insert-parameter to
+	insert charset and format parameters; encode description after
+	inserting it to buffer.
+	(mml-insert-parameter): Fold lines properly even if a parameter is
+	segmented into two or more lines; change the max column to 76.
+
+	* rfc1843.el (rfc1843-decode-article-body): Don't use
+	ignore-errors when calling mail-header-parse-content-type.
+
+	* rfc2231.el (rfc2231-parse-string): Return at least type if
+	possible; don't cause an error even if it fails in parsing of
+	parameters.  Suggested by ARISAWA Akihiro <ari@mbf.ocn.ne.jp>.
+	(rfc2231-encode-string): Don't break lines at the beginning, leave
+	it to mml-insert-parameter.
+
+	* webmail.el (webmail-yahoo-article): Don't use ignore-errors when
+	calling mail-header-parse-content-type.
+
+2006-02-06  Reiner Steib  <Reiner.Steib@gmx.de>
+
+	* spam-report.el (spam-report-gmane-use-article-number): Improve
+	doc string.
+	(spam-report-gmane-internal): Check if a suitable header was found
+	in the article.
+
+2006-02-04  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+	* rfc2231.el (rfc2231-parse-string): Revert 2006-02-03 change.
+	(rfc2231-encode-string): Make param*=value always begin with LWSP.
+
 2006-02-05  Romain Francoise  <romain@orebokech.com>
 
 	Update copyright notices of all files in the gnus directory.

lisp/gnus/gnus-art.el

@@ -2267,38 +2267,37 @@ If PROMPT (the prefix), prompt for a coding system to use."
 			   (error))
 			 gnus-newsgroup-ignored-charsets))
 	ct cte ctl charset format)
-  (save-excursion
+    (save-excursion
-    (save-restriction
+      (save-restriction
-      (article-narrow-to-head)
+	(article-narrow-to-head)
-      (setq ct (message-fetch-field "Content-Type" t)
+	(setq ct (message-fetch-field "Content-Type" t)
-	    cte (message-fetch-field "Content-Transfer-Encoding" t)
+	      cte (message-fetch-field "Content-Transfer-Encoding" t)
-	    ctl (and ct (ignore-errors
+	      ctl (and ct (mail-header-parse-content-type ct))
-			  (mail-header-parse-content-type ct)))
+	      charset (cond
-	    charset (cond
+		       (prompt
-		     (prompt
+			(mm-read-coding-system "Charset to decode: "))
-		      (mm-read-coding-system "Charset to decode: "))
+		       (ctl
-		     (ctl
+			(mail-content-type-get ctl 'charset)))
-		      (mail-content-type-get ctl 'charset)))
+	      format (and ctl (mail-content-type-get ctl 'format)))
-	    format (and ctl (mail-content-type-get ctl 'format)))
+	(when cte
-      (when cte
+	  (setq cte (mail-header-strip cte)))
-	(setq cte (mail-header-strip cte)))
+	(if (and ctl (not (string-match "/" (car ctl))))
-      (if (and ctl (not (string-match "/" (car ctl))))
+	    (setq ctl nil))
-	  (setq ctl nil))
+	(goto-char (point-max)))
-      (goto-char (point-max)))
+      (forward-line 1)
-    (forward-line 1)
+      (save-restriction
-    (save-restriction
+	(narrow-to-region (point) (point-max))
-      (narrow-to-region (point) (point-max))
+	(when (and (eq mail-parse-charset 'gnus-decoded)
-      (when (and (eq mail-parse-charset 'gnus-decoded)
+		   (eq (mm-body-7-or-8) '8bit))
-		 (eq (mm-body-7-or-8) '8bit))
+	  ;; The text code could have been decoded.
-	;; The text code could have been decoded.
+	  (setq charset mail-parse-charset))
-	(setq charset mail-parse-charset))
+	(when (and (or (not ctl)
-      (when (and (or (not ctl)
+		       (equal (car ctl) "text/plain"))
-		     (equal (car ctl) "text/plain"))
+		   (not format)) ;; article with format will decode later.
-		 (not format)) ;; article with format will decode later.
+	  (mm-decode-body
-	(mm-decode-body
+	   charset (and cte (intern (downcase
-	 charset (and cte (intern (downcase
+				     (gnus-strip-whitespace cte))))
-				   (gnus-strip-whitespace cte))))
+	   (car ctl)))))))
-	 (car ctl)))))))
 
 (defun article-decode-encoded-words ()
   "Remove encoded-word encoding from headers."
@@ -2390,9 +2389,7 @@ If READ-CHARSET, ask for a coding system."
 	    (setq type
 		  (gnus-fetch-field "content-transfer-encoding"))
 	    (let* ((ct (gnus-fetch-field "content-type"))
-		   (ctl (and ct
+		   (ctl (and ct (mail-header-parse-content-type ct))))
-			     (ignore-errors
-			       (mail-header-parse-content-type ct)))))
 	      (setq charset (and ctl
 				 (mail-content-type-get ctl 'charset)))
 	      (if (stringp charset)
@@ -2420,9 +2417,7 @@ If READ-CHARSET, ask for a coding system."
 	    (setq type
 		  (gnus-fetch-field "content-transfer-encoding"))
 	    (let* ((ct (gnus-fetch-field "content-type"))
-		   (ctl (and ct
+		   (ctl (and ct (mail-header-parse-content-type ct))))
-			     (ignore-errors
-			       (mail-header-parse-content-type ct)))))
 	      (setq charset (and ctl
 				 (mail-content-type-get ctl 'charset)))
 	      (if (stringp charset)
@@ -2488,9 +2483,7 @@ charset defined in `gnus-summary-show-article-charset-alist' is used."
 	(when (gnus-buffer-live-p gnus-original-article-buffer)
 	  (with-current-buffer gnus-original-article-buffer
 	    (let* ((ct (gnus-fetch-field "content-type"))
-		   (ctl (and ct
+		   (ctl (and ct (mail-header-parse-content-type ct))))
-			     (ignore-errors
-			       (mail-header-parse-content-type ct)))))
 	      (setq charset (and ctl
 				 (mail-content-type-get ctl 'charset)))
 	      (when (stringp charset)

lisp/gnus/mm-decode.el

@@ -534,13 +534,13 @@ Postpone undisplaying of viewers for types in
 		  loose-mime
 		  (mail-fetch-field "mime-version"))
 	  (setq ct (mail-fetch-field "content-type")
-		ctl (ignore-errors (mail-header-parse-content-type ct))
+		ctl (and ct (mail-header-parse-content-type ct))
 		cte (mail-fetch-field "content-transfer-encoding")
 		cd (mail-fetch-field "content-disposition")
 		description (mail-fetch-field "content-description")
 		id (mail-fetch-field "content-id"))
 	  (unless from
-		(setq from (mail-fetch-field "from")))
+	    (setq from (mail-fetch-field "from")))
 	  ;; FIXME: In some circumstances, this code is running within
 	  ;; an unibyte macro.  mail-extract-address-components
 	  ;; creates unibyte buffers. This `if', though not a perfect
@@ -557,7 +557,7 @@ Postpone undisplaying of viewers for types in
 				       (mail-header-remove-comments
 					cte)))))
 	   no-strict-mime
-	   (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
+	   (and cd (mail-header-parse-content-disposition cd))
 	   description)
 	(setq type (split-string (car ctl) "/"))
 	(setq subtype (cadr type)
@@ -592,8 +592,7 @@ Postpone undisplaying of viewers for types in
 					 (mail-header-remove-comments
 					  cte)))))
 	     no-strict-mime
-	     (and cd (ignore-errors
+	     (and cd (mail-header-parse-content-disposition cd))
-		       (mail-header-parse-content-disposition cd)))
 	     description id)
 	    ctl))))
 	(when id
@@ -1401,9 +1400,8 @@ If RECURSIVE, search recursively."
 	(save-excursion
 	  (save-restriction
 	    (narrow-to-region start (1- (point)))
-	    (when (let ((ctl (ignore-errors
+	    (when (let* ((ct (mail-fetch-field "content-type"))
-			       (mail-header-parse-content-type
+			 (ctl (and ct (mail-header-parse-content-type ct))))
-				(mail-fetch-field "content-type")))))
 		    (if notp
 			(not (equal (car ctl) type))
 		      (equal (car ctl) type)))
@@ -1414,9 +1412,8 @@ If RECURSIVE, search recursively."
       (save-excursion
 	(save-restriction
 	  (narrow-to-region start end)
-	  (when (let ((ctl (ignore-errors
+	  (when (let* ((ct (mail-fetch-field "content-type"))
-			     (mail-header-parse-content-type
+		       (ctl (and ct (mail-header-parse-content-type ct))))
-			      (mail-fetch-field "content-type")))))
 		  (if notp
 		      (not (equal (car ctl) type))
 		    (equal (car ctl) type)))

lisp/gnus/mml.el

@@ -664,10 +664,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
 	 "Can't encode a part with several charsets"))
       (insert "Content-Type: " type)
       (when charset
-	(insert "; " (mail-header-encode-parameter
+	(mml-insert-parameter
-		      "charset" (symbol-name charset))))
+	 (mail-header-encode-parameter "charset" (symbol-name charset))))
       (when flowed
-	(insert "; format=flowed"))
+	(mml-insert-parameter "format=flowed"))
       (when parameters
 	(mml-insert-parameter-string
 	 cont mml-content-type-parameters))
@@ -687,8 +687,11 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
     (unless (eq encoding '7bit)
       (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
     (when (setq description (cdr (assq 'description cont)))
-      (insert "Content-Description: "
+      (insert "Content-Description: ")
-	      (mail-encode-encoded-word-string description) "\n"))))
+      (setq description (prog1
+			    (point)
+			  (insert description "\n")))
+      (mail-encode-encoded-word-region description (point)))))
 
 (defun mml-parameter-string (cont types)
   (let ((string "")
@@ -841,14 +844,20 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
 
 (defun mml-insert-parameter (&rest parameters)
   "Insert PARAMETERS in a nice way."
-  (dolist (param parameters)
+  (let (start end)
-    (insert ";")
+    (dolist (param parameters)
-    (let ((point (point)))
+      (insert ";")
+      (setq start (point))
       (insert " " param)
-      (when (> (current-column) 71)
+      (setq end (point))
-	(goto-char point)
+      (goto-char start)
-	(insert "\n ")
+      (end-of-line)
-	(end-of-line)))))
+      (if (> (current-column) 76)
+	  (progn
+	    (goto-char start)
+	    (insert "\n")
+	    (goto-char (1+ end)))
+	(goto-char end)))))
 
 ;;;
 ;;; Mode for inserting and editing MML forms

lisp/gnus/rfc1843.el

@@ -149,8 +149,7 @@ ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc"
 	  (let* ((inhibit-point-motion-hooks t)
 		 (case-fold-search t)
 		 (ct (message-fetch-field "Content-Type" t))
-		 (ctl (and ct (ignore-errors
+		 (ctl (and ct (mail-header-parse-content-type ct))))
-				(mail-header-parse-content-type ct)))))
 	    (if (and ctl (not (string-match "/" (car ctl))))
 		(setq ctl nil))
 	    (goto-char (point-max))

lisp/gnus/rfc2231.el

@@ -41,10 +41,13 @@
 N.B.  This is in violation with RFC2047, but it seem to be in common use."
   (rfc2231-parse-string (rfc2047-decode-string string)))
 
-(defun rfc2231-parse-string (string)
+(defun rfc2231-parse-string (string &optional signal-error)
   "Parse STRING and return a list.
 The list will be on the form
- `(name (attribute . value) (attribute . value)...)"
+ `(name (attribute . value) (attribute . value)...)'.
+
+If the optional SIGNAL-ERROR is non-nil, signal an error when this
+function fails in parsing of parameters."
   (with-temp-buffer
     (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token))
 	  (stoken (ietf-drums-token-to-list ietf-drums-tspecials))
@@ -74,63 +77,68 @@ The list will be on the form
 	(setq type (downcase (buffer-substring
 			      (point) (progn (forward-sexp 1) (point)))))
 	;; Do the params
-	(while (not (eobp))
+	(condition-case err
-	  (setq c (char-after))
+	    (progn
-	  (unless (eq c ?\;)
+	      (while (not (eobp))
-	    (error "Invalid header: %s" string))
-	  (forward-char 1)
-	  ;; If c in nil, then this is an invalid header, but
-	  ;; since elm generates invalid headers on this form,
-	  ;; we allow it.
-	  (when (setq c (char-after))
-	    (if (and (memq c ttoken)
-		     (not (memq c stoken)))
-		(setq attribute
-		      (intern
-		       (downcase
-			(buffer-substring
-			 (point) (progn (forward-sexp 1) (point))))))
-	      (error "Invalid header: %s" string))
-	    (setq c (char-after))
-	    (when (eq c ?*)
-	      (forward-char 1)
-	      (setq c (char-after))
-	      (if (not (memq c ntoken))
-		  (setq encoded t
-			number nil)
-		(setq number
-		      (string-to-number
-		       (buffer-substring
-			(point) (progn (forward-sexp 1) (point)))))
 		(setq c (char-after))
-		(when (eq c ?*)
+		(unless (eq c ?\;)
-		  (setq encoded t)
+		  (error "Invalid header: %s" string))
+		(forward-char 1)
+		;; If c in nil, then this is an invalid header, but
+		;; since elm generates invalid headers on this form,
+		;; we allow it.
+		(when (setq c (char-after))
+		  (if (and (memq c ttoken)
+			   (not (memq c stoken)))
+		      (setq attribute
+			    (intern
+			     (downcase
+			      (buffer-substring
+			       (point) (progn (forward-sexp 1) (point))))))
+		    (error "Invalid header: %s" string))
+		  (setq c (char-after))
+		  (when (eq c ?*)
+		    (forward-char 1)
+		    (setq c (char-after))
+		    (if (not (memq c ntoken))
+			(setq encoded t
+			      number nil)
+		      (setq number
+			    (string-to-number
+			     (buffer-substring
+			      (point) (progn (forward-sexp 1) (point)))))
+		      (setq c (char-after))
+		      (when (eq c ?*)
+			(setq encoded t)
+			(forward-char 1)
+			(setq c (char-after)))))
+		  ;; See if we have any previous continuations.
+		  (when (and prev-attribute
+			     (not (eq prev-attribute attribute)))
+		    (push (cons prev-attribute
+				(if prev-encoded
+				    (rfc2231-decode-encoded-string prev-value)
+				  prev-value))
+			  parameters)
+		    (setq prev-attribute nil
+			  prev-value ""
+			  prev-encoded nil))
+		  (unless (eq c ?=)
+		    (error "Invalid header: %s" string))
 		  (forward-char 1)
-		  (setq c (char-after)))))
+		  (setq c (char-after))
-	    ;; See if we have any previous continuations.
+		  (cond
-	    (when (and prev-attribute
+		   ((eq c ?\")
-		       (not (eq prev-attribute attribute)))
+		    (setq value (buffer-substring (1+ (point))
-	      (push (cons prev-attribute
+						  (progn
-			  (if prev-encoded
+						    (forward-sexp 1)
-			      (rfc2231-decode-encoded-string prev-value)
+						    (1- (point))))))
-			    prev-value))
+		   ((and (or (memq c ttoken)
-		    parameters)
+			     ;; EXTENSION: Support non-ascii chars.
-	      (setq prev-attribute nil
+			     (> c ?\177))
-		    prev-value ""
+			 (not (memq c stoken)))
-		    prev-encoded nil))
+		    (setq value
-	    (unless (eq c ?=)
+			  (buffer-substring
-	      (error "Invalid header: %s" string))
-	    (forward-char 1)
-	    (setq c (char-after))
-	    (cond
-	     ((eq c ?\")
-	      (setq value
-		    (buffer-substring (1+ (point))
-				      (progn (forward-sexp 1) (1- (point))))))
-	     ((and (or (memq c ttoken)
-		       (> c ?\177)) ;; EXTENSION: Support non-ascii chars.
-		   (not (memq c stoken)))
-	      (setq value (buffer-substring
 			   (point)
 			   (progn
 			     (forward-sexp)
@@ -142,25 +150,31 @@ The list will be on the form
 			       (forward-char 1)
 			       (forward-sexp))
 			     (point)))))
-	     (t
+		   (t
-	      (error "Invalid header: %s" string)))
+		    (error "Invalid header: %s" string)))
-	    (if number
+		  (if number
-		(setq prev-attribute attribute
+		      (setq prev-attribute attribute
-		      prev-value (concat prev-value value)
+			    prev-value (concat prev-value value)
-		      prev-encoded encoded)
+			    prev-encoded encoded)
-	      (push (cons attribute
+		    (push (cons attribute
-			  (if encoded
+				(if encoded
-			      (rfc2231-decode-encoded-string value)
+				    (rfc2231-decode-encoded-string value)
-			    value))
+				  value))
-		    parameters))))
+			  parameters))))
 
-	;; Take care of any final continuations.
+	      ;; Take care of any final continuations.
-	(when prev-attribute
+	      (when prev-attribute
-	  (push (cons prev-attribute
+		(push (cons prev-attribute
-		      (if prev-encoded
+			    (if prev-encoded
-			  (rfc2231-decode-encoded-string prev-value)
+				(rfc2231-decode-encoded-string prev-value)
-			prev-value))
+			      prev-value))
-		parameters))
+		      parameters)))
+	  (error
+	   (setq parameters nil)
+	   (if signal-error
+	       (signal (car err) (cdr err))
+	     ;;(message "%s" (error-message-string err))
+	     )))
 
 	(when type
 	  `(,type ,@(nreverse parameters)))))))
@@ -189,12 +203,15 @@ These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"."
       (buffer-string))))
 
 (defun rfc2231-encode-string (param value)
-  "Return and PARAM=VALUE string encoded according to RFC2231."
+  "Return and PARAM=VALUE string encoded according to RFC2231.
+Use `mml-insert-parameter' or `mml-insert-parameter-string' to insert
+the result of this function."
   (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token))
 	(tspecial (ietf-drums-token-to-list ietf-drums-tspecials))
 	(special (ietf-drums-token-to-list "*'%\n\t"))
 	(ascii (ietf-drums-token-to-list ietf-drums-text-token))
 	(num -1)
+	;; Don't make lines exceeding 76 column.
 	(limit (- 74 (length param)))
 	spacep encodep charsetp charset broken)
     (with-temp-buffer
@@ -241,7 +258,7 @@ These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"."
 	(if (not broken)
 	    (insert param "*=")
 	  (while (not (eobp))
-	    (insert (if (>= num 0) " " "\n ")
+	    (insert (if (>= num 0) " " "")
 		    param "*" (format "%d" (incf num)) "*=")
 	    (forward-line 1))))
        (spacep

lisp/gnus/spam-report.el

@@ -50,7 +50,11 @@ instead."
   :group 'spam-report)
 
 (defcustom spam-report-gmane-use-article-number t
-  "Whether the article number (faster!) or the header should be used."
+  "Whether the article number (faster!) or the header should be used.
+
+You must set this to nil if you don't read Gmane groups directly
+from news.gmane.org, e.g. when using local newsserver such as
+leafnode."
   :type 'boolean
   :group 'spam-report)
 

lisp/gnus/webmail.el

@@ -637,7 +637,7 @@
 	  (goto-char (point-min))
 	  (delete-blank-lines)
 	  (setq ct (mail-fetch-field "content-type")
-		ctl (ignore-errors (mail-header-parse-content-type ct))
+		ctl (and ct (mail-header-parse-content-type ct))
 		;;cte (mail-fetch-field "content-transfer-encoding")
 		cd (mail-fetch-field "content-disposition")
 		description (mail-fetch-field "content-description")