;;; rfc2231.el --- Functions for decoding rfc2231 headers
-;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004, 2005,
-;; 2006 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2013 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
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 prev-encoded)
- (ietf-drums-init (mail-header-remove-whitespace
- (mail-header-remove-comments string)))
+ c type attribute encoded number 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 parsable. 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
- (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))
+ (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
- (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))
- (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
+ (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))
+ ;; Jump over asterisk, non-ASCII
+ ;; and non-boundary characters.
+ (while (and c
+ (or (eq c ?*)
+ (> c ?\177)
+ (not (eq (char-syntax c) ? ))))
(forward-char 1)
- (forward-sexp))
+ (setq c (char-after)))
(point)))))
- (t
- (error "Invalid header: %s" string)))
- (if number
- (setq prev-attribute attribute
- prev-value (concat prev-value value)
- prev-encoded encoded)
- (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 prev-encoded
- (rfc2231-decode-encoded-string prev-value)
- prev-value))
- parameters))
+ (t
+ (error "Invalid header: %s" string)))
+ (push (list attribute value number encoded)
+ parameters))))
+ (error
+ (setq parameters nil)
+ (when signal-error
+ (signal (car err) (cdr err)))))
- (when type
- `(,type ,@(nreverse parameters)))))))
+ ;; Now collect and concatenate continuation parameters.
+ (let ((cparams nil)
+ elem)
+ (loop for (attribute value&n
projects / gnus / blobdiff