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
178 (rfc2231-decode-encoded-string value)
183 (setq parameters nil)
185 (signal (car err) (cdr err)))))
187 ;; Now collect and concatenate continuation parameters.
190 (loop for (attribute value part) in (nreverse parameters)
191 do (if (or (not (setq elem (assq attribute cparams)))
194 (push (cons attribute value) cparams)
195 (setcdr elem (concat (cdr elem) value))))
196 (cons type (nreverse cparams)))))))
198 (defun rfc2231-decode-encoded-string (string)
199 "Decode an RFC2231-encoded string.
201 \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\",
202 \"us-ascii''This%20is%20%2A%2A%2Afun%2A%2A%2A\",
203 \"'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\",
204 \"''This%20is%20%2A%2A%2Afun%2A%2A%2A\", or
205 \"This is ***fun***\"."
206 (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string)
207 (let ((coding-system (mm-charset-to-coding-system (match-string 1 string)))
208 ;;(language (match-string 2 string))
209 (value (match-string 3 string)))
210 (mm-with-unibyte-buffer
212 (goto-char (point-min))
213 (while (search-forward "%" nil t)
216 (string-to-number (buffer-substring (point) (+ (point) 2)) 16)
217 (delete-region (1- (point)) (+ (point) 2)))))
218 ;; Decode using the charset, if any.
219 (if (memq coding-system '(nil ascii))
221 (mm-decode-coding-string (buffer-string) coding-system)))))
223 (defun rfc2231-encode-string (param value)
224 "Return and PARAM=VALUE string encoded according to RFC2231.
225 Use `mml-insert-parameter' or `mml-insert-parameter-string' to insert
226 the result of this function."
227 (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token))
228 (tspecial (ietf-drums-token-to-list ietf-drums-tspecials))
229 (special (ietf-drums-token-to-list "*'%\n\t"))
230 (ascii (ietf-drums-token-to-list ietf-drums-text-token))
232 ;; Don't make lines exceeding 76 column.
233 (limit (- 74 (length param)))
234 spacep encodep charsetp charset broken)
235 (mm-with-multibyte-buffer
237 (goto-char (point-min))
240 ((or (memq (following-char) control)
241 (memq (following-char) tspecial)
242 (memq (following-char) special))
244 ((eq (following-char) ? )
246 ((not (memq (following-char) ascii))
250 (setq charset (mm-encode-body)))
251 (mm-disable-multibyte)
253 ((or encodep charsetp
256 (> (current-column) (if spacep (- limit 2) limit))))
257 (setq limit (- limit 6))
258 (goto-char (point-min))
259 (insert (symbol-name (or charset 'us-ascii)) "''")
261 (if (or (not (memq (following-char) ascii))
262 (memq (following-char) control)
263 (memq (following-char) tspecial)
264 (memq (following-char) special)
265 (eq (following-char) ? ))
267 (when (>= (current-column) (1- limit))
270 (insert "%" (format "%02x" (following-char)))
272 (when (> (current-column) limit)
276 (goto-char (point-min))
280 (insert (if (>= num 0) " " "")
281 param "*" (format "%d" (incf num)) "*=")
284 (goto-char (point-min))
286 (goto-char (point-max))
289 (goto-char (point-min))
295 ;;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63
296 ;;; rfc2231.el ends here