quoted-printable: Q-encode #\? and #\_ with their ASCII values.

* email/quoted-printable.scm (%q-encoding-literal-char-set,
%quoted-printable-literal-char-set): New variables.
(quoted-printable-encode): Move core encoding code to ...
(quoted-printable-style-encode): ... this new function.
(q-encoding-decode): Call quoted-printable-style-encode with the
appropriate literal-char-set instead of calling
quoted-printable-encode.
* tests/quoted-printable.scm (q-encoding of special characters): Add
to check for this bug.

1 files changed, 45 insertions, 26 deletions

diff --git a/email/quoted-printable.scm b/email/quoted-printable.scm
index d119f6a..7b88b04 100644
--- a/email/quoted-printable.scm
+++ b/email/quoted-printable.scm
@@ -53,6 +53,43 @@
         (else (put-u8 out (char->integer c))
               (quoted-printable-decode in out)))))))
 
+(define* (quoted-printable-style-encode
+          in out literal-char-set
+          #:optional (number-of-chars-left-on-this-line 76))
+  (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-style-encode
+         in out literal-char-set
+         (put-into-output
+          (if (char-set-contains? literal-char-set c)
+              (string c)
+              (format #f "=~:@(~2,'0x~)" x))))))))
+
+;; Character set of characters to be represented by themselves in
+;; quoted-printable encoding
+(define %quoted-printable-literal-char-set
+  (char-set-delete
+   (ucs-range->char-set (char->integer #\space)
+                        (char->integer #\delete))
+   #\=))
+
+;; Character set of characters to be represented by themselves in Q
+;; encoding
+(define %q-encoding-literal-char-set
+  (char-set-delete
+   %quoted-printable-literal-char-set
+   #\? #\_))
+
 (define quoted-printable-encode
   (match-lambda*
     (((? bytevector? bv))
@@ -62,31 +99,8 @@
      (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
-                   (ucs-range->char-set (char->integer #\space)
-                                        (char->integer #\delete))
-                   #\=)
-                  c)
-                 (string c)
-                 (format #f "=~:@(~2,'0x~)" x))))))))))
+     (quoted-printable-style-encode
+      in out %quoted-printable-literal-char-set))))
 
 (define (q-encoding-decode str)
   (quoted-printable-decode
@@ -99,4 +113,9 @@
   (string-map
    (lambda (c)
      (if (char=? c #\Space) #\_ c))
-   (quoted-printable-encode bv)))
+   (call-with-port
+    (open-bytevector-input-port bv)
+    (lambda (in)
+      (call-with-output-string
+        (cut quoted-printable-style-encode in <>
+             %q-encoding-literal-char-set))))))