| 1 | ;;; rfc2231.el --- Functions for decoding rfc2231 headers |
| 2 | |
| 3 | ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 6 | ;; This file is part of GNU Emacs. |
| 7 | |
| 8 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 9 | ;; it under the terms of the GNU General Public License as published by |
| 10 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 11 | ;; any later version. |
| 12 | |
| 13 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 16 | ;; GNU General Public License for more details. |
| 17 | |
| 18 | ;; 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 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 21 | ;; Boston, MA 02111-1307, USA. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | |
| 25 | ;;; Code: |
| 26 | |
| 27 | (eval-when-compile (require 'cl)) |
| 28 | (require 'ietf-drums) |
| 29 | |
| 30 | (defun rfc2231-get-value (ct attribute) |
| 31 | "Return the value of ATTRIBUTE from CT." |
| 32 | (cdr (assq attribute (cdr ct)))) |
| 33 | |
| 34 | (defun rfc2231-parse-string (string) |
| 35 | "Parse STRING and return a list. |
| 36 | The list will be on the form |
| 37 | `(name (attribute . value) (attribute . value)...)" |
| 38 | (with-temp-buffer |
| 39 | (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token)) |
| 40 | (stoken (ietf-drums-token-to-list ietf-drums-tspecials)) |
| 41 | (ntoken (ietf-drums-token-to-list "0-9")) |
| 42 | (prev-value "") |
| 43 | display-name mailbox c display-string parameters |
| 44 | attribute value type subtype number encoded |
| 45 | prev-attribute) |
| 46 | (ietf-drums-init (mail-header-remove-whitespace |
| 47 | (mail-header-remove-comments string))) |
| 48 | (let ((table (copy-syntax-table ietf-drums-syntax-table))) |
| 49 | (modify-syntax-entry ?\' "w" table) |
| 50 | ;; The following isn't valid, but one should be liberal |
| 51 | ;; in what one receives. |
| 52 | (modify-syntax-entry ?\: "w" table) |
| 53 | (set-syntax-table table)) |
| 54 | (setq c (char-after)) |
| 55 | (when (and (memq c ttoken) |
| 56 | (not (memq c stoken))) |
| 57 | (setq type (downcase (buffer-substring |
| 58 | (point) (progn (forward-sexp 1) (point))))) |
| 59 | ;; Do the params |
| 60 | (while (not (eobp)) |
| 61 | (setq c (char-after)) |
| 62 | (unless (eq c ?\;) |
| 63 | (error "Invalid header: %s" string)) |
| 64 | (forward-char 1) |
| 65 | ;; If c in nil, then this is an invalid header, but |
| 66 | ;; since elm generates invalid headers on this form, |
| 67 | ;; we allow it. |
| 68 | (when (setq c (char-after)) |
| 69 | (if (and (memq c ttoken) |
| 70 | (not (memq c stoken))) |
| 71 | (setq attribute |
| 72 | (intern |
| 73 | (downcase |
| 74 | (buffer-substring |
| 75 | (point) (progn (forward-sexp 1) (point)))))) |
| 76 | (error "Invalid header: %s" string)) |
| 77 | (setq c (char-after)) |
| 78 | (setq encoded nil) |
| 79 | (when (eq c ?*) |
| 80 | (forward-char 1) |
| 81 | (setq c (char-after)) |
| 82 | (when (memq c ntoken) |
| 83 | (setq number |
| 84 | (string-to-number |
| 85 | (buffer-substring |
| 86 | (point) (progn (forward-sexp 1) (point))))) |
| 87 | (setq c (char-after)) |
| 88 | (when (eq c ?*) |
| 89 | (setq encoded t) |
| 90 | (forward-char 1) |
| 91 | (setq c (char-after))))) |
| 92 | ;; See if we have any previous continuations. |
| 93 | (when (and prev-attribute |
| 94 | (not (eq prev-attribute attribute))) |
| 95 | (push (cons prev-attribute prev-value) parameters) |
| 96 | (setq prev-attribute nil |
| 97 | prev-value "")) |
| 98 | (unless (eq c ?=) |
| 99 | (error "Invalid header: %s" string)) |
| 100 | (forward-char 1) |
| 101 | (setq c (char-after)) |
| 102 | (cond |
| 103 | ((eq c ?\") |
| 104 | (setq value |
| 105 | (buffer-substring (1+ (point)) |
| 106 | (progn (forward-sexp 1) (1- (point)))))) |
| 107 | ((and (memq c ttoken) |
| 108 | (not (memq c stoken))) |
| 109 | (setq value (buffer-substring |
| 110 | (point) (progn (forward-sexp 1) (point))))) |
| 111 | (t |
| 112 | (error "Invalid header: %s" string))) |
| 113 | (when encoded |
| 114 | (setq value (rfc2231-decode-encoded-string value))) |
| 115 | (if number |
| 116 | (setq prev-attribute attribute |
| 117 | prev-value (concat prev-value value)) |
| 118 | (push (cons attribute value) parameters)))) |
| 119 | |
| 120 | ;; Take care of any final continuations. |
| 121 | (when prev-attribute |
| 122 | (push (cons prev-attribute prev-value) parameters)) |
| 123 | |
| 124 | (when type |
| 125 | `(,type ,@(nreverse parameters))))))) |
| 126 | |
| 127 | (defun rfc2231-decode-encoded-string (string) |
| 128 | "Decode an RFC2231-encoded string. |
| 129 | These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"." |
| 130 | (with-temp-buffer |
| 131 | (let ((elems (split-string string "'"))) |
| 132 | ;; The encoded string may contain zero to two single-quote |
| 133 | ;; marks. This should give us the encoded word stripped |
| 134 | ;; of any preceding values. |
| 135 | (insert (car (last elems))) |
| 136 | (goto-char (point-min)) |
| 137 | (while (search-forward "%" nil t) |
| 138 | (insert |
| 139 | (prog1 |
| 140 | (string-to-number (buffer-substring (point) (+ (point) 2)) 16) |
| 141 | (delete-region (1- (point)) (+ (point) 2))))) |
| 142 | ;; Encode using the charset, if any. |
| 143 | (when (and (< (length elems) 1) |
| 144 | (not (equal (intern (car elems)) 'us-ascii))) |
| 145 | (mm-decode-coding-region (point-min) (point-max) |
| 146 | (intern (car elems)))) |
| 147 | (buffer-string)))) |
| 148 | |
| 149 | (defun rfc2231-encode-string (param value) |
| 150 | "Return and PARAM=VALUE string encoded according to RFC2231." |
| 151 | (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token)) |
| 152 | (tspecial (ietf-drums-token-to-list ietf-drums-tspecials)) |
| 153 | (special (ietf-drums-token-to-list "*'%\n\t")) |
| 154 | (ascii (ietf-drums-token-to-list ietf-drums-text-token)) |
| 155 | (num -1) |
| 156 | spacep encodep charsetp charset broken) |
| 157 | (with-temp-buffer |
| 158 | (insert value) |
| 159 | (goto-char (point-min)) |
| 160 | (while (not (eobp)) |
| 161 | (cond |
| 162 | ((or (memq (following-char) control) |
| 163 | (memq (following-char) tspecial) |
| 164 | (memq (following-char) special)) |
| 165 | (setq encodep t)) |
| 166 | ((eq (following-char) ? ) |
| 167 | (setq spacep t)) |
| 168 | ((not (memq (following-char) ascii)) |
| 169 | (setq charsetp t))) |
| 170 | (forward-char 1)) |
| 171 | (when charsetp |
| 172 | (setq charset (mm-encode-body))) |
| 173 | (cond |
| 174 | ((or encodep charsetp) |
| 175 | (goto-char (point-min)) |
| 176 | (while (not (eobp)) |
| 177 | (when (> (current-column) 60) |
| 178 | (insert "\n") |
| 179 | (setq broken t)) |
| 180 | (if (or (not (memq (following-char) ascii)) |
| 181 | (memq (following-char) control) |
| 182 | (memq (following-char) tspecial) |
| 183 | (memq (following-char) special) |
| 184 | (eq (following-char) ? )) |
| 185 | (progn |
| 186 | (insert "%" (format "%02x" (following-char))) |
| 187 | (delete-char 1)) |
| 188 | (forward-char 1))) |
| 189 | (goto-char (point-min)) |
| 190 | (insert (or charset "ascii") "''") |
| 191 | (goto-char (point-min)) |
| 192 | (if (not broken) |
| 193 | (insert param "*=") |
| 194 | (while (not (eobp)) |
| 195 | (insert param "*" (format "%d" (incf num)) "*=") |
| 196 | (forward-line 1)))) |
| 197 | (spacep |
| 198 | (goto-char (point-min)) |
| 199 | (insert param "=\"") |
| 200 | (goto-char (point-max)) |
| 201 | (insert "\"")) |
| 202 | (t |
| 203 | (goto-char (point-min)) |
| 204 | (insert param "="))) |
| 205 | (buffer-string)))) |
| 206 | |
| 207 | (provide 'rfc2231) |
| 208 | |
| 209 | ;;; rfc2231.el ends here |