;;; tl-822.el --- RFC 822 parser for GNU Emacs
;;;
;;; Copyright (C) 1995 Free Software Foundation, Inc.
-;;; Copyright (C) 1995 MORIOKA Tomohiko
+;;; Copyright (C) 1995,1996 MORIOKA Tomohiko
;;;
;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
;;; Keywords: mail, news, RFC 822
;;;
-;;; This file is part of tm (Tools for MIME).
+;;; This file is part of tl (Tiny Library).
;;;
+;;; This program 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.
+;;;
+;;; This program 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 This program. If not, write to the Free Software
+;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;
+;;; Code:
(require 'tl-seq)
(require 'tl-str)
(defconst rfc822/RCS-ID
- "$Id: tl-822.el,v 7.0 1995-11-16 11:11:56 morioka Exp $")
+ "$Id: tl-822.el,v 7.6 1996-03-25 10:21:25 morioka Exp $")
(defconst rfc822/version (get-version-string rfc822/RCS-ID))
(defconst rfc822/linear-white-space-regexp "\\(\n?[ \t]\\)+")
(defconst rfc822/quoted-pair-regexp "\\\\.")
-(defconst rfc822/qtext-regexp "[^\"\\\n\t \t]")
+(defconst rfc822/non-qtext-char-list '(?\" ?\\ ?\r ?\n))
+(defconst rfc822/qtext-regexp
+ (concat "[^" (char-list-to-string rfc822/non-qtext-char-list) " \t]"))
(defconst rfc822/quoted-string-regexp
(concat "\""
(regexp-*
rfc822/linear-white-space-regexp "?"
"\""))
+(defun rfc822/wrap-as-quoted-string (str)
+ "Wrap string STR as RFC 822 quoted-string. [tl-822.el]"
+ (concat "\""
+ (mapconcat (function
+ (lambda (chr)
+ (if (memq chr rfc822/non-qtext-char-list)
+ (concat "\\" (char-to-string chr))
+ (char-to-string chr)
+ )
+ )) str "")
+ "\""))
+
(defun rfc822/strip-quoted-pair (str)
(let ((dest "")
(i 0)
(defconst rfc822/space-chars " \t\n")
(defconst rfc822/non-atom-chars
(concat rfc822/special-chars rfc822/space-chars))
-(defconst rfc822/non-qtext-chars "\"")
(defconst rfc822/non-dtext-chars "[]")
(defconst rfc822/non-ctext-chars "()")
(let* ((i (position-mismatched
(function
(lambda (elt)
- (not (find elt rfc822/non-qtext-chars))
+ (not (memq elt rfc822/non-qtext-char-list))
))
(setq str (substring str 1))
))
(cdr lal))
))
+(defun rfc822/parse-ascii-token (lal)
+ (let (token itl parsed)
+ (while (and lal
+ (setq token (car lal))
+ (if (find-charset-string (cdr token))
+ (setq token nil)
+ (rfc822/ignored-token-p token)
+ ))
+ (setq lal (cdr lal))
+ (setq itl (cons token itl))
+ )
+ (if (and token
+ (setq parsed (reverse (cons token itl)))
+ )
+ (cons parsed (cdr lal))
+ )))
+
(defun rfc822/parse-token-or-comment (lal)
(let (token itl)
(while (and lal
))
(defun rfc822/parse-word (lal)
- (let ((ret (rfc822/parse-token lal)))
+ (let ((ret (rfc822/parse-ascii-token lal)))
(if ret
(let ((elt (car ret))
(rest (cdr ret))
(if ret
(let ((local-part (cdr (car ret))) dot)
(setq lal (cdr ret))
- (while (and (setq ret (rfc822/parse-token lal))
+ (while (and (setq ret (rfc822/parse-ascii-token lal))
(setq dot (car ret))
- (equal (cdr (assq 'specials dot)) ".")
+ (string-equal (cdr (assq 'specials dot)) ".")
(setq ret (rfc822/parse-word (cdr ret)))
(setq local-part
(append local-part dot (cdr (car ret)))
))))
(defun rfc822/parse-sub-domain (lal)
- (let ((ret (rfc822/parse-token lal)))
+ (let ((ret (rfc822/parse-ascii-token lal)))
(if ret
(let ((sub-domain (car ret)))
(if (or (assq 'atom sub-domain)
(if ret
(let ((domain (cdr (car ret))) dot)
(setq lal (cdr ret))
- (while (and (setq ret (rfc822/parse-token lal))
+ (while (and (setq ret (rfc822/parse-ascii-token lal))
(setq dot (car ret))
- (equal (cdr (assq 'specials dot)) ".")
+ (string-equal (cdr (assq 'specials dot)) ".")
(setq ret (rfc822/parse-sub-domain (cdr ret)))
(setq domain
(append domain dot (cdr (car ret)))
))))
(defun rfc822/parse-at-domain (lal)
- (let ((ret (rfc822/parse-token lal)) at-sign)
+ (let ((ret (rfc822/parse-ascii-token lal)) at-sign)
(if (and ret
(setq at-sign (car ret))
- (equal (cdr (assq 'specials at-sign)) "@")
+ (string-equal (cdr (assq 'specials at-sign)) "@")
(setq ret (rfc822/parse-domain (cdr ret)))
)
(cons (cons 'at-domain (append at-sign (cdr (car ret))))
(progn
(setq route (cdr (car ret)))
(setq lal (cdr ret))
- (while (and (setq ret (rfc822/parse-token lal))
+ (while (and (setq ret (rfc822/parse-ascii-token lal))
(setq comma (car ret))
- (equal (cdr (assq 'specials comma)) ",")
+ (string-equal (cdr (assq 'specials comma)) ",")
(setq ret (rfc822/parse-at-domain (cdr ret)))
)
(setq route (append route comma (cdr (car ret))))
(setq lal (cdr ret))
)
- (and (setq ret (rfc822/parse-token lal))
+ (and (setq ret (rfc822/parse-ascii-token lal))
(setq colon (car ret))
- (equal (cdr (assq 'specials colon)) ":")
+ (string-equal (cdr (assq 'specials colon)) ":")
(setq route (append route colon))
)
))
)))
(defun rfc822/parse-route-addr (lal)
- (let ((ret (rfc822/parse-token lal))
+ (let ((ret (rfc822/parse-ascii-token lal))
< route addr-spec >)
(if (and ret
(setq < (car ret))
- (equal (cdr (assq 'specials <)) "<")
+ (string-equal (cdr (assq 'specials <)) "<")
(setq lal (cdr ret))
(progn (and (setq ret (rfc822/parse-route lal))
(setq route (cdr (car ret)))
)
(setq addr-spec (cdr (car ret)))
(setq lal (cdr ret))
- (setq ret (rfc822/parse-token lal))
+ (setq ret (rfc822/parse-ascii-token lal))
(setq > (car ret))
- (equal (cdr (assq 'specials >)) ">")
+ (string-equal (cdr (assq 'specials >)) ">")
)
(cons (cons 'route-addr (append route addr-spec))
(cdr ret)
(if (and ret
(setq phrase (cdr (car ret)))
(setq lal (cdr ret))
- (setq ret (rfc822/parse-token lal))
+ (setq ret (rfc822/parse-ascii-token lal))
(setq colon (car ret))
- (equal (cdr (assq 'specials colon)) ":")
+ (string-equal (cdr (assq 'specials colon)) ":")
(setq lal (cdr ret))
(progn
(and (setq ret (rfc822/parse-mailbox lal))
(setq mbox (list (car ret)))
(setq lal (cdr ret))
(progn
- (while (and (setq ret (rfc822/parse-token lal))
+ (while (and (setq ret (rfc822/parse-ascii-token lal))
(setq comma (car ret))
- (equal (cdr (assq 'specials comma)) ",")
+ (string-equal
+ (cdr (assq 'specials comma)) ",")
(setq lal (cdr ret))
(setq ret (rfc822/parse-mailbox lal))
(setq mbox (cons (car ret) mbox))
(setq lal (cdr ret))
)
)))
- (and (setq ret (rfc822/parse-token lal))
+ (and (setq ret (rfc822/parse-ascii-token lal))
(setq semicolon (car ret))
- (equal (cdr (assq 'specials semicolon)) ";")
+ (string-equal (cdr (assq 'specials semicolon)) ";")
)))
(cons (list 'group phrase (reverse mbox))
(cdr ret)
(if ret
(let ((dest (list (car ret))))
(setq lal (cdr ret))
- (while (and (setq ret (rfc822/parse-token lal))
- (equal (cdr (assq 'specials (car ret))) ",")
+ (while (and (setq ret (rfc822/parse-ascii-token lal))
+ (string-equal (cdr (assq 'specials (car ret))) ",")
(setq ret (rfc822/parse-address (cdr ret)))
)
(setq dest (cons (car ret) dest))
(or phrase comment)
)))
+(defun rfc822/extract-address-components (str)
+ "Extract full name and canonical address from STR.
+Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
+If no name can be extracted, FULL-NAME will be nil. [tl-822.el]"
+ (let* ((structure (car
+ (rfc822/parse-address
+ (rfc822/lexical-analyze str)
+ )))
+ (phrase (rfc822/full-name-string structure))
+ (address (rfc822/address-string structure))
+ )
+ (list phrase address)
+ ))
+
;;; @ end
;;;
(provide 'tl-822)
+
+;;; tl-822.el ends here
projects / elisp / mu-cite.git / blobdiff