lisp/rfc2231.el

   1 ;;; rfc2231.el --- Functions for decoding rfc2231 headers
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004, 2005,
   4 ;;   2006 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; This file is part of GNU Emacs.
   8
   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)
  12 ;; any later version.
  13
  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.
  18
  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.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  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")
  34
  35 (defun rfc2231-get-value (ct attribute)
  36   "Return the value of ATTRIBUTE from 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)))
  43
  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)...)'.
  48
  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."
  52   (with-temp-buffer
  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)
  57       (ietf-drums-init
  58        (condition-case nil
  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...
  65          (error
  66           (let (mod)
  67             (when (and (string-match "\\\\\"" string)
  68                        (not (string-match "\\`\"\\|[^\\]\"" string)))
  69               (setq string (mm-replace-in-string string "\\\\\"" "\"")
  70                     mod t))
  71             (when (and (string-match "\\\\(" string)
  72                        (string-match "\\\\)" string)
  73                        (not (string-match "\\`(\\|[^\\][()]" string)))
  74               (setq string (mm-replace-in-string string "\\\\\\([()]\\)" "\\1")
  75                     mod t))
  76             (or (and mod
  77                      (ignore-errors
  78                        (mail-header-remove-whitespace
  79                         (mail-header-remove-comments string))))
  80                 ;; Finally, attempt to extract only type.
  81                 (if (string-match
  82                      (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+"
  83                              "\\(?:/[^" ietf-drums-tspecials
  84                              "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)")
  85                      string)
  86                     (match-string 1 string)
  87                   ""))))))
  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))
  97       (setq c (char-after))
  98       (when (and (memq c ttoken)
  99                  (not (memq c stoken))
 100                  (setq type (ignore-errors
 101                               (downcase
 102                                (buffer-substring (point) (progn
 103                                                            (forward-sexp 1)
 104                                                            (point)))))))
 105         ;; Do the params
 106         (condition-case err
 107             (progn
 108               (while (not (eobp))
 109                 (setq c (char-after))
 110                 (unless (eq c ?\;)
 111                   (error "Invalid header: %s" string))
 112                 (forward-char 1)
 113                 ;; If c in nil, then this is an invalid header, but
 114                 ;; since elm generates invalid headers on this form,
 115                 ;; we allow it.
 116                 (when (setq c (char-after))
 117                   (if (and (memq c ttoken)
 118                            (not (memq c stoken)))
 119                       (setq attribute
 120                             (intern
 121                              (downcase
 122                               (buffer-substring
 123                                (point) (progn (forward-sexp 1) (point))))))
 124                     (error "Invalid header: %s" string))
 125                   (setq c (char-after))
 126                   (if (eq c ?*)
 127                       (progn
 128                         (forward-char 1)
 129                         (setq c (char-after))
 130                         (if (not (memq c ntoken))
 131                             (setq encoded t
 132                                   number nil)
 133                           (setq number
 134                                 (string-to-number
 135                                  (buffer-substring
 136                                   (point) (progn (forward-sexp 1) (point)))))
 137                           (setq c (char-after))
 138                           (when (eq c ?*)
 139                             (setq encoded t)
 140                             (forward-char 1)
 141                             (setq c (char-after)))))
 142                     (setq number nil
 143                           encoded nil))
 144                   (unless (eq c ?=)
 145                     (error "Invalid header: %s" string))
 146                   (forward-char 1)
 147                   (setq c (char-after))
 148                   (cond
 149                    ((eq c ?\")
 150                     (setq value (buffer-substring (1+ (point))
 151                                                   (progn
 152                                                     (forward-sexp 1)
 153                                                     (1- (point)))))
 154                     (when encoded
 155                       (setq value (mapconcat (lambda (c) (format "%%%02x" c))
 156                                              value ""))))
 157                    ((and (or (memq c ttoken)
 158                              ;; EXTENSION: Support non-ascii chars.
 159                              (> c ?\177))
 160                          (not (memq c stoken)))
 161                     (setq value
 162                           (buffer-substring
 163                            (point)
 164                            (progn
 165                              (forward-sexp)
 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))
 171                                (forward-char 1)
 172                                (forward-sexp))
 173                              (point)))))
 174                    (t
 175                     (error "Invalid header: %s" string)))
 176                   (push (list attribute
 177                               (if encoded
 178                                   (rfc2231-decode-encoded-string value)
 179                                 value)
 180                               number)
 181                         parameters))))
 182           (error
 183            (setq parameters nil)
 184            (when signal-error
 185              (signal (car err) (cdr err)))))
 186
 187         ;; Now collect and concatenate continuation parameters.
 188         (let ((cparams nil)
 189               elem)
 190           (loop for (attribute value part) in (nreverse parameters)
 191                 do (if (or (not (setq elem (assq attribute cparams)))
 192                            (and (numberp part)
 193                                 (zerop part)))
 194                        (push (cons attribute value) cparams)
 195                      (setcdr elem (concat (cdr elem) value))))
 196           (cons type (nreverse cparams)))))))
 197
 198 (defun rfc2231-decode-encoded-string (string)
 199   "Decode an RFC2231-encoded string.
 200 These look like:
 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
 211       (insert value)
 212       (goto-char (point-min))
 213       (while (search-forward "%" nil t)
 214         (insert
 215          (prog1
 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))
 220           (buffer-string)
 221         (mm-decode-coding-string (buffer-string) coding-system)))))
 222
 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))
 231         (num -1)
 232         ;; Don't make lines exceeding 76 column.
 233         (limit (- 74 (length param)))
 234         spacep encodep charsetp charset broken)
 235     (mm-with-multibyte-buffer
 236       (insert value)
 237       (goto-char (point-min))
 238       (while (not (eobp))
 239         (cond
 240          ((or (memq (following-char) control)
 241               (memq (following-char) tspecial)
 242               (memq (following-char) special))
 243           (setq encodep t))
 244          ((eq (following-char) ? )
 245           (setq spacep t))
 246          ((not (memq (following-char) ascii))
 247           (setq charsetp t)))
 248         (forward-char 1))
 249       (when charsetp
 250         (setq charset (mm-encode-body)))
 251       (mm-disable-multibyte)
 252       (cond
 253        ((or encodep charsetp
 254             (progn
 255               (end-of-line)
 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)) "''")
 260         (while (not (eobp))
 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) ? ))
 266               (progn
 267                 (when (>= (current-column) (1- limit))
 268                   (insert ";\n")
 269                   (setq broken t))
 270                 (insert "%" (format "%02x" (following-char)))
 271                 (delete-char 1))
 272             (when (> (current-column) limit)
 273               (insert ";\n")
 274               (setq broken t))
 275             (forward-char 1)))
 276         (goto-char (point-min))
 277         (if (not broken)
 278             (insert param "*=")
 279           (while (not (eobp))
 280             (insert (if (>= num 0) " " "")
 281                     param "*" (format "%d" (incf num)) "*=")
 282             (forward-line 1))))
 283        (spacep
 284         (goto-char (point-min))
 285         (insert param "=\"")
 286         (goto-char (point-max))
 287         (insert "\""))
 288        (t
 289         (goto-char (point-min))
 290         (insert param "=")))
 291       (buffer-string))))
 292
 293 (provide 'rfc2231)
 294
 295 ;;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63
 296 ;;; rfc2231.el ends here