tl-header.el

   1 ;;;
   2 ;;; $Id: tl-header.el,v 5.2 1994/12/07 07:29:33 morioka Exp $
   3 ;;;
   4
   5 (provide 'tl-header)
   6
   7 (defconst message/quoted-string-regexp "\"[^\"]*\"")
   8 (defconst message/field-name-regexp "^[!-9;-~]+:")
   9 (defconst message/field-body-regexp ".*\\(\n[ \t].*\\)*")
  10 (defconst message/field-regexp
  11   (concat message/field-name-regexp
  12           message/field-body-regexp))
  13 (defconst message/word-regexp "[!#-'*+0-9=?A-Z^-~---]+")
  14 (defconst message/local-part-regexp
  15   (concat message/word-regexp "\\(\\." message/word-regexp "\\)*"))
  16 (defconst message/domain-regexp (concat "@" message/local-part-regexp))
  17 (defconst message/addr-spec-regexp
  18   (concat message/local-part-regexp "\\(" message/domain-regexp "\\)?"))
  19
  20 (defun message/get-field-body (name)
  21   (save-excursion
  22     (save-restriction
  23       (goto-char (point-min))
  24       (if (re-search-forward (concat "^" name ":[ \t]*") nil t)
  25           (buffer-substring
  26            (match-end 0)
  27            (and (re-search-forward message/field-body-regexp nil t)
  28                 (match-end 0))
  29            )))))
  30
  31 (defun message/divide-field (str)
  32   (let (field-name field-body)
  33     (if (string-match message/field-name-regexp str)
  34         (progn
  35           (setq field-name (substring str 0 (match-end 0)))
  36           (setq field-body (substring str (match-end 0)))
  37           (if (string-match "^[ \t]+" field-body)
  38               (setq field-body (substring field-body (match-end 0)))
  39             )
  40           (list field-name field-body)
  41           ))))
  42
  43 (defun message/parse-addr-spec (str)
  44   (if (string-match "^\\s +" str)
  45       (setq str (substring str (match-end 0)))
  46     )
  47   (if (eq (string-match message/addr-spec-regexp str) 0)
  48       (list (list (substring str 0 (match-end 0)))
  49             (substring str (match-end 0))
  50             )
  51     ))
  52
  53 (defun message/parse-phrase-route-addr (str)
  54   (let ((p (and (string-match "^\\(\".*\"\\|[^,]\\)*<" str)
  55                 (match-end 0)))
  56         phrase ad)
  57     (if (and p
  58              (setq ad (message/parse-addr-spec (substring str p)))
  59              (eq (elt (nth 1 ad) 0) ?>))
  60         (list (list (substring str 0 (- p 1))
  61                     "<"
  62                     (car (car ad))
  63                     ">")
  64               (substring (nth 1 ad) 1)
  65               )
  66       nil)
  67     ))
  68
  69 (defun message::match-ctexts (str)
  70   (if (string-match "^[^()\\\\]+" str)
  71       (let ((e (match-end 0)))
  72         (list (substring str 0 e)(substring str e))
  73         )))
  74
  75 (defun message::match-comment (str)
  76   (catch 'tag
  77     (if (and (>= (length str) 2)
  78              (= (elt str 0) ?\()
  79              )
  80         (let ((dest "") ret)
  81           (setq str (substring str 1))
  82           (while (cond ((string= str "")
  83                         (throw 'tag nil)
  84                         )
  85                        ((not (= (elt str 0) ?\)))
  86                         (setq ret (or (message::match-ctexts str)
  87                                       (message::match-comment str)
  88                                       ))
  89                         ))
  90             (setq dest (concat dest (car ret)))
  91             (setq str (nth 1 ret))
  92             )
  93           (if (= (elt str 0) ?\))
  94               (list (concat "(" dest ")") (substring str 1))
  95             )
  96           ))))
  97
  98 (defun message/parse-comment (str)
  99   (if (string-match "^\\s +" str)
 100       (setq str (substring str (match-end 0)))
 101     )
 102   (let ((ret (message::match-comment str)))
 103     (if ret
 104         (list (list "(" (substring (car ret) 1 (- (length (car ret)) 1))
 105                     ")")
 106               (nth 1 ret)
 107               )
 108       )))
 109
 110 (defun message/parse-address (str)
 111   (let ((ret (or
 112               (message/parse-phrase-route-addr str)
 113               (message/parse-addr-spec str)
 114               ))
 115         n rest type cret)
 116     (if ret
 117         (progn
 118           (setq rest (cdr ret))
 119           (setq cret (message/parse-comment (car rest)))
 120           (if cret
 121               (list (append (car ret) (car cret))
 122                     (cdr cret))
 123             (list (car ret) rest)
 124             )
 125           ))
 126     ))
 127
 128 (defun message/parse-addresses (str)
 129   (let (dest
 130         (ret (message/parse-address str))
 131         rs)
 132     (if ret
 133         (progn
 134           (setq dest (list (car ret)))
 135           (setq rs (car (nth 1 ret)))
 136           (while (and (string-match "^\\s *,\\s *" rs)
 137                       (setq ret (message/parse-address
 138                                  (substring rs (match-end 0))))
 139                       )
 140             (setq dest (append dest (list (car ret))))
 141             (setq rs (car (nth 1 ret)))
 142             )
 143           (if (string-match "^\\s *$" rs)
 144               dest)
 145           ))
 146     ))
 147
 148 (defun message/unfolding-string (str)
 149   (let ((dest ""))
 150     (while (string-match "\n\\s +" str)
 151       (setq dest (concat dest (substring str 0 (match-beginning 0)) " "))
 152       (setq str (substring str (match-end 0)))
 153       )
 154     (concat dest str)
 155     ))
 156
 157 (defun message/strip-quoted-string (str)
 158   (let ((max (- (length str) 1))
 159         )
 160     (if (and (eq (elt str 0) ?\")
 161              (eq (elt str max) ?\")
 162              )
 163         (substring str 1 max)
 164       str)))