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
129
130
131
|
;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
;; Copyright (C) 2002, 2004, 2006, 2011 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 %include-in-guild-list #f)
(define %summary "Validate an RFC822-style file.")
(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
|
