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