X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fietf-drums.el;h=c0e1542fa823480536910494fcc1e5c88a8647bc;hb=HEAD;hp=865ddffaaccd3ba96fd28613e963f1b4db04a3c1;hpb=7140fbf33061efeae72c71509fca0abfba457933;p=gnus diff --git a/lisp/ietf-drums.el b/lisp/ietf-drums.el index 865ddffaa..c0e1542fa 100644 --- a/lisp/ietf-drums.el +++ b/lisp/ietf-drums.el @@ -1,23 +1,22 @@ ;;; ietf-drums.el --- Functions for parsing RFC822bis headers -;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; the Free Software Foundation, either version 3 of the License, 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 +;; 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. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -26,15 +25,25 @@ ;; 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. + +;; +;; (ietf-drums-parse-address "'foo' ") +;; => ("foo@example.com" . "'foo'") + ;;; Code: -(require 'time-date) +(eval-when-compile (require 'cl)) (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 +59,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.") @@ -61,10 +71,14 @@ (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) - (modify-syntax-entry ?\' " " 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) @@ -81,12 +95,14 @@ (push c out))) (range (while (<= b c) - (push (mm-make-char 'ascii b) out) + (push (make-char 'ascii b) out) (incf b)) (setq range nil)) ((= i (length token)) - (push (mm-make-char 'ascii c) out)) + (push (make-char 'ascii c) out)) (t + (when b + (push (make-char 'ascii b) out)) (setq b c)))) (nreverse out))) @@ -105,15 +121,24 @@ (setq c (char-after)) (cond ((eq c ?\") - (forward-sexp 1)) + (condition-case nil + (forward-sexp 1) + (error (goto-char (point-max))))) ((eq c ?\() - (delete-region (point) (progn (forward-sexp 1) (point)))) + (delete-region + (point) + (condition-case nil + (with-syntax-table (copy-syntax-table ietf-drums-syntax-table) + (modify-syntax-entry ?\" "w") + (forward-sexp 1) + (point)) + (error (point-max))))) (t (forward-char 1)))) (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) @@ -124,7 +149,7 @@ (forward-sexp 1)) ((eq c ?\() (forward-sexp 1)) - ((memq c '(? ?\t ?\n)) + ((memq c '(?\ ?\t ?\n)) (delete-char 1)) (t (forward-char 1)))) @@ -149,6 +174,10 @@ (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 @@ -176,40 +205,61 @@ (buffer-substring (1+ (point)) (progn (forward-sexp 1) (1- (point)))))))) - (t (error "Unknown symbol: %c" c)))) + (t + (forward-char 1)))) ;; 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) + (when (and display-string + (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." - (with-temp-buffer - (ietf-drums-init string) - (let ((beg (point)) - pairs c) - (while (not (eobp)) - (setq c (char-after)) - (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)))) +(defun ietf-drums-parse-addresses (string &optional rawp) + "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs. +If RAWP, don't actually parse the addresses, but instead return +a list of address strings." + (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 + (if rawp + (buffer-substring beg (point)) + (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 + (if rawp + (buffer-substring beg (point)) + (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 +276,8 @@ "Narrow to the header section in the current buffer." (narrow-to-region (goto-char (point-min)) - (if (re-search-forward "^\n" nil 1) - (1- (point)) + (if (re-search-forward "^\r?$" nil 1) + (match-beginning 0) (point-max))) (goto-char (point-min))) @@ -237,6 +287,11 @@ (concat "\"" string "\"") string)) +(defun ietf-drums-make-address (name address) + (if name + (concat (ietf-drums-quote-string name) " <" address ">") + address)) + (provide 'ietf-drums) ;;; ietf-drums.el ends here