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
|
;;; guile-email --- Guile email parser
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of guile-email.
;;;
;;; guile-email is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; guile-email 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
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with guile-email. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (email utils)
#:use-module (ice-9 match)
#:use-module (ice-9 peg codegen)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 textual-ports)
#:use-module (rnrs bytevectors)
#:use-module ((rnrs io ports)
#:select (call-with-bytevector-output-port))
#:use-module (rnrs io simple)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (get-line-with-delimiter
read-objects
read-while
read-bytes-till
acons*
alist-combine))
(define (read-objects read-proc port)
"Read all objects using READ-PROC from PORT and return them as a
list."
(let ((x (read-proc port)))
(if (eof-object? x)
(list)
(cons x (read-objects read-proc port)))))
(define* (read-while port read-proc pred)
"Read from PORT using READ-PROC while PRED returns #t and the
end-of-file has not been reached. READ-PROC is invoked with the input
port as argument. PRED is invoked with each string returned by
READ-PROC as argument. The string for which PRED returns #f is ungot
back into PORT."
(define (read-while-loop output)
(let ((x (read-proc port)))
(cond
((eof-object? x) x)
((pred x)
(put-string output x)
(read-while-loop output))
(else (unget-string port x)))))
(let ((str (call-with-output-string read-while-loop)))
(if (string-null? str) (eof-object) str)))
(define (read-bytes-till port sequence)
"Read bytes from PORT until byte SEQUENCE is seen or end-of-file is
reached. If SEQUENCE is seen, unget it to PORT and return."
(define (read-bytes-and-write-till in out sequence)
(let ((octet (get-u8 in)))
(cond
((eof-object? octet) octet)
;; If octet read matches first octet of sequence, try matching
;; the full sequence.
((= octet (bytevector-u8-ref sequence 0))
(unget-bytevector in sequence 0 1)
(let ((bv (get-bytevector-n in (bytevector-length sequence))))
(cond
((bytevector=? bv sequence) (unget-bytevector in bv))
(else (unget-bytevector in bv 1)
(put-u8 out octet)
(read-bytes-and-write-till in out sequence)))))
;; Else, output the octet and continue reading.
(else (put-u8 out octet)
(read-bytes-and-write-till in out sequence)))))
(let ((bv (call-with-bytevector-output-port
(cut read-bytes-and-write-till port <> sequence))))
(if (bytevector=? bv (make-bytevector 0)) (eof-object) bv)))
(define (get-line-with-delimiter port)
"Read a line from PORT and return it as a string including the
delimiting linefeed character."
(let ((line (get-line port)))
(if (eof-object? line)
line
(string-append line "\n"))))
(define acons*
(match-lambda*
((key value)
(acons key value (list)))
((key value . rest)
(acons key value (apply acons* rest)))
((alist) alist)))
(define (alist-combine alist1 alist2)
"Combine two association lists ALIST1 and ALIST2 into a single
association list. Key-value pairs in ALIST2 are more significant and
override those in ALIST1."
(append alist2
(remove (match-lambda
((key . _)
(assoc key alist2)))
alist1)))
(define (cg-string-ci pat accum)
(syntax-case pat ()
((pat-str-syntax) (string? (syntax->datum #'pat-str-syntax))
(let ((pat-str (syntax->datum #'pat-str-syntax)))
(let ((plen (string-length pat-str)))
#`(lambda (str len pos)
(let ((end (+ pos #,plen)))
(and (<= end len)
(string-ci= str #,pat-str pos end)
#,(case accum
((all) #`(list end (list 'cg-string #,pat-str)))
((name) #`(list end 'cg-string))
((body) #`(list end #,pat-str))
((none) #`(list end '()))
(else (error "bad accum" accum)))))))))))
(add-peg-compiler! 'string-ci cg-string-ci)
|
