(defconst rfc822/RCS-ID
- "$Id: tl-822.el,v 7.10 1996-04-19 19:18:30 morioka Exp $")
+ "$Id: tl-822.el,v 7.27 1996-05-22 02:51:33 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)
+ ))))
+
+
;;; @ field
;;;
(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))
(point)
)
-(defun rfc822/get-field-body (name)
+(defun rfc822/get-field-body (name &optional boundary)
(let ((case-fold-search t))
(save-excursion
(save-restriction
- (narrow-to-region
- (goto-char (point-min))
- (or (and (re-search-forward "^$" nil t) (match-end 0))
- (point-max)
- ))
+ (rfc822/narrow-to-header boundary)
(goto-char (point-min))
(if (re-search-forward (concat "^" name ":[ \t]*") nil t)
(buffer-substring-no-properties
))
))))
-
-;;; @ header
-;;;
-
-(defun rfc822/get-header-string-except (pat boundary)
+(defun rfc822/get-field-bodies (field-names &optional default-value boundary)
(let ((case-fold-search t))
(save-excursion
(save-restriction
- (narrow-to-region (goto-char (point-min))
- (progn
- (re-search-forward
- (concat "^\\(" (regexp-quote boundary) "\\)?$")
- nil t)
- (match-beginning 0)
- ))
- (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)
- ))))
+ (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)))))
;;; @ quoting
(eq (elt str 0) ?\()
)
(let ((dest "")
- chr p ret)
+ p ret)
(setq str (substring str 1))
(catch 'tag
(while (not (string-equal str ""))
))))
(defun rfc822/lexical-analyze (str)
- (let (dest
- (i 0)(len (length str))
- ret)
+ (let (dest ret)
(while (not (string-equal str ""))
(setq ret
(or (rfc822/analyze-quoted-string str)
(setq lal (cdr lal))
(setq itl (cons token itl))
)
- (cons (reverse (cons token itl))
+ (cons (nreverse (cons token itl))
(cdr lal))
))
(setq itl (cons token itl))
)
(if (and token
- (setq parsed (reverse (cons token itl)))
+ (setq parsed (nreverse (cons token itl)))
)
(cons parsed (cdr lal))
)))
(setq lal (cdr lal))
(setq itl (cons token itl))
)
- (cons (reverse (cons token itl))
+ (cons (nreverse (cons token itl))
(cdr lal))
))
(defun rfc822/parse-addr-spec (lal)
(let ((ret (rfc822/parse-local-part lal))
- addr at-sign)
+ addr)
(if (and ret
(prog1
(setq addr (cdr (car ret)))
(setq semicolon (car ret))
(string-equal (cdr (assq 'specials semicolon)) ";")
)))
- (cons (list 'group phrase (reverse mbox))
+ (cons (list 'group phrase (nreverse mbox))
(cdr ret)
)
)))
(setq dest (cons (car ret) dest))
(setq lal (cdr ret))
)
- (reverse dest)
+ (nreverse dest)
))))
(defun rfc822/addr-to-string (seq)
", ")
)
((eq (car address) 'mailbox)
- (let ((addr (nth 1 address))
- addr-spec)
+ (let ((addr (nth 1 address)))
(rfc822/addr-to-string
(if (eq (car addr) 'phrase-route-addr)
(nth 2 addr)