1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
;; as published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this software; see the file COPYING.LESSER. If
;; not, write to the Free Software Foundation, Inc., 51 Franklin
;; Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Commentary:
;; Usage: read-rfc822 FILE
;;
;; Read FILE, assumed to be in RFC822 format, and display it to stdout.
;; This is not very interesting, admittedly.
;;
;; For Scheme programming, this module exports two procs:
;; (read-rfc822 . args) ; only first arg used
;; (read-rfc822-silently port)
;;
;; Parse FILE (a string) or PORT, respectively, and return a query proc that
;; takes a symbol COMP, and returns the message component COMP. Supported
;; values for COMP (and the associated query return values) are:
;; from -- #f (reserved for future mbox support)
;; headers -- alist of (HEADER-SYMBOL . "VALUE-STRING") pairs, in order
;; body -- rest of the mail message, a string
;; body-lines -- rest of the mail message, as a list of lines
;; Any other query results in a "bad component" error.
;;
;; TODO: Add "-m" option (mbox support).
;;; Code:
(define-module (scripts read-rfc822)
:use-module (ice-9 regex)
:use-module (ice-9 rdelim)
:autoload (srfi srfi-13) (string-join)
:export (read-rfc822 read-rfc822-silently))
(define from-line-rx (make-regexp "^From "))
(define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
(define header-cont-rx (make-regexp "^[ \t]+"))
(define option #f) ; for future "-m"
(define (drain-message port)
(let loop ((line (read-line port)) (acc '()))
(cond ((eof-object? line)
(reverse acc))
((and option (regexp-exec from-line-rx line))
(for-each (lambda (c)
(unread-char c port))
(cons #\newline
(reverse (string->list line))))
(reverse acc))
(else
(loop (read-line port) (cons line acc))))))
(define (parse-message port)
(let* ((from (and option
(match:suffix (regexp-exec from-line-rx
(read-line port)))))
(body-lines #f)
(body #f)
(headers '())
(add-header! (lambda (reversed-hlines)
(let* ((hlines (reverse reversed-hlines))
(first (car hlines))
(m (regexp-exec header-name-rx first))
(name (string->symbol (match:substring m 1)))
(data (string-join
(cons (substring first (match:end m))
(cdr hlines))
" ")))
(set! headers (acons name data headers))))))
;; "From " is only one line
(let loop ((line (read-line port)) (current-header #f))
(cond ((string-null? line)
(and current-header (add-header! current-header))
(set! body-lines (drain-message port)))
((regexp-exec header-cont-rx line)
=> (lambda (m)
(loop (read-line port)
(cons (match:suffix m) current-header))))
(else
(and current-header (add-header! current-header))
(loop (read-line port) (list line)))))
(set! headers (reverse headers))
(lambda (component)
(case component
((from) from)
((body-lines) body-lines)
((headers) headers)
((body) (or body
(begin (set! body (string-join body-lines "\n" 'suffix))
body)))
(else (error "bad component:" component))))))
(define (read-rfc822-silently port)
(parse-message port))
(define (display-rfc822 parse)
(cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from))))
(for-each (lambda (header)
(format #t "~A: ~A\n" (car header) (cdr header)))
(parse 'headers))
(format #t "\n~A" (parse 'body)))
(define (read-rfc822 . args)
(let ((parse (read-rfc822-silently (open-file (car args) OPEN_READ))))
(display-rfc822 parse))
#t)
(define main read-rfc822)
;;; read-rfc822 ends here
|
