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
|
;;; 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-26)
#:export (get-line-with-delimiter
read-objects
read-while
read-bytes-till
acons*
alist-delete*))
(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. READ-PROC is
invoked with the input port as argument. PRED is invoked with each
string returned by READ-PROC as argument."
(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-delete* keys alist)
"Return a list containing all elements of ALIST whose keys are not a
member of KEYS."
(filter (match-lambda
((key . _)
(not (member key keys))))
alist))
(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)
|
