X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=tl-822.el;h=0b9f584abab1cfd3936f3a8b65c2e5e9e17ed101;hb=4ecf47ab6e3e510b05dc00b6f2155283ecb189e1;hp=185945c91cbbbb2ed6c171b49f6ac7271e9f62ab;hpb=bb1564b4cb9bc0569dbb590d79b1ac0f9df9ddf5;p=elisp%2Fmu-cite.git diff --git a/tl-822.el b/tl-822.el index 185945c..0b9f584 100644 --- a/tl-822.el +++ b/tl-822.el @@ -30,10 +30,57 @@ (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 ;;; @@ -44,6 +91,21 @@ (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)) @@ -54,15 +116,11 @@ (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 @@ -71,32 +129,26 @@ )) )))) - -;;; @ 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 @@ -275,7 +327,7 @@ (eq (elt str 0) ?\() ) (let ((dest "") - chr p ret) + p ret) (setq str (substring str 1)) (catch 'tag (while (not (string-equal str "")) @@ -304,9 +356,7 @@ )))) (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) @@ -342,7 +392,7 @@ (setq lal (cdr lal)) (setq itl (cons token itl)) ) - (cons (reverse (cons token itl)) + (cons (nreverse (cons token itl)) (cdr lal)) )) @@ -360,7 +410,7 @@ (setq itl (cons token itl)) ) (if (and token - (setq parsed (reverse (cons token itl))) + (setq parsed (nreverse (cons token itl))) ) (cons parsed (cdr lal)) ))) @@ -375,7 +425,7 @@ (setq lal (cdr lal)) (setq itl (cons token itl)) ) - (cons (reverse (cons token itl)) + (cons (nreverse (cons token itl)) (cdr lal)) )) @@ -474,7 +524,7 @@ (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))) @@ -596,7 +646,7 @@ (setq semicolon (car ret)) (string-equal (cdr (assq 'specials semicolon)) ";") ))) - (cons (list 'group phrase (reverse mbox)) + (cons (list 'group phrase (nreverse mbox)) (cdr ret) ) ))) @@ -618,7 +668,7 @@ (setq dest (cons (car ret) dest)) (setq lal (cdr ret)) ) - (reverse dest) + (nreverse dest) )))) (defun rfc822/addr-to-string (seq) @@ -638,8 +688,7 @@ ", ") ) ((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)