From 959941b87c2e7ba732cae8ad1943432dfba83427 Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Wed, 12 Sep 2018 17:25:45 +0530
Subject: quoted-printable: Add quoted-printable-encode.

* email/quoted-printable.scm (quoted-printable-encode): New function.
* tests/quoted-printable.scm (quoted-printable wikipedia example):
Rename to ...
(quoted-printable wikipedia example: decoding): ... this.
(quoted-printable wikipedia example: encoding, quoted-printable
wikipedia example: encoded output should not be more than 76 columns
wide): New tests.
---
 email/quoted-printable.scm | 33 +++++++++++++++++++++++++++++++++
 1 file changed, 33 insertions(+)

(limited to 'email/quoted-printable.scm')

diff --git a/email/quoted-printable.scm b/email/quoted-printable.scm
index 317bf81..d084a7e 100644
--- a/email/quoted-printable.scm
+++ b/email/quoted-printable.scm
@@ -19,8 +19,11 @@
 
 (define-module (email quoted-printable)
   #:use-module (rnrs)
+  #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
   #:export (quoted-printable-decode
+	    quoted-printable-encode
 	    q-encoding-decode))
 
 ;; TODO: Error out on invalid quoted-printable input
@@ -49,6 +52,36 @@
 	(else (put-u8 out (char->integer c))
 	      (quoted-printable-decode in out)))))))
 
+(define quoted-printable-encode
+  (match-lambda*
+    (((? bytevector? bv))
+     (call-with-port (open-bytevector-input-port bv)
+		     quoted-printable-encode))
+    (((? port? in))
+     (call-with-output-string
+       (cut quoted-printable-encode in <>)))
+    (((? port? in) (? port? out))
+     (quoted-printable-encode in out 76))
+    (((? port? in) (? port? out) (? integer? number-of-chars-left-on-this-line))
+     (let ((x (get-u8 in))
+	   (put-into-output
+	    (lambda (str)
+	      (let* ((len (string-length str))
+		     (break-line? (<= number-of-chars-left-on-this-line len)))
+		(put-string
+		 out (string-append (if break-line? "=\n" "") str))
+		(if break-line?
+		    (- 76 len)
+		    (- number-of-chars-left-on-this-line len))))))
+       (unless (eof-object? x)
+	 (let ((c (integer->char x)))
+	   (quoted-printable-encode
+	    in out
+	    (put-into-output
+	     (if (char-set-contains?
+		  (char-set-delete char-set:ascii #\newline #\return) c)
+		 (string c)
+		 (format #f "=~:@(~2,'0x~)" x))))))))))
 
 (define (q-encoding-decode str)
   (quoted-printable-decode
-- 
cgit v1.2.3