Initial commit.

1 files changed, 95 insertions, 0 deletions

diff --git a/email/utils.scm b/email/utils.scm
new file mode 100644
index 0000000..7d51ebb
--- /dev/null
+++ b/email/utils.scm
@@ -0,0 +1,95 @@
+;;; guile-email --- Guile email parser
+;;; Copyright © 2018 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 textual-ports)
+  #:use-module (rnrs io simple)
+  #:export (get-line-with-delimiter
+	    read-objects
+	    read-while
+	    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))
+       (#t (unget-string port x)))))
+
+  (let ((str (call-with-output-string read-while-loop)))
+    (if (string-null? str) (eof-object) str)))
+
+(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)