[bpt/emacs.git] / lisp / gnus / rfc2231.el

;;; rfc2231.el --- Functions for decoding rfc2231 headers

;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004
;;        Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(eval-when-compile (require 'cl))
(require 'ietf-drums)
(require 'rfc2047)
(autoload 'mm-encode-body "mm-bodies")
(autoload 'mail-header-remove-whitespace "mail-parse")
(autoload 'mail-header-remove-comments "mail-parse")

(defun rfc2231-get-value (ct attribute)
  "Return the value of ATTRIBUTE from CT."
  (cdr (assq attribute (cdr ct))))

(defun rfc2231-parse-qp-string (string)
  "Parse QP-encoded string using `rfc2231-parse-string'.
N.B.  This is in violation with RFC2047, but it seem to be in common use."
  (rfc2231-parse-string (rfc2047-decode-string string)))

(defun rfc2231-parse-string (string)
  "Parse STRING and return a list.
The list will be on the form
 `(name (attribute . value) (attribute . value)...)"
  (with-temp-buffer
    (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token))
	  (stoken (ietf-drums-token-to-list ietf-drums-tspecials))
	  (ntoken (ietf-drums-token-to-list "0-9"))
	  (prev-value "")
	  display-name mailbox c display-string parameters
	  attribute value type subtype number encoded
	  prev-attribute)
      (ietf-drums-init (mail-header-remove-whitespace
			(mail-header-remove-comments string)))
      (let ((table (copy-syntax-table ietf-drums-syntax-table)))
	(modify-syntax-entry ?\' "w" table)
	(modify-syntax-entry ?* " " table)
	(modify-syntax-entry ?\; " " table)
	(modify-syntax-entry ?= " " table)
	;; The following isn't valid, but one should be liberal
	;; in what one receives.
	(modify-syntax-entry ?\: "w" table)
	(set-syntax-table table))
      (setq c (char-after))
      (when (and (memq c ttoken)
		 (not (memq c stoken)))
	(setq type (downcase (buffer-substring
			      (point) (progn (forward-sexp 1) (point)))))
	;; Do the params
	(while (not (eobp))
	  (setq c (char-after))
	  (unless (eq c ?\;)
	    (error "Invalid header: %s" string))
	  (forward-char 1)
	  ;; If c in nil, then this is an invalid header, but
	  ;; since elm generates invalid headers on this form,
	  ;; we allow it.
	  (when (setq c (char-after))
	    (if (and (memq c ttoken)
		     (not (memq c stoken)))
		(setq attribute
		      (intern
		       (downcase
			(buffer-substring
			 (point) (progn (forward-sexp 1) (point))))))
	      (error "Invalid header: %s" string))
	    (setq c (char-after))
	    (when (eq c ?*)
	      (forward-char 1)
	      (setq c (char-after))
	      (if (not (memq c ntoken))
		  (setq encoded t
			number nil)
		(setq number
		      (string-to-number
		       (buffer-substring
			(point) (progn (forward-sexp 1) (point)))))
		(setq c (char-after))
		(when (eq c ?*)
		  (setq encoded t)
		  (forward-char 1)
		  (setq c (char-after)))))
	    ;; See if we have any previous continuations.
	    (when (and prev-attribute
		       (not (eq prev-attribute attribute)))
	      (push (cons prev-attribute prev-value) parameters)
	      (setq prev-attribute nil
		    prev-value ""))
	    (unless (eq c ?=)
	      (error "Invalid header: %s" string))
	    (forward-char 1)
	    (setq c (char-after))
	    (cond
	     ((eq c ?\")
	      (setq value
		    (buffer-substring (1+ (point))
				      (progn (forward-sexp 1) (1- (point))))))
	     ((and (or (memq c ttoken)
		       (> c ?\177)) ;; EXTENSION: Support non-ascii chars.
		   (not (memq c stoken)))
	      (setq value (buffer-substring
			   (point) (progn (forward-sexp) (point)))))
	     (t
	      (error "Invalid header: %s" string)))
	    (if number
		(setq prev-attribute attribute
		      prev-value (concat prev-value value))
	      (push (cons attribute
			  (if encoded
			      (rfc2231-decode-encoded-string value)
			    value))
		    parameters))))

	;; Take care of any final continuations.
	(when prev-attribute
	  (push (cons prev-attribute
		      (if encoded
			  (rfc2231-decode-encoded-string prev-value)
			prev-value))
		parameters))

	(when type
	  `(,type ,@(nreverse parameters)))))))

(defun rfc2231-decode-encoded-string (string)
  "Decode an RFC2231-encoded string.
These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"."
  (with-temp-buffer
    (let ((elems (split-string string "'")))
      ;; The encoded string may contain zero to two single-quote
      ;; marks.  This should give us the encoded word stripped
      ;; of any preceding values.
      (insert (car (last elems)))
      (goto-char (point-min))
      (while (search-forward "%" nil t)
	(insert
	 (prog1
	     (string-to-number (buffer-substring (point) (+ (point) 2)) 16)
	   (delete-region (1- (point)) (+ (point) 2)))))
      ;; Encode using the charset, if any.
      (when (and (mm-multibyte-p)
		 (> (length elems) 1)
		 (not (equal (intern (downcase (car elems))) 'us-ascii)))
	(mm-decode-coding-region (point-min) (point-max)
				 (intern (downcase (car elems)))))
      (buffer-string))))

(defun rfc2231-encode-string (param value)
  "Return and PARAM=VALUE string encoded according to RFC2231."
  (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token))
	(tspecial (ietf-drums-token-to-list ietf-drums-tspecials))
	(special (ietf-drums-token-to-list "*'%\n\t"))
	(ascii (ietf-drums-token-to-list ietf-drums-text-token))
	(num -1)
	spacep encodep charsetp charset broken)
    (with-temp-buffer
      (insert value)
      (goto-char (point-min))
      (while (not (eobp))
	(cond
	 ((or (memq (following-char) control)
	      (memq (following-char) tspecial)
	      (memq (following-char) special))
	  (setq encodep t))
	 ((eq (following-char) ? )
	  (setq spacep t))
	 ((not (memq (following-char) ascii))
	  (setq charsetp t)))
	(forward-char 1))
      (when charsetp
	(setq charset (mm-encode-body)))
      (cond
       ((or encodep charsetp)
	(goto-char (point-min))
	(while (not (eobp))
	  (when (> (current-column) 60)
	    (insert ";\n")
	    (setq broken t))
	  (if (or (not (memq (following-char) ascii))
		  (memq (following-char) control)
		  (memq (following-char) tspecial)
		  (memq (following-char) special)
		  (eq (following-char) ? ))
	      (progn
		(insert "%" (format "%02x" (following-char)))
		(delete-char 1))
	    (forward-char 1)))
	(goto-char (point-min))
	(insert (symbol-name (or charset 'us-ascii)) "''")
	(goto-char (point-min))
	(if (not broken)
	    (insert param "*=")
	  (while (not (eobp))
	    (insert (if (>= num 0) " " "\n ")
		    param "*" (format "%d" (incf num)) "*=")
	    (forward-line 1))))
       (spacep
	(goto-char (point-min))
	(insert param "=\"")
	(goto-char (point-max))
	(insert "\""))
       (t
	(goto-char (point-min))
	(insert param "=")))
      (buffer-string))))

(provide 'rfc2231)

;;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63
;;; rfc2231.el ends here
Commit	Line	Data
23f87bed	1	;;; rfc2231.el --- Functions for decoding rfc2231 headers
c113de23	2
23f87bed MB	3	;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004
23f87bed MB	4	;; Free Software Foundation, Inc.
c113de23 GM	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., 59 Temple Place - Suite 330,
	22	;; Boston, MA 02111-1307, USA.
	23
	24	;;; Commentary:
	25
	26	;;; Code:
	27
e017ba35	28	(eval-when-compile (require 'cl))
c113de23	29	(require 'ietf-drums)
23f87bed MB	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")
c113de23 GM	34
	35	(defun rfc2231-get-value (ct attribute)
	36	"Return the value of ATTRIBUTE from CT."
	37	(cdr (assq attribute (cdr ct))))
	38
23f87bed MB	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
c113de23 GM	44	(defun rfc2231-parse-string (string)
	45	"Parse STRING and return a list.
	46	The list will be on the form
	47	`(name (attribute . value) (attribute . value)...)"
	48	(with-temp-buffer
	49	(let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token))
	50	(stoken (ietf-drums-token-to-list ietf-drums-tspecials))
	51	(ntoken (ietf-drums-token-to-list "0-9"))
	52	(prev-value "")
	53	display-name mailbox c display-string parameters
	54	attribute value type subtype number encoded
	55	prev-attribute)
	56	(ietf-drums-init (mail-header-remove-whitespace
	57	(mail-header-remove-comments string)))
	58	(let ((table (copy-syntax-table ietf-drums-syntax-table)))
	59	(modify-syntax-entry ?\' "w" table)
23f87bed MB	60	(modify-syntax-entry ?* " " table)
	61	(modify-syntax-entry ?\; " " table)
	62	(modify-syntax-entry ?= " " table)
c113de23 GM	63	;; The following isn't valid, but one should be liberal
	64	;; in what one receives.
	65	(modify-syntax-entry ?\: "w" table)
	66	(set-syntax-table table))
	67	(setq c (char-after))
	68	(when (and (memq c ttoken)
	69	(not (memq c stoken)))
	70	(setq type (downcase (buffer-substring
	71	(point) (progn (forward-sexp 1) (point)))))
	72	;; Do the params
	73	(while (not (eobp))
	74	(setq c (char-after))
	75	(unless (eq c ?\;)
	76	(error "Invalid header: %s" string))
	77	(forward-char 1)
	78	;; If c in nil, then this is an invalid header, but
	79	;; since elm generates invalid headers on this form,
	80	;; we allow it.
	81	(when (setq c (char-after))
	82	(if (and (memq c ttoken)
	83	(not (memq c stoken)))
	84	(setq attribute
	85	(intern
	86	(downcase
	87	(buffer-substring
	88	(point) (progn (forward-sexp 1) (point))))))
	89	(error "Invalid header: %s" string))
	90	(setq c (char-after))
c113de23 GM	91	(when (eq c ?*)
	92	(forward-char 1)
	93	(setq c (char-after))
23f87bed MB	94	(if (not (memq c ntoken))
	95	(setq encoded t
	96	number nil)
c113de23 GM	97	(setq number
	98	(string-to-number
	99	(buffer-substring
	100	(point) (progn (forward-sexp 1) (point)))))
	101	(setq c (char-after))
	102	(when (eq c ?*)
	103	(setq encoded t)
	104	(forward-char 1)
	105	(setq c (char-after)))))
	106	;; See if we have any previous continuations.
	107	(when (and prev-attribute
	108	(not (eq prev-attribute attribute)))
	109	(push (cons prev-attribute prev-value) parameters)
	110	(setq prev-attribute nil
	111	prev-value ""))
	112	(unless (eq c ?=)
	113	(error "Invalid header: %s" string))
	114	(forward-char 1)
	115	(setq c (char-after))
	116	(cond
	117	((eq c ?\")
	118	(setq value
	119	(buffer-substring (1+ (point))
	120	(progn (forward-sexp 1) (1- (point))))))
23f87bed MB	121	((and (or (memq c ttoken)
23f87bed MB	122	(> c ?\177)) ;; EXTENSION: Support non-ascii chars.
c113de23 GM	123	(not (memq c stoken)))
c113de23 GM	124	(setq value (buffer-substring
23f87bed	125	(point) (progn (forward-sexp) (point)))))
c113de23 GM	126	(t
c113de23 GM	127	(error "Invalid header: %s" string)))
c113de23 GM	128	(if number
	129	(setq prev-attribute attribute
	130	prev-value (concat prev-value value))
aa0a8561 MB	131	(push (cons attribute
	132	(if encoded
	133	(rfc2231-decode-encoded-string value)
	134	value))
	135	parameters))))
c113de23 GM	136
	137	;; Take care of any final continuations.
	138	(when prev-attribute
aa0a8561 MB	139	(push (cons prev-attribute
	140	(if encoded
	141	(rfc2231-decode-encoded-string prev-value)
	142	prev-value))
	143	parameters))
c113de23 GM	144
	145	(when type
	146	`(,type ,@(nreverse parameters)))))))
	147
	148	(defun rfc2231-decode-encoded-string (string)
	149	"Decode an RFC2231-encoded string.
	150	These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"."
	151	(with-temp-buffer
	152	(let ((elems (split-string string "'")))
	153	;; The encoded string may contain zero to two single-quote
	154	;; marks. This should give us the encoded word stripped
	155	;; of any preceding values.
	156	(insert (car (last elems)))
	157	(goto-char (point-min))
	158	(while (search-forward "%" nil t)
	159	(insert
	160	(prog1
	161	(string-to-number (buffer-substring (point) (+ (point) 2)) 16)
	162	(delete-region (1- (point)) (+ (point) 2)))))
	163	;; Encode using the charset, if any.
23f87bed MB	164	(when (and (mm-multibyte-p)
	165	(> (length elems) 1)
	166	(not (equal (intern (downcase (car elems))) 'us-ascii)))
c113de23	167	(mm-decode-coding-region (point-min) (point-max)
23f87bed	168	(intern (downcase (car elems)))))
c113de23 GM	169	(buffer-string))))
	170
	171	(defun rfc2231-encode-string (param value)
	172	"Return and PARAM=VALUE string encoded according to RFC2231."
	173	(let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token))
	174	(tspecial (ietf-drums-token-to-list ietf-drums-tspecials))
	175	(special (ietf-drums-token-to-list "*'%\n\t"))
	176	(ascii (ietf-drums-token-to-list ietf-drums-text-token))
	177	(num -1)
	178	spacep encodep charsetp charset broken)
	179	(with-temp-buffer
	180	(insert value)
	181	(goto-char (point-min))
	182	(while (not (eobp))
	183	(cond
	184	((or (memq (following-char) control)
	185	(memq (following-char) tspecial)
	186	(memq (following-char) special))
	187	(setq encodep t))
	188	((eq (following-char) ? )
	189	(setq spacep t))
	190	((not (memq (following-char) ascii))
	191	(setq charsetp t)))
	192	(forward-char 1))
	193	(when charsetp
	194	(setq charset (mm-encode-body)))
	195	(cond
	196	((or encodep charsetp)
	197	(goto-char (point-min))
	198	(while (not (eobp))
	199	(when (> (current-column) 60)
23f87bed	200	(insert ";\n")
c113de23 GM	201	(setq broken t))
	202	(if (or (not (memq (following-char) ascii))
	203	(memq (following-char) control)
	204	(memq (following-char) tspecial)
	205	(memq (following-char) special)
	206	(eq (following-char) ? ))
	207	(progn
	208	(insert "%" (format "%02x" (following-char)))
	209	(delete-char 1))
	210	(forward-char 1)))
	211	(goto-char (point-min))
23f87bed	212	(insert (symbol-name (or charset 'us-ascii)) "''")
c113de23 GM	213	(goto-char (point-min))
	214	(if (not broken)
	215	(insert param "*=")
	216	(while (not (eobp))
23f87bed MB	217	(insert (if (>= num 0) " " "\n ")
23f87bed MB	218	param "" (format "%d" (incf num)) "=")
c113de23 GM	219	(forward-line 1))))
	220	(spacep
	221	(goto-char (point-min))
	222	(insert param "=\"")
	223	(goto-char (point-max))
	224	(insert "\""))
	225	(t
	226	(goto-char (point-min))
	227	(insert param "=")))
	228	(buffer-string))))
	229
	230	(provide 'rfc2231)
	231
ab5796a9	232	;;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63
c113de23	233	;;; rfc2231.el ends here