Normalize base64 errors.

3 files changed, 52 insertions, 45 deletions

diff --git a/doc/ref/guile/base64.texi b/doc/ref/guile/base64.texi
index ef262ab5..ab6bba81 100644
--- a/doc/ref/guile/base64.texi
+++ b/doc/ref/guile/base64.texi
@@ -5,6 +5,8 @@
 @defunx bytevector->base64 bv
 Base procedure for all Base64 operations.
 Takes and returns bytevectors.
+
+Throws @code{decoding-error} on invalid input.
 @end defun
 
 @defun base64-string->bytevector string
diff --git a/module/base64.scm b/module/base64.scm
index 6a3d4706..e9dc9357 100644
--- a/module/base64.scm
+++ b/module/base64.scm
@@ -56,48 +56,55 @@
    bytevector-u8-set!))
 
 (define (base64->bytevector bv)
-  (let ((len* (bytevector-length bv)))
-    (if (zero? len*)
-        (make-bytevector 0)
-        (let* ((rest (+ (if (= (char->integer #\=) (ref bv (- len* 1)))
-                            1 0)
-                        (if (= (char->integer #\=) (ref bv (- len* 2)))
-                            1 0)))
-               (x (/ (- len* rest) 4))
-               (ret-len (floor (* 3 x))))
-
-          (define ret (make-bytevector ret-len))
-
-          (do ((i 0 (1+ i)))
-              ((>= i (floor x)))
-            (let ((a (encoded->real (ref bv (+ (* i 4) 0))))
-                  (b (encoded->real (ref bv (+ (* i 4) 1))))
-                  (c (encoded->real (ref bv (+ (* i 4) 2))))
-                  (d (encoded->real (ref bv (+ (* i 4) 3)))))
-              (let ((aa (logior (ash a 2) (ash b -4)))
-                    (ab (logior (ash (logand b #xF) 4) (ash c -2)))
-                    (ac (logior (ash (logand c 3) 6) d)))
-                (set! (ref ret (+ (* i 3) 0)) aa)
-                (set! (ref ret (+ (* i 3) 1)) ab)
-                (set! (ref ret (+ (* i 3) 2)) ac))))
-
-
-          (case rest
-            [(2)
-             (let ((a (encoded->real (ref bv (+ (* (floor x) 4) 0))))
-                   (b (encoded->real (ref bv (+ (* (floor x) 4) 1)))))
-               (let ((aa (logior (ash a 2) (ash b -4))))
-                 (set! (ref ret (- ret-len 1)) aa)))]
-            [(1)
-             (let ((a (encoded->real (ref bv (+ (* (floor x) 4) 0))))
-                   (b (encoded->real (ref bv (+ (* (floor x) 4) 1))))
-                   (c (encoded->real (ref bv (+ (* (floor x) 4) 2)))))
-               (let ((aa (logior (ash a 2) (ash b -4)))
-                     (ab (logior (ash (logand b #xF) 4) (ash c -2))))
-                 (set! (ref ret (- ret-len 2)) aa)
-                 (set! (ref ret (- ret-len 1)) ab)))])
-
-          ret))))
+  (catch 'out-of-range
+    (lambda ()
+     (let ((len* (bytevector-length bv)))
+       (if (zero? len*)
+           (make-bytevector 0)
+           (let* ((rest (+ (if (= (char->integer #\=) (ref bv (- len* 1)))
+                               1 0)
+                           (if (= (char->integer #\=) (ref bv (- len* 2)))
+                               1 0)))
+                  (x (/ (- len* rest) 4))
+                  (ret-len (floor (* 3 x))))
+
+             (define ret (make-bytevector ret-len))
+
+             (do ((i 0 (1+ i)))
+                 ((>= i (floor x)))
+               (let ((a (encoded->real (ref bv (+ (* i 4) 0))))
+                     (b (encoded->real (ref bv (+ (* i 4) 1))))
+                     (c (encoded->real (ref bv (+ (* i 4) 2))))
+                     (d (encoded->real (ref bv (+ (* i 4) 3)))))
+                 (let ((aa (logior (ash a 2) (ash b -4)))
+                       (ab (logior (ash (logand b #xF) 4) (ash c -2)))
+                       (ac (logior (ash (logand c 3) 6) d)))
+                   (set! (ref ret (+ (* i 3) 0)) aa)
+                   (set! (ref ret (+ (* i 3) 1)) ab)
+                   (set! (ref ret (+ (* i 3) 2)) ac))))
+
+
+             (case rest
+               [(2)
+                (let ((a (encoded->real (ref bv (+ (* (floor x) 4) 0))))
+                      (b (encoded->real (ref bv (+ (* (floor x) 4) 1)))))
+                  (let ((aa (logior (ash a 2) (ash b -4))))
+                    (set! (ref ret (- ret-len 1)) aa)))]
+               [(1)
+                (let ((a (encoded->real (ref bv (+ (* (floor x) 4) 0))))
+                      (b (encoded->real (ref bv (+ (* (floor x) 4) 1))))
+                      (c (encoded->real (ref bv (+ (* (floor x) 4) 2)))))
+                  (let ((aa (logior (ash a 2) (ash b -4)))
+                        (ab (logior (ash (logand b #xF) 4) (ash c -2))))
+                    (set! (ref ret (- ret-len 2)) aa)
+                    (set! (ref ret (- ret-len 1)) ab)))])
+
+             ret))))
+    (lambda (err proc fmt args data)
+      (scm-error 'decoding-error "base64->bytevector"
+                 (format #f "~~a in ~~a: ~a" fmt)
+                 (cons* err (or proc "unknown function") args)
+                 data))))
 
 (define (bytevector->base64 bv)
   (let* ((len (bytevector-length bv))
diff --git a/tests/test/base64.scm b/tests/test/base64.scm
index 788e7093..61ac8856 100644
--- a/tests/test/base64.scm
+++ b/tests/test/base64.scm
@@ -28,14 +28,12 @@
 
 ;; Other tests
 
-;; TODO normalize base64 errors
-
 (test-error "Invalid base64"
   'decoding-error
   (base64decode "@@@@"))
 
 (test-error "To short base64"
-  'out-of-range
+  'decoding-error
   (base64decode "="))
 
 (test-equal "AAECAw==" (bytevector->base64-string #vu8(0 1 2 3)))