/[emacs]/emacs/lisp/gnus/ietf-drums.el
ViewVC logotype

Diff of /emacs/lisp/gnus/ietf-drums.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8.4.1 by handa, Fri Mar 12 00:02:58 2004 UTC revision 1.8.4.2 by miles, Thu Sep 9 09:36:26 2004 UTC
# Line 1  Line 1 
1  ;;; ietf-drums.el --- functions for parsing RFC822bis headers  ;;; ietf-drums.el --- Functions for parsing RFC822bis headers
2  ;; Copyright (C) 1998, 1999, 2000, 2002  ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
3  ;;        Free Software Foundation, Inc.  ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
# Line 27  Line 27 
27  ;; Messages".  This library is based on  ;; Messages".  This library is based on
28  ;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.  ;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.
29    
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    
40  ;;; Code:  ;;; Code:
41    
42  (eval-when-compile (require 'cl))  (eval-when-compile (require 'cl))
# Line 64  backslash and doublequote.") Line 74  backslash and doublequote.")
74      (modify-syntax-entry ?> ")" table)      (modify-syntax-entry ?> ")" table)
75      (modify-syntax-entry ?@ "w" table)      (modify-syntax-entry ?@ "w" table)
76      (modify-syntax-entry ?/ "w" table)      (modify-syntax-entry ?/ "w" table)
77      (modify-syntax-entry ?= " " table)      (modify-syntax-entry ?* "_" table)
78      (modify-syntax-entry ?* " " table)      (modify-syntax-entry ?\; "_" table)
79      (modify-syntax-entry ?\; " " table)      (modify-syntax-entry ?\' "_" table)
80      (modify-syntax-entry ?\' " " table)      (if (featurep 'xemacs)
81            (let ((i 128))
82              (while (< i 256)
83                (modify-syntax-entry i "w" table)
84                (setq i (1+ i)))))
85      table))      table))
86    
87  (defun ietf-drums-token-to-list (token)  (defun ietf-drums-token-to-list (token)
# Line 200  backslash and doublequote.") Line 214  backslash and doublequote.")
214    
215  (defun ietf-drums-parse-addresses (string)  (defun ietf-drums-parse-addresses (string)
216    "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."    "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."
217    (with-temp-buffer    (if (null string)
218      (ietf-drums-init string)        nil
219      (let ((beg (point))      (with-temp-buffer
220            pairs c)        (ietf-drums-init string)
221        (while (not (eobp))        (let ((beg (point))
222          (setq c (char-after))              pairs c address)
223          (cond          (while (not (eobp))
224           ((memq c '(?\" ?< ?\())            (setq c (char-after))
225            (forward-sexp 1))            (cond
226           ((eq c ?,)             ((memq c '(?\" ?< ?\())
227            (push (ietf-drums-parse-address (buffer-substring beg (point)))              (condition-case nil
228                  pairs)                  (forward-sexp 1)
229            (forward-char 1)                (error
230            (setq beg (point)))                 (skip-chars-forward "^,"))))
231           (t             ((eq c ?,)
232            (forward-char 1))))              (setq address
233        (push (ietf-drums-parse-address (buffer-substring beg (point)))                    (condition-case nil
234              pairs)                        (ietf-drums-parse-address
235        (nreverse pairs))))                         (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)))))
249    
250  (defun ietf-drums-unfold-fws ()  (defun ietf-drums-unfold-fws ()
251    "Unfold folding white space in the current buffer."    "Unfold folding white space in the current buffer."

Legend:
Removed from v.1.8.4.1  
changed lines
  Added in v.1.8.4.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26