Mercurial > emacs
comparison lisp/gnus/rfc2231.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | 695cf19ef79e |
children | e300f00a427a |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
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 Free Software Foundation, Inc. |
4 | 4 |
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
6 ;; This file is part of GNU Emacs. | 6 ;; This file is part of GNU Emacs. |
7 | 7 |
8 ;; GNU Emacs is free software; you can redistribute it and/or modify | 8 ;; GNU Emacs is free software; you can redistribute it and/or modify |
24 | 24 |
25 ;;; Code: | 25 ;;; Code: |
26 | 26 |
27 (eval-when-compile (require 'cl)) | 27 (eval-when-compile (require 'cl)) |
28 (require 'ietf-drums) | 28 (require 'ietf-drums) |
29 (require 'rfc2047) | |
30 (autoload 'mm-encode-body "mm-bodies") | |
31 (autoload 'mail-header-remove-whitespace "mail-parse") | |
32 (autoload 'mail-header-remove-comments "mail-parse") | |
29 | 33 |
30 (defun rfc2231-get-value (ct attribute) | 34 (defun rfc2231-get-value (ct attribute) |
31 "Return the value of ATTRIBUTE from CT." | 35 "Return the value of ATTRIBUTE from CT." |
32 (cdr (assq attribute (cdr ct)))) | 36 (cdr (assq attribute (cdr ct)))) |
37 | |
38 (defun rfc2231-parse-qp-string (string) | |
39 "Parse QP-encoded string using `rfc2231-parse-string'. | |
40 N.B. This is in violation with RFC2047, but it seem to be in common use." | |
41 (rfc2231-parse-string (rfc2047-decode-string string))) | |
33 | 42 |
34 (defun rfc2231-parse-string (string) | 43 (defun rfc2231-parse-string (string) |
35 "Parse STRING and return a list. | 44 "Parse STRING and return a list. |
36 The list will be on the form | 45 The list will be on the form |
37 `(name (attribute . value) (attribute . value)...)" | 46 `(name (attribute . value) (attribute . value)...)" |
45 prev-attribute) | 54 prev-attribute) |
46 (ietf-drums-init (mail-header-remove-whitespace | 55 (ietf-drums-init (mail-header-remove-whitespace |
47 (mail-header-remove-comments string))) | 56 (mail-header-remove-comments string))) |
48 (let ((table (copy-syntax-table ietf-drums-syntax-table))) | 57 (let ((table (copy-syntax-table ietf-drums-syntax-table))) |
49 (modify-syntax-entry ?\' "w" table) | 58 (modify-syntax-entry ?\' "w" table) |
59 (modify-syntax-entry ?= " " table) | |
50 ;; The following isn't valid, but one should be liberal | 60 ;; The following isn't valid, but one should be liberal |
51 ;; in what one receives. | 61 ;; in what one receives. |
52 (modify-syntax-entry ?\: "w" table) | 62 (modify-syntax-entry ?\: "w" table) |
53 (set-syntax-table table)) | 63 (set-syntax-table table)) |
54 (setq c (char-after)) | 64 (setq c (char-after)) |
77 (setq c (char-after)) | 87 (setq c (char-after)) |
78 (setq encoded nil) | 88 (setq encoded nil) |
79 (when (eq c ?*) | 89 (when (eq c ?*) |
80 (forward-char 1) | 90 (forward-char 1) |
81 (setq c (char-after)) | 91 (setq c (char-after)) |
82 (when (memq c ntoken) | 92 (if (not (memq c ntoken)) |
93 (setq encoded t | |
94 number nil) | |
83 (setq number | 95 (setq number |
84 (string-to-number | 96 (string-to-number |
85 (buffer-substring | 97 (buffer-substring |
86 (point) (progn (forward-sexp 1) (point))))) | 98 (point) (progn (forward-sexp 1) (point))))) |
87 (setq c (char-after)) | 99 (setq c (char-after)) |
102 (cond | 114 (cond |
103 ((eq c ?\") | 115 ((eq c ?\") |
104 (setq value | 116 (setq value |
105 (buffer-substring (1+ (point)) | 117 (buffer-substring (1+ (point)) |
106 (progn (forward-sexp 1) (1- (point)))))) | 118 (progn (forward-sexp 1) (1- (point)))))) |
107 ((and (memq c ttoken) | 119 ((and (or (memq c ttoken) |
120 (> c ?\177)) ;; EXTENSION: Support non-ascii chars. | |
108 (not (memq c stoken))) | 121 (not (memq c stoken))) |
109 (setq value (buffer-substring | 122 (setq value (buffer-substring |
110 (point) (progn (forward-sexp 1) (point))))) | 123 (point) (progn (forward-sexp) (point))))) |
111 (t | 124 (t |
112 (error "Invalid header: %s" string))) | 125 (error "Invalid header: %s" string))) |
113 (when encoded | 126 (when encoded |
114 (setq value (rfc2231-decode-encoded-string value))) | 127 (setq value (rfc2231-decode-encoded-string value))) |
115 (if number | 128 (if number |
138 (insert | 151 (insert |
139 (prog1 | 152 (prog1 |
140 (string-to-number (buffer-substring (point) (+ (point) 2)) 16) | 153 (string-to-number (buffer-substring (point) (+ (point) 2)) 16) |
141 (delete-region (1- (point)) (+ (point) 2))))) | 154 (delete-region (1- (point)) (+ (point) 2))))) |
142 ;; Encode using the charset, if any. | 155 ;; Encode using the charset, if any. |
143 (when (and (< (length elems) 1) | 156 (when (and (mm-multibyte-p) |
144 (not (equal (intern (car elems)) 'us-ascii))) | 157 (> (length elems) 1) |
158 (not (equal (intern (downcase (car elems))) 'us-ascii))) | |
145 (mm-decode-coding-region (point-min) (point-max) | 159 (mm-decode-coding-region (point-min) (point-max) |
146 (intern (car elems)))) | 160 (intern (downcase (car elems))))) |
147 (buffer-string)))) | 161 (buffer-string)))) |
148 | 162 |
149 (defun rfc2231-encode-string (param value) | 163 (defun rfc2231-encode-string (param value) |
150 "Return and PARAM=VALUE string encoded according to RFC2231." | 164 "Return and PARAM=VALUE string encoded according to RFC2231." |
151 (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token)) | 165 (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token)) |
173 (cond | 187 (cond |
174 ((or encodep charsetp) | 188 ((or encodep charsetp) |
175 (goto-char (point-min)) | 189 (goto-char (point-min)) |
176 (while (not (eobp)) | 190 (while (not (eobp)) |
177 (when (> (current-column) 60) | 191 (when (> (current-column) 60) |
178 (insert "\n") | 192 (insert ";\n") |
179 (setq broken t)) | 193 (setq broken t)) |
180 (if (or (not (memq (following-char) ascii)) | 194 (if (or (not (memq (following-char) ascii)) |
181 (memq (following-char) control) | 195 (memq (following-char) control) |
182 (memq (following-char) tspecial) | 196 (memq (following-char) tspecial) |
183 (memq (following-char) special) | 197 (memq (following-char) special) |
185 (progn | 199 (progn |
186 (insert "%" (format "%02x" (following-char))) | 200 (insert "%" (format "%02x" (following-char))) |
187 (delete-char 1)) | 201 (delete-char 1)) |
188 (forward-char 1))) | 202 (forward-char 1))) |
189 (goto-char (point-min)) | 203 (goto-char (point-min)) |
190 (insert (or charset "ascii") "''") | 204 (insert (symbol-name (or charset 'us-ascii)) "''") |
191 (goto-char (point-min)) | 205 (goto-char (point-min)) |
192 (if (not broken) | 206 (if (not broken) |
193 (insert param "*=") | 207 (insert param "*=") |
194 (while (not (eobp)) | 208 (while (not (eobp)) |
195 (insert param "*" (format "%d" (incf num)) "*=") | 209 (insert (if (>= num 0) " " "\n ") |
210 param "*" (format "%d" (incf num)) "*=") | |
196 (forward-line 1)))) | 211 (forward-line 1)))) |
197 (spacep | 212 (spacep |
198 (goto-char (point-min)) | 213 (goto-char (point-min)) |
199 (insert param "=\"") | 214 (insert param "=\"") |
200 (goto-char (point-max)) | 215 (goto-char (point-max)) |