Import Oort Gnus v0.11.

[elisp/gnus.git-] / lisp / ietf-drums.el

diff --git a/lisp/ietf-drums.el b/lisp/ietf-drums.el
index 2ef7d61..ae97c7e 100644 (file)
--- a/lisp/ietf-drums.el
+++ b/lisp/ietf-drums.el
@@ -1,5 +1,6 @@
 ;;; ietf-drums.el --- Functions for parsing RFC822bis headers
-;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002
+;;        Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.
@@ -28,13 +29,14 @@
 
 ;;; 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 exlcuding CR and LF.")
+  "US-ASCII characters excluding CR and LF.")
 (defvar ietf-drums-specials-token "()<>[]:;@\\,.\""
   "Special characters.")
 (defvar ietf-drums-quote-token "\\"
@@ -50,7 +52,8 @@
   "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 characaters, plus the rest of ASCII excluding backslash and doublequote.")
+  "Non-white-space control characters, plus the rest of ASCII excluding 
+backslash and doublequote.")
 (defvar ietf-drums-tspecials "][()<>@,;:\\\"/?="
   "Tspecials.")
 
@@ -65,6 +68,11 @@
     (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)
@@ -87,6 +95,8 @@
        ((= 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)))
 
@@ -102,7 +112,7 @@
     (let (c)
       (ietf-drums-init string)
       (while (not (eobp))
-       (setq c (following-char))
+       (setq c (char-after))
        (cond
         ((eq c ?\")
          (forward-sexp 1))
@@ -113,12 +123,12 @@
       (buffer-string))))
 
 (defun ietf-drums-remove-whitespace (string)
-  "Remove comments from STRING."
+  "Remove whitespace from STRING."
   (with-temp-buffer
     (ietf-drums-init string)
     (let (c)
       (while (not (eobp))
-       (setq c (following-char))
+       (setq c (char-after))
        (cond
         ((eq c ?\")
          (forward-sexp 1))
@@ -136,7 +146,7 @@
     (ietf-drums-init string)
     (let (result c)
       (while (not (eobp))
-       (setq c (following-char))
+       (setq c (char-after))
        (cond
         ((eq c ?\")
          (forward-sexp 1))
@@ -149,13 +159,17 @@
          (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 (following-char))
+       (setq c (char-after))
        (cond
         ((or (eq c ? )
              (eq c ?\t))
@@ -191,25 +205,38 @@
 
 (defun ietf-drums-parse-addresses (string)
   "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."
-  (with-temp-buffer
-    (ietf-drums-init string)
-    (let ((beg (point))
-         pairs c)
-      (while (not (eobp))
-       (setq c (following-char))
-       (cond
-        ((memq c '(?\" ?< ?\())
-         (forward-sexp 1))
-        ((eq c ?,)
-         (push (ietf-drums-parse-address (buffer-substring beg (point)))
-               pairs)
-         (forward-char 1)
-         (setq beg (point)))
-        (t
-         (forward-char 1))))
-      (push (ietf-drums-parse-address (buffer-substring beg (point)))
-           pairs)
-      (nreverse 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."
@@ -226,8 +253,8 @@
   "Narrow to the header section in the current buffer."
   (narrow-to-region
    (goto-char (point-min))
-   (if (search-forward "\n\n" nil 1)
-       (1- (point))
+   (if (re-search-forward "^\r?$" nil 1)
+       (match-beginning 0)
      (point-max)))
   (goto-char (point-min)))