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.53 1996-08-28 18:07:50 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 (defconst rfc822/non-ctext-chars "()")
 121
 122 (defalias 'rfc822/analyze-spaces        'std11-analyze-spaces)
 123 (defalias 'rfc822/analyze-special       'std11-analyze-special)
 124 (defalias 'rfc822/analyze-atom          'std11-analyze-atom)
 125 (defalias 'rfc822/analyze-quoted-string 'std11-analyze-quoted-string)
 126 (defalias 'rfc822/analyze-domain-literal 'std11-analyze-domain-literal)
 127 (defalias 'rfc822/analyze-comment       'std11-analyze-comment)
 128
 129 (defun rfc822/lexical-analyze (str)
 130   (let (dest ret)
 131     (while (not (string-equal str ""))
 132       (setq ret
 133             (or (rfc822/analyze-quoted-string str)
 134                 (rfc822/analyze-domain-literal str)
 135                 (rfc822/analyze-comment str)
 136                 (rfc822/analyze-spaces str)
 137                 (rfc822/analyze-special str)
 138                 (rfc822/analyze-atom str)
 139                 '((error) . "")
 140                 ))
 141       (setq dest (cons (car ret) dest))
 142       (setq str (cdr ret))
 143       )
 144     (nreverse dest)
 145     ))
 146
 147
 148 ;;; @ parser
 149 ;;;
 150
 151 (defun rfc822/ignored-token-p (token)
 152   (let ((type (car token)))
 153     (or (eq type 'spaces)(eq type 'comment))
 154     ))
 155
 156 (defun rfc822/parse-token (lal)
 157   (let (token itl)
 158     (while (and lal
 159                 (progn
 160                   (setq token (car lal))
 161                   (rfc822/ignored-token-p token)
 162                   ))
 163       (setq lal (cdr lal))
 164       (setq itl (cons token itl))
 165       )
 166     (cons (nreverse (cons token itl))
 167           (cdr lal))
 168     ))
 169
 170 (defun rfc822/parse-ascii-token (lal)
 171   (let (token itl parsed token-value)
 172     (while (and lal
 173                 (setq token (car lal))
 174                 (if (and (setq token-value (cdr token))
 175                          (find-charset-string token-value)
 176                          )
 177                     (setq token nil)
 178                   (rfc822/ignored-token-p token)
 179                   ))
 180       (setq lal (cdr lal))
 181       (setq itl (cons token itl))
 182       )
 183     (if (and token
 184              (setq parsed (nreverse (cons token itl)))
 185              )
 186         (cons parsed (cdr lal))
 187       )))
 188
 189 (defun rfc822/parse-token-or-comment (lal)
 190   (let (token itl)
 191     (while (and lal
 192                 (progn
 193                   (setq token (car lal))
 194                   (eq (car token) 'spaces)
 195                   ))
 196       (setq lal (cdr lal))
 197       (setq itl (cons token itl))
 198       )
 199     (cons (nreverse (cons token itl))
 200           (cdr lal))
 201     ))
 202
 203 (defun rfc822/parse-word (lal)
 204   (let ((ret (rfc822/parse-ascii-token lal)))
 205     (if ret
 206         (let ((elt (car ret))
 207               (rest (cdr ret))
 208               )
 209           (if (or (assq 'atom elt)
 210                   (assq 'quoted-string elt))
 211               (cons (cons 'word elt) rest)
 212             )))))
 213
 214 (defun rfc822/parse-word-or-comment (lal)
 215   (let ((ret (rfc822/parse-token-or-comment lal)))
 216     (if ret
 217         (let ((elt (car ret))
 218               (rest (cdr ret))
 219               )
 220           (cond ((or (assq 'atom elt)
 221                      (assq 'quoted-string elt))
 222                  (cons (cons 'word elt) rest)
 223                  )
 224                 ((assq 'comment elt)
 225                  (cons (cons 'comment-word elt) rest)
 226                  ))
 227           ))))
 228
 229 (defun rfc822/parse-phrase (lal)
 230   (let (ret phrase)
 231     (while (setq ret (rfc822/parse-word-or-comment lal))
 232       (setq phrase (append phrase (cdr (car ret))))
 233       (setq lal (cdr ret))
 234       )
 235     (if phrase
 236         (cons (cons 'phrase phrase) lal)
 237       )))
 238
 239 (defun rfc822/parse-local-part (lal)
 240   (let ((ret (rfc822/parse-word lal)))
 241     (if ret
 242         (let ((local-part (cdr (car ret))) dot)
 243           (setq lal (cdr ret))
 244           (while (and (setq ret (rfc822/parse-ascii-token lal))
 245                       (setq dot (car ret))
 246                       (string-equal (cdr (assq 'specials dot)) ".")
 247                       (setq ret (rfc822/parse-word (cdr ret)))
 248                       (setq local-part
 249                             (append local-part dot (cdr (car ret)))
 250                             )
 251                       (setq lal (cdr ret))
 252                       ))
 253           (cons (cons 'local-part local-part) lal)
 254           ))))
 255
 256 (defun rfc822/parse-sub-domain (lal)
 257   (let ((ret (rfc822/parse-ascii-token lal)))
 258     (if ret
 259         (let ((sub-domain (car ret)))
 260           (if (or (assq 'atom sub-domain)
 261                   (assq 'domain-literal sub-domain)
 262                   )
 263               (cons (cons 'sub-domain sub-domain)
 264                     (cdr ret)
 265                     )
 266             )))))
 267
 268 (defun rfc822/parse-domain (lal)
 269   (let ((ret (rfc822/parse-sub-domain lal)))
 270     (if ret
 271         (let ((domain (cdr (car ret))) dot)
 272           (setq lal (cdr ret))
 273           (while (and (setq ret (rfc822/parse-ascii-token lal))
 274                       (setq dot (car ret))
 275                       (string-equal (cdr (assq 'specials dot)) ".")
 276                       (setq ret (rfc822/parse-sub-domain (cdr ret)))
 277                       (setq domain
 278                             (append domain dot (cdr (car ret)))
 279                             )
 280                       (setq lal (cdr ret))
 281                       ))
 282           (cons (cons 'domain domain) lal)
 283           ))))
 284
 285 (defun rfc822/parse-at-domain (lal)
 286   (let ((ret (rfc822/parse-ascii-token lal)) at-sign)
 287     (if (and ret
 288              (setq at-sign (car ret))
 289              (string-equal (cdr (assq 'specials at-sign)) "@")
 290              (setq ret (rfc822/parse-domain (cdr ret)))
 291              )
 292         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 293               (cdr ret))
 294       )))
 295
 296 (defun rfc822/parse-addr-spec (lal)
 297   (let ((ret (rfc822/parse-local-part lal))
 298         addr)
 299     (if (and ret
 300              (prog1
 301                  (setq addr (cdr (car ret)))
 302                (setq lal (cdr ret))
 303                (and (setq ret (rfc822/parse-at-domain lal))
 304                     (setq addr (append addr (cdr (car ret))))
 305                     (setq lal (cdr ret))
 306                     )))
 307         (cons (cons 'addr-spec addr) lal)
 308       )))
 309
 310 (defun rfc822/parse-route (lal)
 311   (let ((ret (rfc822/parse-at-domain lal))
 312         route comma colon)
 313     (if (and ret
 314              (progn
 315                (setq route (cdr (car ret)))
 316                (setq lal (cdr ret))
 317                (while (and (setq ret (rfc822/parse-ascii-token lal))
 318                            (setq comma (car ret))
 319                            (string-equal (cdr (assq 'specials comma)) ",")
 320                            (setq ret (rfc822/parse-at-domain (cdr ret)))
 321                            )
 322                  (setq route (append route comma (cdr (car ret))))
 323                  (setq lal (cdr ret))
 324                  )
 325                (and (setq ret (rfc822/parse-ascii-token lal))
 326                     (setq colon (car ret))
 327                     (string-equal (cdr (assq 'specials colon)) ":")
 328                     (setq route (append route colon))
 329                     )
 330                ))
 331         (cons (cons 'route route)
 332               (cdr ret)
 333               )
 334       )))
 335
 336 (defun rfc822/parse-route-addr (lal)
 337   (let ((ret (rfc822/parse-ascii-token lal))
 338         < route addr-spec >)
 339     (if (and ret
 340              (setq < (car ret))
 341              (string-equal (cdr (assq 'specials <)) "<")
 342              (setq lal (cdr ret))
 343              (progn (and (setq ret (rfc822/parse-route lal))
 344                          (setq route (cdr (car ret)))
 345                          (setq lal (cdr ret))
 346                          )
 347                     (setq ret (rfc822/parse-addr-spec lal))
 348                     )
 349              (setq addr-spec (cdr (car ret)))
 350              (setq lal (cdr ret))
 351              (setq ret (rfc822/parse-ascii-token lal))
 352              (setq > (car ret))
 353              (string-equal (cdr (assq 'specials >)) ">")
 354              )
 355         (cons (cons 'route-addr (append route addr-spec))
 356               (cdr ret)
 357               )
 358       )))
 359
 360 (defun rfc822/parse-phrase-route-addr (lal)
 361   (let ((ret (rfc822/parse-phrase lal)) phrase)
 362     (if ret
 363         (progn
 364           (setq phrase (cdr (car ret)))
 365           (setq lal (cdr ret))
 366           ))
 367     (if (setq ret (rfc822/parse-route-addr lal))
 368         (cons (list 'phrase-route-addr
 369                     phrase
 370                     (cdr (car ret)))
 371               (cdr ret))
 372       )))
 373
 374 (defun rfc822/parse-mailbox (lal)
 375   (let ((ret (or (rfc822/parse-phrase-route-addr lal)
 376                  (rfc822/parse-addr-spec lal)))
 377         mbox comment)
 378     (if (and ret
 379              (prog1
 380                  (setq mbox (car ret))
 381                (setq lal (cdr ret))
 382                (if (and (setq ret (rfc822/parse-token-or-comment lal))
 383                         (setq comment (cdr (assq 'comment (car ret))))
 384                         )
 385                    (setq lal (cdr ret))
 386                  )))
 387         (cons (list 'mailbox mbox comment)
 388               lal)
 389       )))
 390
 391 (defun rfc822/parse-group (lal)
 392   (let ((ret (rfc822/parse-phrase lal))
 393         phrase colon comma mbox semicolon)
 394     (if (and ret
 395              (setq phrase (cdr (car ret)))
 396              (setq lal (cdr ret))
 397              (setq ret (rfc822/parse-ascii-token lal))
 398              (setq colon (car ret))
 399              (string-equal (cdr (assq 'specials colon)) ":")
 400              (setq lal (cdr ret))
 401              (progn
 402                (and (setq ret (rfc822/parse-mailbox lal))
 403                     (setq mbox (list (car ret)))
 404                     (setq lal (cdr ret))
 405                     (progn
 406                       (while (and (setq ret (rfc822/parse-ascii-token lal))
 407                                   (setq comma (car ret))
 408                                   (string-equal
 409                                    (cdr (assq 'specials comma)) ",")
 410                                   (setq lal (cdr ret))
 411                                   (setq ret (rfc822/parse-mailbox lal))
 412                                   (setq mbox (cons (car ret) mbox))
 413                                   (setq lal (cdr ret))
 414                                   )
 415                         )))
 416                (and (setq ret (rfc822/parse-ascii-token lal))
 417                     (setq semicolon (car ret))
 418                     (string-equal (cdr (assq 'specials semicolon)) ";")
 419                     )))
 420         (cons (list 'group phrase (nreverse mbox))
 421               (cdr ret)
 422               )
 423       )))
 424
 425 (defun rfc822/parse-address (lal)
 426   (or (rfc822/parse-group lal)
 427       (rfc822/parse-mailbox lal)
 428       ))
 429
 430 (defun rfc822/parse-addresses (lal)
 431   (let ((ret (rfc822/parse-address lal)))
 432     (if ret
 433         (let ((dest (list (car ret))))
 434           (setq lal (cdr ret))
 435           (while (and (setq ret (rfc822/parse-ascii-token lal))
 436                       (string-equal (cdr (assq 'specials (car ret))) ",")
 437                       (setq ret (rfc822/parse-address (cdr ret)))
 438                       )
 439             (setq dest (cons (car ret) dest))
 440             (setq lal (cdr ret))
 441             )
 442           (nreverse dest)
 443           ))))
 444
 445 (defun rfc822/addr-to-string (seq)
 446   (mapconcat (function
 447               (lambda (token)
 448                 (if (eq (car token) 'spaces)
 449                     ""
 450                   (cdr token)
 451                   )))
 452              seq "")
 453   )
 454
 455 (defun rfc822/address-string (address)
 456   (cond ((eq (car address) 'group)
 457          (mapconcat (function rfc822/address-string)
 458                     (nth 2 address)
 459                     ", ")
 460          )
 461         ((eq (car address) 'mailbox)
 462          (let ((addr (nth 1 address)))
 463            (rfc822/addr-to-string
 464             (if (eq (car addr) 'phrase-route-addr)
 465                 (nth 2 addr)
 466               (cdr addr)
 467               )
 468             )))))
 469
 470 (defun rfc822/full-name-string (address)
 471   (cond ((eq (car address) 'group)
 472          (mapconcat (function
 473                      (lambda (token)
 474                        (cdr token)
 475                        ))
 476                     (nth 1 address) "")
 477          )
 478         ((eq (car address) 'mailbox)
 479          (let ((addr (nth 1 address))
 480                (comment (nth 2 address))
 481                phrase)
 482            (if (eq (car addr) 'phrase-route-addr)
 483                (setq phrase (mapconcat (function
 484                                         (lambda (token)
 485                                           (cdr token)
 486                                           ))
 487                                        (nth 1 addr) ""))
 488              )
 489            (or phrase comment)
 490            ))))
 491
 492 (defun rfc822/extract-address-components (str)
 493   "Extract full name and canonical address from STR.
 494 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 495 If no name can be extracted, FULL-NAME will be nil. [tl-822.el]"
 496   (let* ((structure (car
 497                      (rfc822/parse-address
 498                       (rfc822/lexical-analyze str)
 499                       )))
 500          (phrase  (rfc822/full-name-string structure))
 501          (address (rfc822/address-string structure))
 502          )
 503     (list phrase address)
 504     ))
 505
 506
 507 ;;; @ end
 508 ;;;
 509
 510 (provide 'tl-822)
 511
 512 ;;; tl-822.el ends here