`(name (attribute . value) (attribute . value)...)'.
If the optional SIGNAL-ERROR is non-nil, signal an error when this
-function fails in parsing of parameters."
+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 prev-encoded)
- ;; Some mailer (e.g. Thunderbird 1.5) doesn't terminate each
- ;; line with semicolon when folding a long parameter value.
- (while (string-match "\\([^\t\n\r ;]\\)[\t ]*\r?\n[\t ]+" string)
- (setq string (replace-match "\\1;\n " nil nil string)))
- (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)
(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
(condition-case err
(progn
(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)
+ (if (eq c ?*)
+ (progn
(forward-char 1)
- (setq c (char-after)))))
+ (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 prev-value)
- prev-value))
+ (rfc2231-decode-encoded-string vals)
+ vals))
parameters)
(setq prev-attribute nil
- prev-value ""
+ vals nil
prev-encoded nil))
(unless (eq c ?=)
(error "Invalid header: %s" string))
(setq value (buffer-substring (1+ (point))
(progn
(forward-sexp 1)
- (1- (point))))))
+ (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))
(t
(error "Invalid header: %s" string)))
(if number
- (setq prev-attribute attribute
- prev-value (concat prev-value value)
- prev-encoded encoded)
+ (progn
+ (push (cons number value) vals)
+ (setq prev-attribute attribute
+ prev-encoded encoded))
(push (cons attribute
(if encoded
(rfc2231-decode-encoded-string value)
;; 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 prev-value)
- prev-value))
+ (rfc2231-decode-encoded-string vals)
+ vals))
parameters)))
(error
(setq parameters nil)
;;(message "%s" (error-message-string err))
)))
- (when type
- `(,type ,@(nreverse parameters)))))))
+ (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)
(forward-line 1))))
(spacep
(goto-char (point-min))
- (insert "\n " param "=\"")
+ (insert param "=\"")
(goto-char (point-max))
(insert "\""))
(t
(goto-char (point-min))
- (insert "\n " param "=")))
+ (insert param "=")))
(buffer-string))))
(provide 'rfc2231)
projects / gnus / blobdiff