tl-header.el

   1 ;;;
   2 ;;; $Id: tl-header.el,v 4.5 1994/09/02 07:10:15 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/parse-comment (str)
  70   (if (string-match "^\\s +" str)
  71       (setq str (substring str (match-end 0)))
  72     )
  73   (if (string-match "^([^,]*)" str)
  74       (list (list "(" (substring str 1 (- (match-end 0) 1)) ")")
  75             (substring str (match-end 0))
  76             )
  77     ))
  78
  79 (defun message/parse-address (str)
  80   (let ((ret (or
  81               (message/parse-phrase-route-addr str)
  82               (message/parse-addr-spec str)
  83               ))
  84         n rest type cret)
  85     (if ret
  86         (progn
  87           (setq rest (cdr ret))
  88           (setq cret (message/parse-comment (car rest)))
  89           (if cret
  90               (list (append (car ret) (car cret))
  91                     (cdr cret))
  92             (list (car ret) rest)
  93             )
  94           ))
  95     ))
  96
  97 (defun message/parse-addresses (str)
  98   (let (dest
  99         (ret (message/parse-address str))
 100         rs)
 101     (if ret
 102         (progn
 103           (setq dest (list (car ret)))
 104           (setq rs (car (nth 1 ret)))
 105           (while (and (string-match "^\\s *,\\s *" rs)
 106                       (setq ret (message/parse-address
 107                                  (substring rs (match-end 0))))
 108                       )
 109             (setq dest (append dest (list (car ret))))
 110             (setq rs (car (nth 1 ret)))
 111             )
 112           (if (string-match "^\\s *$" rs)
 113               dest)
 114           ))
 115     ))
 116
 117 (defun message/unfolding-string (str)
 118   (let ((dest ""))
 119     (while (string-match "\n\\s +" str)
 120       (setq dest (concat dest (substring str 0 (match-beginning 0)) " "))
 121       (setq str (substring str (match-end 0)))
 122       )
 123     (concat dest str)
 124     ))
 125
 126 (defun message/strip-quoted-string (str)
 127   (let ((max (- (length str) 1))
 128         )
 129     (if (and (eq (elt str 0) ?\")
 130              (eq (elt str max) ?\")
 131              )
 132         (substring str 1 max)
 133       str)))