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.56 1996-08-28 20:32:07 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
 129 (defun rfc822/addr-to-string (seq)
 130   (mapconcat (function
 131               (lambda (token)
 132                 (if (eq (car token) 'spaces)
 133                     ""
 134                   (cdr token)
 135                   )))
 136              seq "")
 137   )
 138
 139 (defun rfc822/address-string (address)
 140   (cond ((eq (car address) 'group)
 141          (mapconcat (function rfc822/address-string)
 142                     (nth 2 address)
 143                     ", ")
 144          )
 145         ((eq (car address) 'mailbox)
 146          (let ((addr (nth 1 address)))
 147            (rfc822/addr-to-string
 148             (if (eq (car addr) 'phrase-route-addr)
 149                 (nth 2 addr)
 150               (cdr addr)
 151               )
 152             )))))
 153
 154 (defun rfc822/full-name-string (address)
 155   (cond ((eq (car address) 'group)
 156          (mapconcat (function
 157                      (lambda (token)
 158                        (cdr token)
 159                        ))
 160                     (nth 1 address) "")
 161          )
 162         ((eq (car address) 'mailbox)
 163          (let ((addr (nth 1 address))
 164                (comment (nth 2 address))
 165                phrase)
 166            (if (eq (car addr) 'phrase-route-addr)
 167                (setq phrase (mapconcat (function
 168                                         (lambda (token)
 169                                           (cdr token)
 170                                           ))
 171                                        (nth 1 addr) ""))
 172              )
 173            (or phrase comment)
 174            ))))
 175
 176 (defun rfc822/extract-address-components (str)
 177   "Extract full name and canonical address from STR.
 178 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 179 If no name can be extracted, FULL-NAME will be nil. [tl-822.el]"
 180   (let* ((structure (car
 181                      (rfc822/parse-address
 182                       (rfc822/lexical-analyze str)
 183                       )))
 184          (phrase  (rfc822/full-name-string structure))
 185          (address (rfc822/address-string structure))
 186          )
 187     (list phrase address)
 188     ))
 189
 190
 191 ;;; @ end
 192 ;;;
 193
 194 (provide 'tl-822)
 195
 196 ;;; tl-822.el ends here