X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Frfc2231.el;h=6e9963c5321a4d43b4d191a533a68e4e3f8aff7f;hp=31c9f1ade94f0131ceeedac34543278ba1a592be;hb=76aee12382f9d631bd1a1c51db62be5318e55881;hpb=75880493a6a9dad9607a4002d4c6ab2895b110ca diff --git a/lisp/rfc2231.el b/lisp/rfc2231.el index 31c9f1ade..6e9963c53 100644 --- a/lisp/rfc2231.el +++ b/lisp/rfc2231.el @@ -1,14 +1,14 @@ ;;; rfc2231.el --- Functions for decoding rfc2231 headers -;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004, 2005, -;; 2006 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, +;; 2006, 2007 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. ;; 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) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -47,21 +47,44 @@ The list will be on the form `(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 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) @@ -73,9 +96,12 @@ function fails in parsing of parameters." (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 @@ -97,32 +123,24 @@ function fails in parsing of parameters." (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))))) - ;; 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)) + (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) @@ -132,7 +150,10 @@ function fails in parsing of parameters." (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)) @@ -141,66 +162,69 @@ function fails in parsing of parameters." (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))) + (push (list attribute value number encoded) + parameters)))) (error (setq parameters nil) - (if signal-error - (signal (car err) (cdr err)) - ;;(message "%s" (error-message-string err)) - ))) + (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 part encoded) + in (sort parameters (lambda (e1 e2) + (< (or (caddr e1) 0) + (or (caddr e2) 0)))) + do (if (or (not (setq elem (assq attribute cparams))) + (and (numberp part) + (zerop part))) + (push (list attribute value encoded) cparams) + (setcar (cdr elem) (concat (cadr elem) value)))) + ;; Finally decode encoded values. + (cons type (mapcar + (lambda (elem) + (cons (car elem) + (if (nth 2 elem) + (rfc2231-decode-encoded-string (nth 1 elem)) + (nth 1 elem)))) + (nreverse cparams)))))))) (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-unibyte-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))))) - (buffer-string)))) + ;; Decode using the charset, if any. + (if (memq coding-system '(nil ascii)) + (buffer-string) + (mm-decode-coding-string (buffer-string) coding-system))))) (defun rfc2231-encode-string (param value) "Return and PARAM=VALUE string encoded according to RFC2231. @@ -214,7 +238,7 @@ the result of this function." ;; Don't make lines exceeding 76 column. (limit (- 74 (length param))) spacep encodep charsetp charset broken) - (with-temp-buffer + (mm-with-multibyte-buffer (insert value) (goto-char (point-min)) (while (not (eobp)) @@ -230,6 +254,7 @@ the result of this function." (forward-char 1)) (when charsetp (setq charset (mm-encode-body))) + (mm-disable-multibyte) (cond ((or encodep charsetp (progn @@ -263,12 +288,12 @@ the result of this function." (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)