X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fgnus.git-;a=blobdiff_plain;f=lisp%2Frfc2231.el;h=3728b780cd5cfb49eb9bee39b3341b9100f46f48;hp=8a20e19e8ad5a38fb2279e59fcf4f73b37f4dbea;hb=ab6b58ba032f3baaf4c78e63be9e39e9d8de5e62;hpb=9dd8d144dd2d47bd0ea84e76881ec0f46af778f1

diff --git a/lisp/rfc2231.el b/lisp/rfc2231.el
index 8a20e19..3728b78 100644
--- a/lisp/rfc2231.el
+++ b/lisp/rfc2231.el
@@ -1,7 +1,7 @@
 ;;; rfc2231.el --- Functions for decoding rfc2231 headers
 
-;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004
-;;        Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004, 2005,
+;;   2006 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.
@@ -18,8 +18,8 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 
@@ -41,20 +41,51 @@
 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.  Otherwise, this function
+must never cause a Lisp error."
   (with-temp-buffer
     (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token))
 	  (stoken (ietf-drums-token-to-list ietf-drums-tspecials))
 	  (ntoken (ietf-drums-token-to-list "0-9"))
-	  (prev-value "")
-	  display-name mailbox c display-string parameters
-	  attribute value type subtype number encoded
-	  prev-attribute)
-      (ietf-drums-init (mail-header-remove-whitespace
-			(mail-header-remove-comments string)))
+	  c type attribute encoded number prev-attribute vals
+	  prev-encoded parameters value)
+      (ietf-drums-init
+       (condition-case nil
+	   (mail-header-remove-whitespace
+	    (mail-header-remove-comments string))
+	 ;; The most likely cause of an error is unbalanced parentheses
+	 ;; or double-quotes.  If all parentheses and double-quotes are
+	 ;; quoted meaninglessly with backslashes, removing them might
+	 ;; make it parseable.  Let's try...
+	 (error
+	  (let (mod)
+	    (when (and (string-match "\\\\\"" string)
+		       (not (string-match "\\`\"\\|[^\\]\"" string)))
+	      (setq string (mm-replace-in-string string "\\\\\"" "\"")
+		    mod t))
+	    (when (and (string-match "\\\\(" string)
+		       (string-match "\\\\)" string)
+		       (not (string-match "\\`(\\|[^\\][()]" string)))
+	      (setq string (mm-replace-in-string string "\\\\\\([()]\\)" "\\1")
+		    mod t))
+	    (or (and mod
+		     (ignore-errors
+		       (mail-header-remove-whitespace
+			(mail-header-remove-comments string))))
+		;; Finally, attempt to extract only type.
+		(if (string-match
+		     (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+"
+			     "\\(?:/[^" ietf-drums-tspecials
+			     "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)")
+		     string)
+		    (match-string 1 string)
+		  ""))))))
       (let ((table (copy-syntax-table ietf-drums-syntax-table)))
 	(modify-syntax-entry ?\' "w" table)
 	(modify-syntax-entry ?* " " table)
@@ -66,115 +97,160 @@ The list will be on the form
 	(set-syntax-table table))
       (setq c (char-after))
       (when (and (memq c ttoken)
-		 (not (memq c stoken)))
-	(setq type (downcase (buffer-substring
-			      (point) (progn (forward-sexp 1) (point)))))
+		 (not (memq c stoken))
+		 (setq type (ignore-errors
+			      (downcase
+			       (buffer-substring (point) (progn
+							   (forward-sexp 1)
+							   (point)))))))
 	;; Do the params
-	(while (not (eobp))
-	  (setq c (char-after))
-	  (unless (eq c ?\;)
-	    (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)))))
+	(condition-case err
+	    (progn
+	      (while (not (eobp))
 		(setq c (char-after))
-		(when (eq c ?*)
-		  (setq encoded t)
+		(unless (eq c ?\;)
+		  (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))
+		  (if (eq c ?*)
+		      (progn
+			(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)))))
+		    (setq number nil
+			  encoded nil))
+		  ;; See if we have any previous continuations.
+		  (when (and prev-attribute
+			     (not (eq prev-attribute attribute)))
+		    (setq vals
+			  (mapconcat 'cdr (sort vals 'car-less-than-car) ""))
+		    (push (cons prev-attribute
+				(if prev-encoded
+				    (rfc2231-decode-encoded-string vals)
+				  vals))
+			  parameters)
+		    (setq prev-attribute nil
+			  vals nil
+			  prev-encoded nil))
+		  (unless (eq c ?=)
+		    (error "Invalid header: %s" string))
 		  (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 prev-value) parameters)
-	      (setq prev-attribute nil
-		    prev-value ""))
-	    (unless (eq c ?=)
-	      (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) (point)))))
-	     (t
-	      (error "Invalid header: %s" string)))
-	    (if number
-		(setq prev-attribute attribute
-		      prev-value (concat prev-value value))
-	      (push (cons attribute
-			  (if encoded
-			      (rfc2231-decode-encoded-string value)
-			    value))
-		    parameters))))
-
-	;; Take care of any final continuations.
-	(when prev-attribute
-	  (push (cons prev-attribute
-		      (if encoded
-			  (rfc2231-decode-encoded-string prev-value)
-			prev-value))
-		parameters))
-
-	(when type
-	  `(,type ,@(nreverse parameters)))))))
+		  (setq c (char-after))
+		  (cond
+		   ((eq c ?\")
+		    (setq value (buffer-substring (1+ (point))
+						  (progn
+						    (forward-sexp 1)
+						    (1- (point)))))
+		    (when encoded
+		      (setq value (mapconcat (lambda (c) (format "%%%02x" c))
+					     value ""))))
+		   ((and (or (memq c ttoken)
+			     ;; EXTENSION: Support non-ascii chars.
+			     (> c ?\177))
+			 (not (memq c stoken)))
+		    (setq value
+			  (buffer-substring
+			   (point)
+			   (progn
+			     (forward-sexp)
+			     ;; We might not have reached at the end of
+			     ;; the value because of non-ascii chars,
+			     ;; so we should jump over them if any.
+			     (while (and (not (eobp))
+					 (> (char-after) ?\177))
+			       (forward-char 1)
+			       (forward-sexp))
+			     (point)))))
+		   (t
+		    (error "Invalid header: %s" string)))
+		  (if number
+		      (progn
+			(push (cons number value) vals)
+			(setq prev-attribute attribute
+			      prev-encoded encoded))
+		    (push (cons attribute
+				(if encoded
+				    (rfc2231-decode-encoded-string value)
+				  value))
+			  parameters))))
+
+	      ;; Take care of any final continuations.
+	      (when prev-attribute
+		(setq vals (mapconcat 'cdr (sort vals 'car-less-than-car) ""))
+		(push (cons prev-attribute
+			    (if prev-encoded
+				(rfc2231-decode-encoded-string vals)
+			      vals))
+		      parameters)))
+	  (error
+	   (setq parameters nil)
+	   (if signal-error
+	       (signal (car err) (cdr err))
+	     ;;(message "%s" (error-message-string err))
+	     )))
+
+	(cons type (nreverse parameters))))))
 
 (defun rfc2231-decode-encoded-string (string)
   "Decode an RFC2231-encoded string.
-These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"."
-  (with-temp-buffer
-    (let ((elems (split-string string "'")))
-      ;; The encoded string may contain zero to two single-quote
-      ;; marks.  This should give us the encoded word stripped
-      ;; of any preceding values.
-      (insert (car (last elems)))
+These look like:
+ \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\",
+ \"us-ascii''This%20is%20%2A%2A%2Afun%2A%2A%2A\",
+ \"'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\",
+ \"''This%20is%20%2A%2A%2Afun%2A%2A%2A\", or
+ \"This is ***fun***\"."
+  (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string)
+  (let ((coding-system (mm-charset-to-coding-system (match-string 1 string)))
+	;;(language (match-string 2 string))
+	(value (match-string 3 string)))
+    (mm-with-multibyte-buffer
+      (insert value)
       (goto-char (point-min))
       (while (search-forward "%" nil t)
 	(insert
 	 (prog1
 	     (string-to-number (buffer-substring (point) (+ (point) 2)) 16)
 	   (delete-region (1- (point)) (+ (point) 2)))))
-      ;; Encode using the charset, if any.
-      (when (and (mm-multibyte-p)
-		 (> (length elems) 1)
-		 (not (equal (intern (downcase (car elems))) 'us-ascii)))
-	(mm-decode-coding-region (point-min) (point-max)
-				 (intern (downcase (car elems)))))
+      ;; Decode using the charset, if any.
+      (unless (memq coding-system '(nil ascii))
+	(mm-decode-coding-region (point-min) (point-max) coding-system))
       (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
       (insert value)
@@ -193,28 +269,34 @@ These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"."
       (when charsetp
 	(setq charset (mm-encode-body)))
       (cond
-       ((or encodep charsetp)
+       ((or encodep charsetp
+	    (progn
+	      (end-of-line)
+	      (> (current-column) (if spacep (- limit 2) limit))))
+	(setq limit (- limit 6))
 	(goto-char (point-min))
+	(insert (symbol-name (or charset 'us-ascii)) "''")
 	(while (not (eobp))
-	  (when (> (current-column) 60)
-	    (insert ";\n")
-	    (setq broken t))
 	  (if (or (not (memq (following-char) ascii))
 		  (memq (following-char) control)
 		  (memq (following-char) tspecial)
 		  (memq (following-char) special)
 		  (eq (following-char) ? ))
 	      (progn
+		(when (>= (current-column) (1- limit))
+		  (insert ";\n")
+		  (setq broken t))
 		(insert "%" (format "%02x" (following-char)))
 		(delete-char 1))
+	    (when (> (current-column) limit)
+	      (insert ";\n")
+	      (setq broken t))
 	    (forward-char 1)))
 	(goto-char (point-min))
-	(insert (symbol-name (or charset 'us-ascii)) "''")
-	(goto-char (point-min))
 	(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