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.

2 files changed, 54 insertions, 5 deletions

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
diff --git a/tests/quoted-printable.scm b/tests/quoted-printable.scm
index c57c833..cc1b957 100755
--- a/tests/quoted-printable.scm
+++ b/tests/quoted-printable.scm
@@ -19,19 +19,35 @@
 
 (use-modules (email quoted-printable)
 	     (ice-9 iconv)
+	     (srfi srfi-1)
 	     (srfi srfi-64))
 
 (test-begin "quoted-printable")
 
-(test-equal "quoted-printable wikipedia example"
-  (bytevector->string
-   (quoted-printable-decode "J'interdis aux marchands de vanter trop leur marchandises. Car ils se font =
+(let ((decoded-text
+       "J'interdis aux marchands de vanter trop leur marchandises. Car ils se font vite pédagogues et t'enseignent comme but ce qui n'est par essence qu'un moyen, et te trompant ainsi sur la route à suivre les voilà bientôt qui te dégradent, car si leur musique est vulgaire ils te fabriquent pour te la vendre une âme vulgaire.")
+      (encoded-text
+       "J'interdis aux marchands de vanter trop leur marchandises. Car ils se font =
 vite p=C3=A9dagogues et t'enseignent comme but ce qui n'est par essence qu'=
 un moyen, et te trompant ainsi sur la route =C3=A0 suivre les voil=C3=A0 bi=
 ent=C3=B4t qui te d=C3=A9gradent, car si leur musique est vulgaire ils te f=
 abriquent pour te la vendre une =C3=A2me vulgaire.")
-   "UTF-8")
-  "J'interdis aux marchands de vanter trop leur marchandises. Car ils se font vite pédagogues et t'enseignent comme but ce qui n'est par essence qu'un moyen, et te trompant ainsi sur la route à suivre les voilà bientôt qui te dégradent, car si leur musique est vulgaire ils te fabriquent pour te la vendre une âme vulgaire.")
+      (charset "UTF-8"))
+  (test-equal "quoted-printable wikipedia example: decoding"
+    (bytevector->string (quoted-printable-decode encoded-text) charset)
+    decoded-text)
+
+  (test-equal "quoted-printable wikipedia example: encoding"
+    (quoted-printable-encode
+     (string->bytevector decoded-text charset))
+    encoded-text)
+
+  (test-assert "quoted-printable wikipedia example: encoded output should not be more than 76 columns wide"
+    (every (lambda (line)
+	     (<= (string-length line) 76))
+	   (string-split (quoted-printable-encode
+			  (string->bytevector decoded-text charset))
+			 #\newline))))
 
 (test-equal "q-encoding wikipedia example"
   (bytevector->string