[bpt/emacs.git] / lisp / gnus / ietf-drums.el

;;; ietf-drums.el --- Functions for parsing RFC822bis headers
;; Copyright (C) 1998, 1999, 2000, 2001, 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:

;; DRUMS is an IETF Working Group that works (or worked) on the
;; successor to RFC822, "Standard For The Format Of Arpa Internet Text
;; Messages".  This library is based on
;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.

;; Pending a real regression self test suite, Simon Josefsson added
;; various self test expressions snipped from bug reports, and their
;; expected value, below.  I you believe it could be useful, please
;; add your own test cases, or write a real self test suite, or just
;; remove this.

;; <m3oekvfd50.fsf@whitebox.m5r.de>
;; (ietf-drums-parse-address "'foo' <foo@example.com>")
;; => ("foo@example.com" . "'foo'")

;;; Code:

(eval-when-compile (require 'cl))
(require 'time-date)
(require 'mm-util)

(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177"
  "US-ASCII control characters excluding CR, LF and white space.")
(defvar ietf-drums-text-token "\001-\011\013\014\016-\177"
  "US-ASCII characters excluding CR and LF.")
(defvar ietf-drums-specials-token "()<>[]:;@\\,.\""
  "Special characters.")
(defvar ietf-drums-quote-token "\\"
  "Quote character.")
(defvar ietf-drums-wsp-token " \t"
  "White space.")
(defvar ietf-drums-fws-regexp
  (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+")
  "Folding white space.")
(defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~"
  "Textual token.")
(defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~."
  "Textual token including full stop.")
(defvar ietf-drums-qtext-token
  (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177")
  "Non-white-space control characters, plus the rest of ASCII excluding
backslash and doublequote.")
(defvar ietf-drums-tspecials "][()<>@,;:\\\"/?="
  "Tspecials.")

(defvar ietf-drums-syntax-table
  (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
    (modify-syntax-entry ?\\ "/" table)
    (modify-syntax-entry ?< "(" table)
    (modify-syntax-entry ?> ")" table)
    (modify-syntax-entry ?@ "w" table)
    (modify-syntax-entry ?/ "w" table)
    (modify-syntax-entry ?* "_" table)
    (modify-syntax-entry ?\; "_" table)
    (modify-syntax-entry ?\' "_" table)
    (if (featurep 'xemacs)
	(let ((i 128))
	  (while (< i 256)
	    (modify-syntax-entry i "w" table)
	    (setq i (1+ i)))))
    table))

(defun ietf-drums-token-to-list (token)
  "Translate TOKEN into a list of characters."
  (let ((i 0)
	b e c out range)
    (while (< i (length token))
      (setq c (mm-char-int (aref token i)))
      (incf i)
      (cond
       ((eq c (mm-char-int ?-))
	(if b
	    (setq range t)
	  (push c out)))
       (range
	(while (<= b c)
	  (push (mm-make-char 'ascii b) out)
	  (incf b))
	(setq range nil))
       ((= i (length token))
	(push (mm-make-char 'ascii c) out))
       (t
	(when b
	  (push (mm-make-char 'ascii b) out))
	(setq b c))))
    (nreverse out)))

(defsubst ietf-drums-init (string)
  (set-syntax-table ietf-drums-syntax-table)
  (insert string)
  (ietf-drums-unfold-fws)
  (goto-char (point-min)))

(defun ietf-drums-remove-comments (string)
  "Remove comments from STRING."
  (with-temp-buffer
    (let (c)
      (ietf-drums-init string)
      (while (not (eobp))
	(setq c (char-after))
	(cond
	 ((eq c ?\")
	  (forward-sexp 1))
	 ((eq c ?\()
	  (delete-region (point) (progn (forward-sexp 1) (point))))
	 (t
	  (forward-char 1))))
      (buffer-string))))

(defun ietf-drums-remove-whitespace (string)
  "Remove whitespace from STRING."
  (with-temp-buffer
    (ietf-drums-init string)
    (let (c)
      (while (not (eobp))
	(setq c (char-after))
	(cond
	 ((eq c ?\")
	  (forward-sexp 1))
	 ((eq c ?\()
	  (forward-sexp 1))
	 ((memq c '(?\  ?\t ?\n))
	  (delete-char 1))
	 (t
	  (forward-char 1))))
      (buffer-string))))

(defun ietf-drums-get-comment (string)
  "Return the first comment in STRING."
  (with-temp-buffer
    (ietf-drums-init string)
    (let (result c)
      (while (not (eobp))
	(setq c (char-after))
	(cond
	 ((eq c ?\")
	  (forward-sexp 1))
	 ((eq c ?\()
	  (setq result
		(buffer-substring
		 (1+ (point))
		 (progn (forward-sexp 1) (1- (point))))))
	 (t
	  (forward-char 1))))
      result)))

(defun ietf-drums-strip (string)
  "Remove comments and whitespace from STRING."
  (ietf-drums-remove-whitespace (ietf-drums-remove-comments string)))

(defun ietf-drums-parse-address (string)
  "Parse STRING and return a MAILBOX / DISPLAY-NAME pair."
  (with-temp-buffer
    (let (display-name mailbox c display-string)
      (ietf-drums-init string)
      (while (not (eobp))
	(setq c (char-after))
	(cond
	 ((or (eq c ? )
	      (eq c ?\t))
	  (forward-char 1))
	 ((eq c ?\()
	  (forward-sexp 1))
	 ((eq c ?\")
	  (push (buffer-substring
		 (1+ (point)) (progn (forward-sexp 1) (1- (point))))
		display-name))
	 ((looking-at (concat "[" ietf-drums-atext-token "@" "]"))
	  (push (buffer-substring (point) (progn (forward-sexp 1) (point)))
		display-name))
	 ((eq c ?<)
	  (setq mailbox
		(ietf-drums-remove-whitespace
		 (ietf-drums-remove-comments
		  (buffer-substring
		   (1+ (point))
		   (progn (forward-sexp 1) (1- (point))))))))
	 (t (error "Unknown symbol: %c" c))))
      ;; If we found no display-name, then we look for comments.
      (if display-name
	  (setq display-string
		(mapconcat 'identity (reverse display-name) " "))
	(setq display-string (ietf-drums-get-comment string)))
      (if (not mailbox)
	  (when (string-match "@" display-string)
	    (cons
	     (mapconcat 'identity (nreverse display-name) "")
	     (ietf-drums-get-comment string)))
	(cons mailbox display-string)))))

(defun ietf-drums-parse-addresses (string)
  "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."
  (if (null string)
      nil
    (with-temp-buffer
      (ietf-drums-init string)
      (let ((beg (point))
	    pairs c address)
	(while (not (eobp))
	  (setq c (char-after))
	  (cond
	   ((memq c '(?\" ?< ?\())
	    (condition-case nil
		(forward-sexp 1)
	      (error
	       (skip-chars-forward "^,"))))
	   ((eq c ?,)
	    (setq address
		  (condition-case nil
		      (ietf-drums-parse-address
		       (buffer-substring beg (point)))
		    (error nil)))
	    (if address (push address pairs))
	    (forward-char 1)
	    (setq beg (point)))
	   (t
	    (forward-char 1))))
	(setq address
	      (condition-case nil
		  (ietf-drums-parse-address
		   (buffer-substring beg (point)))
		(error nil)))
	(if address (push address pairs))
	(nreverse pairs)))))

(defun ietf-drums-unfold-fws ()
  "Unfold folding white space in the current buffer."
  (goto-char (point-min))
  (while (re-search-forward ietf-drums-fws-regexp nil t)
    (replace-match " " t t))
  (goto-char (point-min)))

(defun ietf-drums-parse-date (string)
  "Return an Emacs time spec from STRING."
  (apply 'encode-time (parse-time-string string)))

(defun ietf-drums-narrow-to-header ()
  "Narrow to the header section in the current buffer."
  (narrow-to-region
   (goto-char (point-min))
   (if (re-search-forward "^\r?$" nil 1)
       (match-beginning 0)
     (point-max)))
  (goto-char (point-min)))

(defun ietf-drums-quote-string (string)
  "Quote string if it needs quoting to be displayed in a header."
  (if (string-match (concat "[^" ietf-drums-atext-token "]") string)
      (concat "\"" string "\"")
    string))

(provide 'ietf-drums)

;;; arch-tag: 379a0191-dbae-4ca6-a0f5-d4202c209ef9
;;; ietf-drums.el ends here
Commit	Line	Data
23f87bed MB	1	;;; ietf-drums.el --- Functions for parsing RFC822bis headers
23f87bed MB	2	;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
c113de23 GM	3	;; 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	;; DRUMS is an IETF Working Group that works (or worked) on the
	26	;; successor to RFC822, "Standard For The Format Of Arpa Internet Text
	27	;; Messages". This library is based on
	28	;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.
	29
23f87bed MB	30	;; Pending a real regression self test suite, Simon Josefsson added
	31	;; various self test expressions snipped from bug reports, and their
	32	;; expected value, below. I you believe it could be useful, please
	33	;; add your own test cases, or write a real self test suite, or just
	34	;; remove this.
	35
	36	;; <m3oekvfd50.fsf@whitebox.m5r.de>
	37	;; (ietf-drums-parse-address "'foo' <foo@example.com>")
	38	;; => ("foo@example.com" . "'foo'")
	39
c113de23 GM	40	;;; Code:
c113de23 GM	41
3b9d5a55	42	(eval-when-compile (require 'cl))
c113de23 GM	43	(require 'time-date)
	44	(require 'mm-util)
	45
	46	(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177"
	47	"US-ASCII control characters excluding CR, LF and white space.")
	48	(defvar ietf-drums-text-token "\001-\011\013\014\016-\177"
8f688cb0	49	"US-ASCII characters excluding CR and LF.")
c113de23 GM	50	(defvar ietf-drums-specials-token "()<>[]:;@\\,.\""
	51	"Special characters.")
	52	(defvar ietf-drums-quote-token "\\"
	53	"Quote character.")
	54	(defvar ietf-drums-wsp-token " \t"
	55	"White space.")
	56	(defvar ietf-drums-fws-regexp
	57	(concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+")
	58	"Folding white space.")
	59	(defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{\|}~"
	60	"Textual token.")
	61	(defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{\|}~."
	62	"Textual token including full stop.")
	63	(defvar ietf-drums-qtext-token
	64	(concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177")
a1506d29	65	"Non-white-space control characters, plus the rest of ASCII excluding
8f688cb0	66	backslash and doublequote.")
c113de23 GM	67	(defvar ietf-drums-tspecials "][()<>@,;:\\\"/?="
	68	"Tspecials.")
	69
	70	(defvar ietf-drums-syntax-table
	71	(let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
	72	(modify-syntax-entry ?\\ "/" table)
	73	(modify-syntax-entry ?< "(" table)
	74	(modify-syntax-entry ?> ")" table)
	75	(modify-syntax-entry ?@ "w" table)
	76	(modify-syntax-entry ?/ "w" table)
23f87bed MB	77	(modify-syntax-entry ?* "_" table)
	78	(modify-syntax-entry ?\; "_" table)
	79	(modify-syntax-entry ?\' "_" table)
	80	(if (featurep 'xemacs)
	81	(let ((i 128))
	82	(while (< i 256)
	83	(modify-syntax-entry i "w" table)
	84	(setq i (1+ i)))))
c113de23 GM	85	table))
	86
	87	(defun ietf-drums-token-to-list (token)
	88	"Translate TOKEN into a list of characters."
	89	(let ((i 0)
	90	b e c out range)
	91	(while (< i (length token))
	92	(setq c (mm-char-int (aref token i)))
	93	(incf i)
	94	(cond
	95	((eq c (mm-char-int ?-))
	96	(if b
	97	(setq range t)
	98	(push c out)))
	99	(range
	100	(while (<= b c)
	101	(push (mm-make-char 'ascii b) out)
	102	(incf b))
	103	(setq range nil))
	104	((= i (length token))
	105	(push (mm-make-char 'ascii c) out))
	106	(t
	107	(when b
	108	(push (mm-make-char 'ascii b) out))
	109	(setq b c))))
	110	(nreverse out)))
	111
	112	(defsubst ietf-drums-init (string)
	113	(set-syntax-table ietf-drums-syntax-table)
	114	(insert string)
	115	(ietf-drums-unfold-fws)
	116	(goto-char (point-min)))
	117
	118	(defun ietf-drums-remove-comments (string)
	119	"Remove comments from STRING."
	120	(with-temp-buffer
	121	(let (c)
	122	(ietf-drums-init string)
	123	(while (not (eobp))
	124	(setq c (char-after))
	125	(cond
	126	((eq c ?\")
	127	(forward-sexp 1))
	128	((eq c ?\()
	129	(delete-region (point) (progn (forward-sexp 1) (point))))
	130	(t
	131	(forward-char 1))))
	132	(buffer-string))))
	133
	134	(defun ietf-drums-remove-whitespace (string)
	135	"Remove whitespace from STRING."
	136	(with-temp-buffer
	137	(ietf-drums-init string)
	138	(let (c)
	139	(while (not (eobp))
	140	(setq c (char-after))
	141	(cond
	142	((eq c ?\")
	143	(forward-sexp 1))
	144	((eq c ?\()
	145	(forward-sexp 1))
8afb8b29	146	((memq c '(?\ ?\t ?\n))
c113de23 GM	147	(delete-char 1))
	148	(t
	149	(forward-char 1))))
	150	(buffer-string))))
	151
	152	(defun ietf-drums-get-comment (string)
	153	"Return the first comment in STRING."
	154	(with-temp-buffer
	155	(ietf-drums-init string)
	156	(let (result c)
	157	(while (not (eobp))
	158	(setq c (char-after))
	159	(cond
	160	((eq c ?\")
	161	(forward-sexp 1))
	162	((eq c ?\()
	163	(setq result
	164	(buffer-substring
	165	(1+ (point))
	166	(progn (forward-sexp 1) (1- (point))))))
	167	(t
	168	(forward-char 1))))
	169	result)))
	170
	171	(defun ietf-drums-strip (string)
	172	"Remove comments and whitespace from STRING."
	173	(ietf-drums-remove-whitespace (ietf-drums-remove-comments string)))
	174
	175	(defun ietf-drums-parse-address (string)
	176	"Parse STRING and return a MAILBOX / DISPLAY-NAME pair."
	177	(with-temp-buffer
	178	(let (display-name mailbox c display-string)
	179	(ietf-drums-init string)
	180	(while (not (eobp))
	181	(setq c (char-after))
	182	(cond
	183	((or (eq c ? )
	184	(eq c ?\t))
	185	(forward-char 1))
	186	((eq c ?\()
	187	(forward-sexp 1))
	188	((eq c ?\")
	189	(push (buffer-substring
	190	(1+ (point)) (progn (forward-sexp 1) (1- (point))))
	191	display-name))
	192	((looking-at (concat "[" ietf-drums-atext-token "@" "]"))
	193	(push (buffer-substring (point) (progn (forward-sexp 1) (point)))
	194	display-name))
	195	((eq c ?<)
	196	(setq mailbox
	197	(ietf-drums-remove-whitespace
	198	(ietf-drums-remove-comments
	199	(buffer-substring
	200	(1+ (point))
	201	(progn (forward-sexp 1) (1- (point))))))))
	202	(t (error "Unknown symbol: %c" c))))
	203	;; If we found no display-name, then we look for comments.
	204	(if display-name
	205	(setq display-string
	206	(mapconcat 'identity (reverse display-name) " "))
	207	(setq display-string (ietf-drums-get-comment string)))
	208	(if (not mailbox)
	209	(when (string-match "@" display-string)
	210	(cons
211	(mapconcat 'identity (nreverse display-name) "")
212	(ietf-drums-get-comment string)))
213	(cons mailbox display-string)))))
214
215	(defun ietf-drums-parse-addresses (string)
216	"Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."
23f87bed MB	217	(if (null string)
	218	nil
	219	(with-temp-buffer
	220	(ietf-drums-init string)
	221	(let ((beg (point))
	222	pairs c address)
	223	(while (not (eobp))
	224	(setq c (char-after))
	225	(cond
	226	((memq c '(?\" ?< ?\())
	227	(condition-case nil
	228	(forward-sexp 1)
	229	(error
	230	(skip-chars-forward "^,"))))
	231	((eq c ?,)
	232	(setq address
	233	(condition-case nil
	234	(ietf-drums-parse-address
	235	(buffer-substring beg (point)))
	236	(error nil)))
	237	(if address (push address pairs))
	238	(forward-char 1)
	239	(setq beg (point)))
	240	(t
	241	(forward-char 1))))
	242	(setq address
	243	(condition-case nil
	244	(ietf-drums-parse-address
	245	(buffer-substring beg (point)))
	246	(error nil)))
	247	(if address (push address pairs))
	248	(nreverse pairs)))))
c113de23 GM	249
	250	(defun ietf-drums-unfold-fws ()
	251	"Unfold folding white space in the current buffer."
	252	(goto-char (point-min))
	253	(while (re-search-forward ietf-drums-fws-regexp nil t)
	254	(replace-match " " t t))
	255	(goto-char (point-min)))
	256
	257	(defun ietf-drums-parse-date (string)
	258	"Return an Emacs time spec from STRING."
	259	(apply 'encode-time (parse-time-string string)))
	260
	261	(defun ietf-drums-narrow-to-header ()
	262	"Narrow to the header section in the current buffer."
	263	(narrow-to-region
	264	(goto-char (point-min))
	265	(if (re-search-forward "^\r?$" nil 1)
	266	(match-beginning 0)
	267	(point-max)))
	268	(goto-char (point-min)))
	269
	270	(defun ietf-drums-quote-string (string)
	271	"Quote string if it needs quoting to be displayed in a header."
	272	(if (string-match (concat "[^" ietf-drums-atext-token "]") string)
	273	(concat "\"" string "\"")
	274	string))
	275
	276	(provide 'ietf-drums)
	277
ab5796a9	278	;;; arch-tag: 379a0191-dbae-4ca6-a0f5-d4202c209ef9
c113de23	279	;;; ietf-drums.el ends here