tl-822.el

   1 ;;; tl-822.el --- RFC 822 parser for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
   4
   5 ;; Author:   MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: mail, news, RFC 822
   7
   8 ;; This file is part of tl (Tiny Library).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with This program; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'tl-seq)
  28 (require 'tl-str)
  29 (require 'std11)
  30
  31
  32 (defconst rfc822/RCS-ID
  33   "$Id: tl-822.el,v 7.58 1996-08-28 21:01:01 morioka Exp $")
  34 (defconst rfc822/version (get-version-string rfc822/RCS-ID))
  35
  36
  37 ;;; @ header
  38 ;;;
  39
  40 (defalias 'rfc822/narrow-to-header      'std11-narrow-to-header)
  41 (defalias 'rfc822/get-header-string     'std11-header-string)
  42 (defalias 'rfc822/get-header-string-except 'std11-header-string-except)
  43 (defalias 'rfc822/get-field-names       'std11-collect-field-names)
  44
  45
  46 ;;; @ field
  47 ;;;
  48
  49 (defalias `rfc822/field-end             'std11-field-end)
  50 (defalias 'rfc822/get-field-body        'std11-find-field-body)
  51 (defalias 'rfc822/get-field-bodies      'std11-find-field-bodies)
  52
  53
  54 ;;; @ quoting
  55 ;;;
  56
  57 (defconst rfc822/linear-white-space-regexp "\\(\n?[ \t]\\)+")
  58 (defconst rfc822/quoted-pair-regexp "\\\\.")
  59 (defconst rfc822/non-qtext-char-list '(?\" ?\\ ?\r ?\n))
  60 (defconst rfc822/qtext-regexp
  61   (concat "[^" (char-list-to-string rfc822/non-qtext-char-list) "]"))
  62 (defconst rfc822/quoted-string-regexp
  63   (concat "\""
  64           (regexp-*
  65            (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp)
  66            )
  67           "\""))
  68
  69 (defun rfc822/wrap-as-quoted-string (str)
  70   "Wrap string STR as RFC 822 quoted-string. [tl-822.el]"
  71   (concat "\""
  72           (mapconcat (function
  73                       (lambda (chr)
  74                         (if (memq chr rfc822/non-qtext-char-list)
  75                             (concat "\\" (char-to-string chr))
  76                           (char-to-string chr)
  77                           )
  78                         )) str "")
  79           "\""))
  80
  81 (defun rfc822/strip-quoted-pair (str)
  82   (let ((dest "")
  83         (i 0)
  84         (len (length str))
  85         chr flag)
  86     (while (< i len)
  87       (setq chr (elt str i))
  88       (if (or flag (not (eq chr ?\\)))
  89           (progn
  90             (setq dest (concat dest (char-to-string chr)))
  91             (setq flag nil)
  92             )
  93         (setq flag t)
  94         )
  95       (setq i (+ i 1))
  96       )
  97     dest))
  98
  99 (defun rfc822/strip-quoted-string (str)
 100   (rfc822/strip-quoted-pair
 101    (let ((max (- (length str) 1))
 102          )
 103      (if (and (eq (elt str 0) ?\")
 104               (eq (elt str max) ?\")
 105               )
 106          (substring str 1 max)
 107        str)
 108      )))
 109
 110
 111 ;;; @ unfolding
 112 ;;;
 113
 114 (defalias 'rfc822/unfolding-string 'std11-unfold-string)
 115
 116
 117 ;;; @ lexical analyze
 118 ;;;
 119
 120 (defalias 'rfc822/lexical-analyze 'std11-lexical-analyze)
 121
 122
 123 ;;; @ parser
 124 ;;;
 125
 126 (defalias 'rfc822/parse-address         'std11-parse-address)
 127 (defalias 'rfc822/parse-addresses       'std11-parse-addresses)
 128 (defalias 'rfc822/address-string        'std11-address-string)
 129
 130 (defun rfc822/full-name-string (address)
 131   (cond ((eq (car address) 'group)
 132          (mapconcat (function
 133                      (lambda (token)
 134                        (cdr token)
 135                        ))
 136                     (nth 1 address) "")
 137          )
 138         ((eq (car address) 'mailbox)
 139          (let ((addr (nth 1 address))
 140                (comment (nth 2 address))
 141                phrase)
 142            (if (eq (car addr) 'phrase-route-addr)
 143                (setq phrase (mapconcat (function
 144                                         (lambda (token)
 145                                           (cdr token)
 146                                           ))
 147                                        (nth 1 addr) ""))
 148              )
 149            (or phrase comment)
 150            ))))
 151
 152 (defun rfc822/extract-address-components (string)
 153   "Extract full name and canonical address from STRING.
 154 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 155 If no name can be extracted, FULL-NAME will be nil. [tl-822.el]"
 156   (let* ((structure (car (std11-parse-address-string str)))
 157          (phrase  (rfc822/full-name-string structure))
 158          (address (rfc822/address-string structure))
 159          )
 160     (list phrase address)
 161     ))
 162
 163
 164 ;;; @ end
 165 ;;;
 166
 167 (provide 'tl-822)
 168
 169 ;;; tl-822.el ends here