1 ;;; rfc2231.el --- Functions for decoding rfc2231 headers
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 (eval-when-compile (require 'cl))
29 (autoload 'mm-encode-body "mm-bodies")
30 (autoload 'mail-header-remove-whitespace "mail-parse")
31 (autoload 'mail-header-remove-comments "mail-parse")
33 (defun rfc2231-get-value (ct attribute)
34 "Return the value of ATTRIBUTE from CT."
35 (cdr (assq attribute (cdr ct))))
37 (defun rfc2231-parse-qp-string (string)
38 "Parse QP-encoded string using `rfc2231-parse-string'.
39 N.B. This is in violation with RFC2047, but it seem to be in common use."
40 (rfc2231-parse-string (rfc2047-decode-string string)))
42 (defun rfc2231-parse-string (string &optional signal-error)
43 "Parse STRING and return a list.
44 The list will be on the form
45 `(name (attribute . value) (attribute . value)...)'.
47 If the optional SIGNAL-ERROR is non-nil, signal an error when this
48 function fails in parsing of parameters. Otherwise, this function
49 must never cause a Lisp error."
51 (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token))
52 (stoken (ietf-drums-token-to-list ietf-drums-tspecials))
53 (ntoken (ietf-drums-token-to-list "0-9"))
54 c type attribute encoded number parameters value)
57 (mail-header-remove-whitespace
58 (mail-header-remove-comments string))
59 ;; The most likely cause of an error is unbalanced parentheses
60 ;; or double-quotes. If all parentheses and double-quotes are
61 ;; quoted meaninglessly with backslashes, removing them might
62 ;; make it parseable. Let's try...
65 (when (and (string-match "\\\\\"" string)
66 (not (string-match "\\`\"\\|[^\\]\"" string)))
67 (setq string (mm-replace-in-string string "\\\\\"" "\"")
69 (when (and (string-match "\\\\(" string)
70 (string-match "\\\\)" string)
71 (not (string-match "\\`(\\|[^\\][()]" string)))
72 (setq string (mm-replace-in-string string "\\\\\\([()]\\)" "\\1")
76 (mail-header-remove-whitespace
77 (mail-header-remove-comments string))))
78 ;; Finally, attempt to extract only type.
80 (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+"
81 "\\(?:/[^" ietf-drums-tspecials
82 "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)")
84 (match-string 1 string)
86 (let ((table (copy-syntax-table ietf-drums-syntax-table)))
87 (modify-syntax-entry ?\' "w" table)
88 (modify-syntax-entry ?* " " table)
89 (modify-syntax-entry ?\; " " table)
90 (modify-syntax-entry ?= " " table)
91 ;; The following isn't valid, but one should be liberal
92 ;; in what one receives.
93 (modify-syntax-entry ?\: "w" table)
94 (set-syntax-table table))
96 (when (and (memq c ttoken)
98 (setq type (ignore-errors
100 (buffer-substring (point) (progn
107 (setq c (char-after))
109 (error "Invalid header: %s" string))
111 ;; If c in nil, then this is an invalid header, but
112 ;; since elm generates invalid headers on this form,
114 (when (setq c (char-after))
115 (if (and (memq c ttoken)
116 (not (memq c stoken)))
121 (point) (progn (forward-sexp 1) (point))))))
122 (error "Invalid header: %s" string))
123 (setq c (char-after))
127 (setq c (char-after))
128 (if (not (memq c ntoken))
134 (point) (progn (forward-sexp 1) (point)))))
135 (setq c (char-after))
139 (setq c (char-after)))))
143 (error "Invalid header: %s" string))
145 (setq c (char-after))
148 (setq value (buffer-substring (1+ (point))
153 (setq value (mapconcat (lambda (c) (format "%%%02x" c))
155 ((and (or (memq c ttoken)
156 ;; EXTENSION: Support non-ascii chars.
158 (not (memq c stoken)))
163 ;; Jump over asterisk, non-ASCII
164 ;; and non-boundary characters.
168 (not (eq (char-syntax c) ? ))))
170 (setq c (char-after)))
173 (error "Invalid header: %s" string)))
174 (push (list attribute value number encoded)
177 (setq parameters nil)
179 (signal (car err) (cdr err)))))
181 ;; Now collect and concatenate continuation parameters.
184 (loop for (attribute value part encoded)
185 in (sort parameters (lambda (e1 e2)
188 do (if (or (not (setq elem (assq attribute cparams)))
191 (push (list attribute value encoded) cparams)
192 (setcar (cdr elem) (concat (cadr elem) value))))
193 ;; Finally decode encoded values.
198 (rfc2231-decode-encoded-string (nth 1 elem))
200 (nreverse cparams))))))))
202 (defun rfc2231-decode-encoded-string (string)
203 "Decode an RFC2231-encoded string.
205 \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\",
206 \"us-ascii''This%20is%20%2A%2A%2Afun%2A%2A%2A\",
207 \"'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\",
208 \"''This%20is%20%2A%2A%2Afun%2A%2A%2A\", or
209 \"This is ***fun***\"."
210 (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string)
211 (let ((coding-system (mm-charset-to-coding-system (match-string 1 string)))
212 ;;(language (match-string 2 string))
213 (value (match-string 3 string)))
214 (mm-with-unibyte-buffer
216 (goto-char (point-min))
217 (while (search-forward "%" nil t)
220 (string-to-number (buffer-substring (point) (+ (point) 2)) 16)
221 (delete-region (1- (point)) (+ (point) 2)))))
222 ;; Decode using the charset, if any.
223 (if (memq coding-system '(nil ascii))
225 (mm-decode-coding-string (buffer-string) coding-system)))))
227 (defun rfc2231-encode-string (param value)
228 "Return and PARAM=VALUE string encoded according to RFC2231.
229 Use `mml-insert-parameter' or `mml-insert-parameter-string' to insert
230 the result of this function."
231 (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token))
232 (tspecial (ietf-drums-token-to-list ietf-drums-tspecials))
233 (special (ietf-drums-token-to-list "*'%\n\t"))
234 (ascii (ietf-drums-token-to-list ietf-drums-text-token))
236 ;; Don't make lines exceeding 76 column.
237 (limit (- 74 (length param)))
238 spacep encodep charsetp charset broken)
239 (mm-with-multibyte-buffer
241 (goto-char (point-min))
244 ((or (memq (following-char) control)
245 (memq (following-char) tspecial)
246 (memq (following-char) special))
248 ((eq (following-char) ? )
250 ((not (memq (following-char) ascii))
254 (setq charset (mm-encode-body)))
255 (mm-disable-multibyte)
257 ((or encodep charsetp
260 (> (current-column) (if spacep (- limit 2) limit))))
261 (setq limit (- limit 6))
262 (goto-char (point-min))
263 (insert (symbol-name (or charset 'us-ascii)) "''")
265 (if (or (not (memq (following-char) ascii))
266 (memq (following-char) control)
267 (memq (following-char) tspecial)
268 (memq (following-char) special)
269 (eq (following-char) ? ))
271 (when (>= (current-column) (1- limit))
274 (insert "%" (format "%02x" (following-char)))
276 (when (> (current-column) limit)
280 (goto-char (point-min))
284 (insert (if (>= num 0) " " "")
285 param "*" (format "%d" (incf num)) "*=")
288 (goto-char (point-min))
290 (goto-char (point-max))
293 (goto-char (point-min))
299 ;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63
300 ;;; rfc2231.el ends here