-;;;
;;; tl-822.el --- RFC 822 parser for GNU Emacs
-;;;
-;;; Copyright (C) 1995 Free Software Foundation, Inc.
-;;; Copyright (C) 1995,1996 MORIOKA Tomohiko
-;;;
-;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;;; Keywords: mail, news, RFC 822
-;;;
-;;; 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.
-;;;
+
+;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: mail, news, RFC 822
+
+;; 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; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
;;; Code:
(require 'tl-seq)
(require 'tl-str)
+(require 'std11)
(defconst rfc822/RCS-ID
- "$Id: tl-822.el,v 7.27 1996-05-22 02:51:33 morioka Exp $")
+ "$Id: tl-822.el,v 7.49 1996-08-28 17:06:26 morioka Exp $")
(defconst rfc822/version (get-version-string rfc822/RCS-ID))
;;; @ header
;;;
-(defun rfc822/narrow-to-header (&optional boundary)
- (narrow-to-region (goto-char (point-min))
- (if (re-search-forward
- (concat "^\\(" (regexp-quote
- (or boundary "")) "\\)?$") nil t)
- (match-beginning 0)
- (point-max)
- )))
-
-(defun rfc822/get-header-string (pat &optional boundary)
- (let ((case-fold-search t))
- (save-excursion
- (save-restriction
- (rfc822/narrow-to-header boundary)
- (goto-char (point-min))
- (let (field header)
- (while (re-search-forward rfc822/field-top-regexp nil t)
- (setq field (buffer-substring (match-beginning 0)
- (rfc822/field-end)
- ))
- (if (string-match pat field)
- (setq header (concat header field "\n"))
- ))
- header)
- ))))
-
-(defun rfc822/get-header-string-except (pat &optional boundary)
- (let ((case-fold-search t))
- (save-excursion
- (save-restriction
- (rfc822/narrow-to-header boundary)
- (goto-char (point-min))
- (let (field header)
- (while (re-search-forward rfc822/field-top-regexp nil t)
- (setq field (buffer-substring (match-beginning 0)
- (rfc822/field-end)
- ))
- (if (not (string-match pat field))
- (setq header (concat header field "\n"))
- ))
- header)
- ))))
+(defalias 'rfc822/narrow-to-header 'std11-narrow-to-header)
+(defalias 'rfc822/get-header-string 'std11-header-string)
+(defalias 'rfc822/get-header-string-except 'std11-header-string-except)
+(defalias 'rfc822/get-field-names 'std11-collect-field-names)
;;; @ field
;;;
-(defconst rfc822/field-name-regexp "[!-9;-~]+")
-
-(defconst rfc822/field-top-regexp
- (concat "\\(" rfc822/field-name-regexp "\\):"))
-
-(defconst rfc822::next-field-top-regexp (concat "\n" rfc822/field-top-regexp))
-
-(defun rfc822/get-field-names (&optional boundary)
- (save-excursion
- (save-restriction
- (rfc822/narrow-to-header boundary)
- (goto-char (point-min))
- (let ((pat (concat "^\\(" rfc822/field-name-regexp "\\):"))
- dest name)
- (while (re-search-forward pat nil t)
- (setq name (buffer-substring (match-beginning 1)(match-end 1)))
- (or (member name dest)
- (setq dest (cons name dest))
- )
- )
- dest))))
-
-(defun rfc822/field-end ()
- (if (re-search-forward rfc822::next-field-top-regexp nil t)
- (goto-char (match-beginning 0))
- (if (re-search-forward "^$" nil t)
- (goto-char (1- (match-beginning 0)))
- (end-of-line)
- ))
- (point)
- )
-
-(defun rfc822/get-field-body (name &optional boundary)
- (let ((case-fold-search t))
- (save-excursion
- (save-restriction
- (rfc822/narrow-to-header boundary)
- (goto-char (point-min))
- (if (re-search-forward (concat "^" name ":[ \t]*") nil t)
- (buffer-substring-no-properties
- (match-end 0)
- (rfc822/field-end)
- ))
- ))))
-
-(defun rfc822/get-field-bodies (field-names &optional default-value boundary)
- (let ((case-fold-search t))
- (save-excursion
- (save-restriction
- (rfc822/narrow-to-header boundary)
- (let* ((dest (make-list (length field-names) default-value))
- (s-rest field-names)
- (d-rest dest)
- field-name)
- (while (setq field-name (car s-rest))
- (goto-char (point-min))
- (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
- (setcar d-rest
- (buffer-substring-no-properties
- (match-end 0)
- (rfc822/field-end))))
- (setq s-rest (cdr s-rest)
- d-rest (cdr d-rest))
- )
- dest)))))
+(defalias `rfc822/field-end 'std11-field-end)
+(defalias 'rfc822/get-field-body 'std11-find-field-body)
+(defalias 'rfc822/get-field-bodies 'std11-find-field-bodies)
;;; @ quoting
(defconst rfc822/quoted-pair-regexp "\\\\.")
(defconst rfc822/non-qtext-char-list '(?\" ?\\ ?\r ?\n))
(defconst rfc822/qtext-regexp
- (concat "[^" (char-list-to-string rfc822/non-qtext-char-list) " \t]"))
+ (concat "[^" (char-list-to-string rfc822/non-qtext-char-list) "]"))
(defconst rfc822/quoted-string-regexp
(concat "\""
(regexp-*
- (concat
- "\\(" rfc822/linear-white-space-regexp "?"
- (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp)
- "\\)"))
- rfc822/linear-white-space-regexp "?"
+ (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp)
+ )
"\""))
(defun rfc822/wrap-as-quoted-string (str)
;;; @ unfolding
;;;
-(defun rfc822/unfolding-string (str)
- (let ((dest ""))
- (while (string-match "\n\\s +" str)
- (setq dest (concat dest (substring str 0 (match-beginning 0)) " "))
- (setq str (substring str (match-end 0)))
- )
- (concat dest str)
- ))
+(defalias 'rfc822/unfolding-string 'std11-unfold-string)
;;; @ lexical analyze
(defconst rfc822/space-chars " \t\n")
(defconst rfc822/non-atom-chars
(concat rfc822/special-chars rfc822/space-chars))
-(defconst rfc822/non-dtext-chars "[]")
+(defconst rfc822/non-dtext-chars "][")
(defconst rfc822/non-ctext-chars "()")
-(defun rfc822/analyze-spaces (str)
- (let ((i (position-mismatched
- (function
- (lambda (elt)
- (find elt rfc822/space-chars)
- )) str))
- )
- (if (> i 0)
- (cons (cons 'spaces (substring str 0 i))
- (substring str i)
- ))
- ))
-
-(defun rfc822/analyze-special (str)
- (if (and (> (length str) 0)
- (find (elt str 0) rfc822/special-chars)
- )
- (cons (cons 'specials (substring str 0 1))
- (substring str 1)
- ))
- )
+(defalias 'rfc822/analyze-spaces 'std11-analyze-spaces)
+(defalias 'rfc822/analyze-special 'std11-analyze-special)
(defun rfc822/analyze-atom (str)
- (let ((i (position-mismatched
- (function
- (lambda (elt)
- (not (find elt rfc822/non-atom-chars))
- )) str))
- )
- (if (> i 0)
- (cons (cons 'atom (substring str 0 i))
- (substring str i)
- ))
- ))
-
-(defun rfc822/analyze-quoted-pair (str)
- (if (and (>= (length str) 2)
- (eq (elt str 0) ?\\)
- )
- (cons (cons 'quoted-pair (substring str 0 2))
- (substring str 2)
- ))
- )
+ (let ((i (string-match (concat "[" rfc822/non-atom-chars "]") str)))
+ (if i
+ (if (> i 0)
+ (cons (cons 'atom (substring str 0 i))
+ (substring str i)
+ ))
+ (if (not (string-equal str ""))
+ (cons (cons 'spaces str) "")
+ ))))
(defun rfc822/analyze-quoted-string (str)
- (if (and (> (length str) 0)
- (eq (elt str 0) ?\")
- )
- (let* ((i (position-mismatched
- (function
- (lambda (elt)
- (not (memq elt rfc822/non-qtext-char-list))
- ))
- (setq str (substring str 1))
- ))
- (rest (substring str i))
+ (let ((len (length str)))
+ (if (and (> len 0)
+ (eq (elt str 0) ?\")
)
- (if (and (> i 0)
- (> (length rest) 0)
- (eq (elt rest 0) ?\")
- )
- (cons (cons 'quoted-string (substring str 0 i))
- (substring rest 1)
- )
- ))))
+ (let ((i 1) chr dest)
+ (catch 'tag
+ (while (< i len)
+ (setq chr (aref str i))
+ (cond ((eq chr ?\\)
+ (setq i (1+ i))
+ (if (>= i len)
+ (throw 'tag nil)
+ )
+ (setq dest (concat dest (char-to-string (aref str i))))
+ )
+ ((eq chr ?\")
+ (throw 'tag
+ (cons (cons 'quoted-string dest)
+ (substring str (1+ i)))
+ )
+ )
+ (t
+ (setq dest (concat dest (char-to-string (aref str i))))
+ ))
+ (setq i (1+ i))
+ ))))))
(defun rfc822/analyze-domain-literal (str)
(if (and (> (length str) 0)
- (eq (elt str 0) ?\[)
+ (eq (aref str 0) ?\[)
)
- (let* ((i (position-mismatched
- (function
- (lambda (elt)
- (not (find elt rfc822/non-dtext-chars))
- ))
- (setq str (substring str 1))
- ))
- (rest (substring str i))
+ (let* ((i (string-match (concat "[" rfc822/non-dtext-chars "]") str 1))
+ (rest (and i (substring str i)))
)
- (if (and (> i 0)
+ (if (and i
(> (length rest) 0)
- (eq (elt rest 0) ?\])
+ (eq (aref rest 0) ?\])
)
- (cons (cons 'domain-literal (substring str 0 i))
+ (cons (cons 'domain-literal (substring str 1 i))
(substring rest 1)
)
))))
(setq str (substring str 1))
(catch 'tag
(while (not (string-equal str ""))
- (setq p (position-mismatched
- (function
- (lambda (elt)
- (not (find elt rfc822/non-ctext-chars))
- )) str))
+ (setq p (string-match (concat "[" rfc822/non-ctext-chars "]") str))
(cond ((> p 0)
(setq dest (concat dest (substring str 0 p)))
(setq str (substring str p))
projects / elisp / mu-cite.git / blobdiff