Mercurial > emacs

comparison lisp/gnus/rfc2231.el @ 88155:d7ddb3e565de

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
sync with trunk
author Henrik Enberg <henrik.enberg@telia.com>
date Mon, 16 Jan 2006 00:03:54 +0000
parents a26d9b55abb6
children
comparison
equal deleted inserted replaced
88154:8ce476d3ba36 88155:d7ddb3e565de
1 ;;; rfc2231.el --- functions for decoding rfc2231 headers 1 ;;; rfc2231.el --- Functions for decoding rfc2231 headers
2 2
3 ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. 3 ;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
4 5
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
7 8
8 ;; GNU Emacs is free software; you can redistribute it and/or modify 9 ;; GNU Emacs is free software; you can redistribute it and/or modify
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details. 17 ;; GNU General Public License for more details.
17 18
18 ;; You should have received a copy of the GNU General Public License 19 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING. If not, write to the 20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 ;; Boston, MA 02111-1307, USA. 22 ;; Boston, MA 02110-1301, USA.
22 23
23 ;;; Commentary: 24 ;;; Commentary:
24 25
25 ;;; Code: 26 ;;; Code:
26 27
27 (eval-when-compile (require 'cl)) 28 (eval-when-compile (require 'cl))
28 (require 'ietf-drums) 29 (require 'ietf-drums)
30 (require 'rfc2047)
31 (autoload 'mm-encode-body "mm-bodies")
32 (autoload 'mail-header-remove-whitespace "mail-parse")
33 (autoload 'mail-header-remove-comments "mail-parse")
29 34
30 (defun rfc2231-get-value (ct attribute) 35 (defun rfc2231-get-value (ct attribute)
31 "Return the value of ATTRIBUTE from CT." 36 "Return the value of ATTRIBUTE from CT."
32 (cdr (assq attribute (cdr ct)))) 37 (cdr (assq attribute (cdr ct))))
38
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)))
33 43
34 (defun rfc2231-parse-string (string) 44 (defun rfc2231-parse-string (string)
35 "Parse STRING and return a list. 45 "Parse STRING and return a list.
36 The list will be on the form 46 The list will be on the form
37 `(name (attribute . value) (attribute . value)...)" 47 `(name (attribute . value) (attribute . value)...)"
40 (stoken (ietf-drums-token-to-list ietf-drums-tspecials)) 50 (stoken (ietf-drums-token-to-list ietf-drums-tspecials))
41 (ntoken (ietf-drums-token-to-list "0-9")) 51 (ntoken (ietf-drums-token-to-list "0-9"))
42 (prev-value "") 52 (prev-value "")
43 display-name mailbox c display-string parameters 53 display-name mailbox c display-string parameters
44 attribute value type subtype number encoded 54 attribute value type subtype number encoded
45 prev-attribute) 55 prev-attribute prev-encoded)
46 (ietf-drums-init (mail-header-remove-whitespace 56 (ietf-drums-init (mail-header-remove-whitespace
47 (mail-header-remove-comments string))) 57 (mail-header-remove-comments string)))
48 (let ((table (copy-syntax-table ietf-drums-syntax-table))) 58 (let ((table (copy-syntax-table ietf-drums-syntax-table)))
49 (modify-syntax-entry ?\' "w" table) 59 (modify-syntax-entry ?\' "w" table)
60 (modify-syntax-entry ?* " " table)
61 (modify-syntax-entry ?\; " " table)
62 (modify-syntax-entry ?= " " table)
50 ;; The following isn't valid, but one should be liberal 63 ;; The following isn't valid, but one should be liberal
51 ;; in what one receives. 64 ;; in what one receives.
52 (modify-syntax-entry ?\: "w" table) 65 (modify-syntax-entry ?\: "w" table)
53 (set-syntax-table table)) 66 (set-syntax-table table))
54 (setq c (char-after)) 67 (setq c (char-after))
73 (downcase 86 (downcase
74 (buffer-substring 87 (buffer-substring
75 (point) (progn (forward-sexp 1) (point)))))) 88 (point) (progn (forward-sexp 1) (point))))))
76 (error "Invalid header: %s" string)) 89 (error "Invalid header: %s" string))
77 (setq c (char-after)) 90 (setq c (char-after))
78 (setq encoded nil)
79 (when (eq c ?*) 91 (when (eq c ?*)
80 (forward-char 1) 92 (forward-char 1)
81 (setq c (char-after)) 93 (setq c (char-after))
82 (when (memq c ntoken) 94 (if (not (memq c ntoken))
95 (setq encoded t
96 number nil)
83 (setq number 97 (setq number
84 (string-to-number 98 (string-to-number
85 (buffer-substring 99 (buffer-substring
86 (point) (progn (forward-sexp 1) (point))))) 100 (point) (progn (forward-sexp 1) (point)))))
87 (setq c (char-after)) 101 (setq c (char-after))
90 (forward-char 1) 104 (forward-char 1)
91 (setq c (char-after))))) 105 (setq c (char-after)))))
92 ;; See if we have any previous continuations. 106 ;; See if we have any previous continuations.
93 (when (and prev-attribute 107 (when (and prev-attribute
94 (not (eq prev-attribute attribute))) 108 (not (eq prev-attribute attribute)))
95 (push (cons prev-attribute prev-value) parameters) 109 (push (cons prev-attribute
110 (if prev-encoded
111 (rfc2231-decode-encoded-string prev-value)
112 prev-value))
113 parameters)
96 (setq prev-attribute nil 114 (setq prev-attribute nil
97 prev-value "")) 115 prev-value ""
116 prev-encoded nil))
98 (unless (eq c ?=) 117 (unless (eq c ?=)
99 (error "Invalid header: %s" string)) 118 (error "Invalid header: %s" string))
100 (forward-char 1) 119 (forward-char 1)
101 (setq c (char-after)) 120 (setq c (char-after))
102 (cond 121 (cond
103 ((eq c ?\") 122 ((eq c ?\")
104 (setq value 123 (setq value
105 (buffer-substring (1+ (point)) 124 (buffer-substring (1+ (point))
106 (progn (forward-sexp 1) (1- (point)))))) 125 (progn (forward-sexp 1) (1- (point))))))
107 ((and (memq c ttoken) 126 ((and (or (memq c ttoken)
127 (> c ?\177)) ;; EXTENSION: Support non-ascii chars.
108 (not (memq c stoken))) 128 (not (memq c stoken)))
109 (setq value (buffer-substring 129 (setq value (buffer-substring
110 (point) (progn (forward-sexp 1) (point))))) 130 (point)
131 (progn
132 (forward-sexp)
133 ;; We might not have reached at the end of
134 ;; the value because of non-ascii chars,
135 ;; so we should jump over them if any.
136 (while (and (not (eobp))
137 (> (char-after) ?\177))
138 (forward-char 1)
139 (forward-sexp))
140 (point)))))
111 (t 141 (t
112 (error "Invalid header: %s" string))) 142 (error "Invalid header: %s" string)))
113 (when encoded
114 (setq value (rfc2231-decode-encoded-string value)))
115 (if number 143 (if number
116 (setq prev-attribute attribute 144 (setq prev-attribute attribute
117 prev-value (concat prev-value value)) 145 prev-value (concat prev-value value)
118 (push (cons attribute value) parameters)))) 146 prev-encoded encoded)
147 (push (cons attribute
148 (if encoded
149 (rfc2231-decode-encoded-string value)
150 value))
151 parameters))))
119 152
120 ;; Take care of any final continuations. 153 ;; Take care of any final continuations.
121 (when prev-attribute 154 (when prev-attribute
122 (push (cons prev-attribute prev-value) parameters)) 155 (push (cons prev-attribute
156 (if prev-encoded
157 (rfc2231-decode-encoded-string prev-value)
158 prev-value))
159 parameters))
123 160
124 (when type 161 (when type
125 `(,type ,@(nreverse parameters))))))) 162 `(,type ,@(nreverse parameters)))))))
126 163
127 (defun rfc2231-decode-encoded-string (string) 164 (defun rfc2231-decode-encoded-string (string)
138 (insert 175 (insert
139 (prog1 176 (prog1
140 (string-to-number (buffer-substring (point) (+ (point) 2)) 16) 177 (string-to-number (buffer-substring (point) (+ (point) 2)) 16)
141 (delete-region (1- (point)) (+ (point) 2))))) 178 (delete-region (1- (point)) (+ (point) 2)))))
142 ;; Encode using the charset, if any. 179 ;; Encode using the charset, if any.
143 (when (and (< (length elems) 1) 180 (when (and (mm-multibyte-p)
144 (not (equal (intern (car elems)) 'us-ascii))) 181 (> (length elems) 1)
182 (not (equal (intern (downcase (car elems))) 'us-ascii)))
145 (mm-decode-coding-region (point-min) (point-max) 183 (mm-decode-coding-region (point-min) (point-max)
146 (intern (car elems)))) 184 (intern (downcase (car elems)))))
147 (buffer-string)))) 185 (buffer-string))))
148 186
149 (defun rfc2231-encode-string (param value) 187 (defun rfc2231-encode-string (param value)
150 "Return and PARAM=VALUE string encoded according to RFC2231." 188 "Return and PARAM=VALUE string encoded according to RFC2231."
151 (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token)) 189 (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token))
173 (cond 211 (cond
174 ((or encodep charsetp) 212 ((or encodep charsetp)
175 (goto-char (point-min)) 213 (goto-char (point-min))
176 (while (not (eobp)) 214 (while (not (eobp))
177 (when (> (current-column) 60) 215 (when (> (current-column) 60)
178 (insert "\n") 216 (insert ";\n")
179 (setq broken t)) 217 (setq broken t))
180 (if (or (not (memq (following-char) ascii)) 218 (if (or (not (memq (following-char) ascii))
181 (memq (following-char) control) 219 (memq (following-char) control)
182 (memq (following-char) tspecial) 220 (memq (following-char) tspecial)
183 (memq (following-char) special) 221 (memq (following-char) special)
185 (progn 223 (progn
186 (insert "%" (format "%02x" (following-char))) 224 (insert "%" (format "%02x" (following-char)))
187 (delete-char 1)) 225 (delete-char 1))
188 (forward-char 1))) 226 (forward-char 1)))
189 (goto-char (point-min)) 227 (goto-char (point-min))
190 (insert (or charset "ascii") "''") 228 (insert (symbol-name (or charset 'us-ascii)) "''")
191 (goto-char (point-min)) 229 (goto-char (point-min))
192 (if (not broken) 230 (if (not broken)
193 (insert param "*=") 231 (insert param "*=")
194 (while (not (eobp)) 232 (while (not (eobp))
195 (insert param "*" (format "%d" (incf num)) "*=") 233 (insert (if (>= num 0) " " "\n ")
234 param "*" (format "%d" (incf num)) "*=")
196 (forward-line 1)))) 235 (forward-line 1))))
197 (spacep 236 (spacep
198 (goto-char (point-min)) 237 (goto-char (point-min))
199 (insert param "=\"") 238 (insert param "=\"")
200 (goto-char (point-max)) 239 (goto-char (point-max))
204 (insert param "="))) 243 (insert param "=")))
205 (buffer-string)))) 244 (buffer-string))))
206 245
207 (provide 'rfc2231) 246 (provide 'rfc2231)
208 247
248 ;;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63
209 ;;; rfc2231.el ends here 249 ;;; rfc2231.el ends here