1 ;;; rfc2231.el --- Functions for decoding rfc2231 headers
3 ;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004, 2005,
4 ;; 2006 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 2, or (at your option)
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; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
22 ;; Boston, MA 02110-1301, USA.
28 (eval-when-compile (require 'cl))
31 (autoload 'mm-encode-body "mm-bodies")
32 (autoload 'mail-header-remove-whitespace "mail-parse")
33 (autoload 'mail-header-remove-comments "mail-parse")
35 (defun rfc2231-get-value (ct attribute)
36 "Return the value of ATTRIBUTE from CT."
37 (cdr (assq attribute (cdr ct))))
39 (defun rfc2231-parse-qp-string (string)
40 "Parse QP-encoded string using `rfc2231-parse-string'.
41 N.B. This is in violation with RFC2047, but it seem to be in common use."
42 (rfc2231-parse-string (rfc2047-decode-string string)))
44 (defun rfc2231-parse-string (string &optional signal-error)
45 "Parse STRING and return a list.
46 The list will be on the form
47 `(name (attribute . value) (attribute . value)...)'.
49 If the optional SIGNAL-ERROR is non-nil, signal an error when this
50 function fails in parsing of parameters. Otherwise, this function
51 must never cause a Lisp error."
53 (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token))
54 (stoken (ietf-drums-token-to-list ietf-drums-tspecials))
55 (ntoken (ietf-drums-token-to-list "0-9"))
56 c type attribute encoded number parameters value)
59 (mail-header-remove-whitespace
60 (mail-header-remove-comments string))
61 ;; The most likely cause of an error is unbalanced parentheses
62 ;; or double-quotes. If all parentheses and double-quotes are
63 ;; quoted meaninglessly with backslashes, removing them might
64 ;; make it parseable. Let's try...
67 (when (and (string-match "\\\\\"" string)
68 (not (string-match "\\`\"\\|[^\\]\"" string)))
69 (setq string (mm-replace-in-string string "\\\\\"" "\"")
71 (when (and (string-match "\\\\(" string)
72 (string-match "\\\\)" string)
73 (not (string-match "\\`(\\|[^\\][()]" string)))
74 (setq string (mm-replace-in-string string "\\\\\\([()]\\)" "\\1")
78 (mail-header-remove-whitespace
79 (mail-header-remove-comments string))))
80 ;; Finally, attempt to extract only type.
82 (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+"
83 "\\(?:/[^" ietf-drums-tspecials
84 "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)")
86 (match-string 1 string)
88 (let ((table (copy-syntax-table ietf-drums-syntax-table)))
89 (modify-syntax-entry ?\' "w" table)
90 (modify-syntax-entry ?* " " table)
91 (modify-syntax-entry ?\; " " table)
92 (modify-syntax-entry ?= " " table)
93 ;; The following isn't valid, but one should be liberal
94 ;; in what one receives.
95 (modify-syntax-entry ?\: "w" table)
96 (set-syntax-table table))
98 (when (and (memq c ttoken)
100 (setq type (ignore-errors
102 (buffer-substring (point) (progn
109 (setq c (char-after))
111 (error "Invalid header: %s" string))
113 ;; If c in nil, then this is an invalid header, but
114 ;; since elm generates invalid headers on this form,
116 (when (setq c (char-after))
117 (if (and (memq c ttoken)
118 (not (memq c stoken)))
123 (point) (progn (forward-sexp 1) (point))))))
124 (error "Invalid header: %s" string))
125 (setq c (char-after))
129 (setq c (char-after))
130 (if (not (memq c ntoken))
136 (point) (progn (forward-sexp 1) (point)))))
137 (setq c (char-after))
141 (setq c (char-after)))))
145 (error "Invalid header: %s" string))
147 (setq c (char-after))
150 (setq value (buffer-substring (1+ (point))
155 (setq value (mapconcat (lambda (c) (format "%%%02x" c))
157 ((and (or (memq c ttoken)
158 ;; EXTENSION: Support non-ascii chars.
160 (not (memq c stoken)))
166 ;; We might not have reached at the end of
167 ;; the value because of non-ascii chars,
168 ;; so we should jump over them if any.
169 (while (and (not (eobp))
170 (> (char-after) ?\177))
175 (error "Invalid header: %s" string)))
176 (push (list attribute value number encoded)
179 (setq parameters nil)
181 (signal (car err) (cdr err)))))
183 ;; Now collect and concatenate continuation parameters.
186 (loop for (attribute value part encoded)
187 in (sort parameters (lambda (e1 e2)
190 do (if (or (not (setq elem (assq attribute cparams)))
193 (push (list attribute value encoded) cparams)
194 (setcar (cdr elem) (concat (cadr elem) value))))
195 ;; Finally decode encoded values.
200 (rfc2231-decode-encoded-string (nth 1 elem))
202 (nreverse cparams))))))))
204 (defun rfc2231-decode-encoded-string (string)
205 "Decode an RFC2231-encoded string.
207 \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\",
208 \"us-ascii''This%20is%20%2A%2A%2Afun%2A%2A%2A\",
209 \"'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\",
210 \"''This%20is%20%2A%2A%2Afun%2A%2A%2A\", or
211 \"This is ***fun***\"."
212 (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string)
213 (let ((coding-system (mm-charset-to-coding-system (match-string 1 string)))
214 ;;(language (match-string 2 string))
215 (value (match-string 3 string)))
216 (mm-with-unibyte-buffer
218 (goto-char (point-min))
219 (while (search-forward "%" nil t)
222 (string-to-number (buffer-substring (point) (+ (point) 2)) 16)
223 (delete-region (1- (point)) (+ (point) 2)))))
224 ;; Decode using the charset, if any.
225 (if (memq coding-system '(nil ascii))
227 (mm-decode-coding-string (buffer-string) coding-system)))))
229 (defun rfc2231-encode-string (param value)
230 "Return and PARAM=VALUE string encoded according to RFC2231.
231 Use `mml-insert-parameter' or `mml-insert-parameter-string' to insert
232 the result of this function."
233 (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token))
234 (tspecial (ietf-drums-token-to-list ietf-drums-tspecials))
235 (special (ietf-drums-token-to-list "*'%\n\t"))
236 (ascii (ietf-drums-token-to-list ietf-drums-text-token))
238 ;; Don't make lines exceeding 76 column.
239 (limit (- 74 (length param)))
240 spacep encodep charsetp charset broken)
241 (mm-with-multibyte-buffer
243 (goto-char (point-min))
246 ((or (memq (following-char) control)
247 (memq (following-char) tspecial)
248 (memq (following-char) special))
250 ((eq (following-char) ? )
252 ((not (memq (following-char) ascii))
256 (setq charset (mm-encode-body)))
257 (mm-disable-multibyte)
259 ((or encodep charsetp
262 (> (current-column) (if spacep (- limit 2) limit))))
263 (setq limit (- limit 6))
264 (goto-char (point-min))
265 (insert (symbol-name (or charset 'us-ascii)) "''")
267 (if (or (not (memq (following-char) ascii))
268 (memq (following-char) control)
269 (memq (following-char) tspecial)
270 (memq (following-char) special)
271 (eq (following-char) ? ))
273 (when (>= (current-column) (1- limit))
276 (insert "%" (format "%02x" (following-char)))
278 (when (> (current-column) limit)
282 (goto-char (point-min))
286 (insert (if (>= num 0) " " "")
287 param "*" (format "%d" (incf num)) "*=")
290 (goto-char (point-min))
292 (goto-char (point-max))
295 (goto-char (point-min))
301 ;;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63
302 ;;; rfc2231.el ends here