binascii

1 files changed, 366 insertions, 0 deletions

diff --git a/modules/language/python/module/binascii.scm b/modules/language/python/module/binascii.scm
new file mode 100644
index 0000000..364cff8
--- /dev/null
+++ b/modules/language/python/module/binascii.scm
@@ -0,0 +1,366 @@
+(define-module (language python module binascii)
+  #:use-modules (language python list)
+  #:use-modules (language python bytes)
+  #:use-modules (language python exceptions)
+  #:use-modules (language python try)
+  #:use-module (rnrs bytevectors)
+  #:export (Error Incomplete a2b_uu b2a_uu a2b_base64 b2a_base64 a2b_qp b2a_qp
+		  a2b_hex b2a_hex))
+
+(define-python-class Error ())
+(define-python-class Incomplete ())
+
+(define (a2b_uu s)
+  (let ((n (len s))
+	(s (bv->scm s)))
+    (define (get n i)
+      (if (< i n)
+	  (let ((r (bytevector-u8-ref s i)))
+	    (if (= r 96)
+		0
+		(- r 32)))
+	  (raise (Incomplete "missing values in the uuencode"))))
+    
+    (if (< n 2)
+	(raise (Error "uudecode of malformed uuencoded bytevector"))
+	(let* ((N (get n 0))
+	       (n (min n (+ (// (* 3 N) 4) 1))))
+	  (let lp ((i 1) (j 0) (r '()))
+	    (if (< i n)
+		(let* ((a1 (get i))
+		       (a2 (get n (+ i 1)))
+		       (a3 (get n (+ i 2)))
+		       (a4 (get n (+ i 3)))
+		       (x  (logior
+			    (ash (logand #x3f a1) 0)
+			    (ash (logand #x3f a2) 6)
+			    (ash (logand #x3f a3) 12)
+			    (ash (logand #x3f a4) 18)))
+		       (b1 (ash (logand #x0000ff x) 0))
+		       (b2 (ash (logand #x00ff00 x) -8))
+		       (b3 (ash (logand #xff0000 x) -16)))
+		  (lp (+ i 4) (+ j 3)
+		      (cond
+		       ((< j (- N 2))
+			(cons* b3 b2 b1 r))
+		       ((= j (- N 2))
+			(cons* b2 b1 r))
+		       ((= j (- N 1))
+			(cons* b1 r)))))		    
+		(bytes (reverse r))))))))
+
+
+
+(def (b2a_uu data (= backtick #f))
+     (let ((n    (len data))
+	   (data (bv->scm data)))
+       
+       (define (m x)
+	 (if (= x 0)
+	     (if backtick
+		 96
+		 32)
+	     (+ x 32)))
+
+       (define (get i)
+	 (if (< i n)
+	     (bytevector-u8-ref data i)
+	     0))
+       
+       (if (< n 45)
+	   (let lp ((i 0) (r '()))
+	     (if (< i n)
+		 (let* ((a1 (get i))
+			(a2 (get (+ i 1)))
+			(a3 (get (+ i 2)))
+			(x  (logior
+			     (ash a1 0)
+			     (ash a2 8)
+			     (ash a3 16)))
+			(b1 (m (ash (logand #x00003f x)   0)))
+			(b2 (m (ash (logand #x000fc0 x)  -6)))
+			(b3 (m (ash (logand #x03f000 x) -12)))
+			(b4 (m (ash (logand #xfc0000 x) -18))))
+		   (lp (+ i 3) (cons* b4 b3 b2 b1 r)))
+		 (bytes (cons (m n) (reverse (cons 10 r))))))
+	   (raise (Error "too many characters at the line")))))
+
+(define (str2vec x)
+  (u8-list->vector
+   (map char->integer
+	(string->list
+	 x))))
+
+(define (vec2str x N)
+  (let ((n (let lp ((i 0) (s 0))
+	     (if (< i (len x))
+		 (lp (+ i 1) (max s (bytevector-u8-ref x i)))
+		 s))))
+    (define (find x)
+      (let lp ((i 0))
+	(if (< i (len x))
+	    (if (= x (bytevector-u8-ref x i))
+		i
+		(lp (+ i 1)))
+	    N)))
+    
+    (let lp ((i 0) (r '()))
+      (if (< i (+ n 1))
+	  (lp (+ i 1) (cons (find i) r))
+	  (u8-list->vector (reverse r))))))
+	   
+(define to64 (str2vec "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"))
+(define from64 (vec2str t064 65))
+(define n64 (len from64))
+	  
+(define (a2b_base64 s)  
+  (define x=x (char->integer #\=))
+  (let ((s (bv->scm s))
+	(n (len s)))
+
+    (define (get1 n i)
+      (if (< i n)
+	  (butevector-u8-ref s i)
+	  (raise (Incomplete "malformed base64 encoding missing values"))))
+
+    (define (get2 i)
+      (if (< i n64)
+	  (let ((x (bytevector-u8-ref from64 i)))
+	    (if (= x 65)
+		(raise (Error "malformed base64 encoding"))
+		x))
+	  (raise (Error "malformed base64 encoding"))))
+
+    (if (or (= n 0) (= n 1))
+	(bytes (list))
+	(let lp ((i 0) (r '()))       
+	  (cond
+	   ((or (= (get1 n i) 10) (= (get1 n i) 13))
+	    (lp (+ i 1) r))
+	   	   
+	   ((< i n)
+	    (let ((b1 (get1 n i))
+		  (b2 (get1 n (+ i 1)))
+		  (b3 (get1 n (+ i 2)))
+		  (b4 (get1 n (+ i 3))))
+	      (let ((b1 (get2 b1))
+		    (b2 (get2 b1)))
+		(if (= x=x b4)
+		    (if (= x=x b3)
+			(let* ((x  (logior b1 (ash b2 6)))
+			       (ch (logand x #xff)))
+			  (lp (+ i 4) (cons ch r)))
+			(let* ((b3  (get2 b3))
+			       (x   (logior b1 (ash b2 6) (ash b3 12)))
+			       (ch1 (logand x #xff))
+			       (ch2 (ash (logand x #xff00) -8)))
+			  (lp (+ i 4) (cons* ch2 ch1 r))))
+		    (let* ((b3  (get2 b3))
+			   (b4  (get2 b4))
+			   (x   (logior b1 (ash b2 6) (ash b3 12) (ash b4 18)))
+			   (ch1 (logand x #xff))
+			   (ch2 (ash (logand x #xff00) -8))
+			   (ch3 (ash (logand x #xff0000) -16)))
+		      (lp (+ i 4) (cons* ch3 ch2 ch1 r)))))))
+	   (else
+	    (bytes (reverse (cons 10 r)))))))))
+
+(def (b2a_base64 data (= newline True))
+     (define x=x (char->integer #\=))
+     (let ((n (len data))
+	   (s (bv->scm data)))
+       (if (= n 0)
+	   (if newline
+	       (bytes (list 10))
+	       (bytes (list)))
+	   (let lp ((i 0) (r '()))
+	     (cond
+	      ((= i (- n 1))
+	       (let* ((b1 (get i))
+		      (b2 (get (+ i 1)))
+		      (x  (logior b1 (ash b2 8)))
+		      (a1 (get2 (logand #x3f x)))
+		      (a2 (get2 (ash (logand #xfc0 x)    -6)))
+		      (a3 (get2 (ash (logand #x3f000 x)  -12)))
+		      (a4 x=x))
+		 (lp (+ i 3) (cons* a4 a3 a2 a1 r))))
+
+	      ((= i (- n 2))
+	       (let* ((x (get i))
+		      (a1 (get2 (logand #x3f x)))
+		      (a2 (get2 (ash (logand #xfc0 x)    -6)))
+		      (a3 x=x)
+		      (a4 x=x))
+		 (lp (+ i 3) (cons* a4 a3 a2 a1 r))))
+
+	      ((< i n)
+	       (let* ((b1 (get i))
+		      (b2 (get (+ i 1)))
+		      (b3 (get (+ i 2)))
+		      (x  (logior b1 (ash b2 8) (ash b3 16)))
+		      (a1 (get2 (logand #x3f x)))
+		      (a2 (get2 (ash (logand #xfc0 x)    -6)))
+		      (a3 (get2 (ash (logand #x3f000 x)  -12)))
+		      (a4 (get2 (ash (logand #xfc0000 x) -18))))
+		 (lp (+ i 3) (cons* a4 a3 a2 a1 r))))
+
+	      (else
+	       (if newline
+		   (bytes (reverse (cons 10 r)))
+		   (bytes (reverse r)))))))))
+
+(define itoh1 (str2vec "0123456789abcdef"))
+(define htoi1 (vec2str itoh1 128))
+(define nh1   (len hto1))
+
+(define itoh2 (str2vec "0123456789ABCDEF"))
+(define htoi2 (vec2str itoh2 128))
+(define nh2   (len hto1))
+
+
+(def (a2b_qp data (= header #f))
+     (define x=x (char->integer #\=))
+     (define x_x (char->integer #\_))
+     (define spc (char->integer #\space))
+
+     (define (tr x)
+       (let ((x (bytevector-u8-ref htoi1)))
+	 (if (= x 128)
+	     (let ((x (bytevector-u8-ref htoi2)))
+	       (if (= x 128)
+		   (raise (Error "malformed quoted data"))
+		   x))
+	     x)))
+	     
+     (let ((n    (len data))
+	   (data (bv->scm data)))
+       (let lp ((i 0) (r '()))
+	 (define (get n i)
+	   (if (< i n)
+	       (bytevector-u8-ref data i)
+	       (raise (incomplete "malformed quoted data missing values"))))
+
+	 (if (< i n)
+	     (let ((x (get i)))
+	       (cond
+		((= x x=x)
+		 (let ((a1 (get (+ i 1))))
+		   (if (or (= a1 10) (= a1 13))
+		       (let ((a2 (get (+ i 2))))
+			 (if (or (= a1 10) (= a1 13))
+			     (lp (+ i 3) r)
+			     (lp (+ i 2) r)))
+		       (let ((a1 (tr (get (+ i 1))))
+			     (a2 (tr (get (+ i 2))))
+			     (x  (logior a1 + (ash a2 4))))
+			 (lp (+ i 3) (cons x r))))))
+		((and header (= x x_x))
+		 (lp (+ i 1) (cons spc r)))
+		(else
+		 (lp (+ i 1) (cons x r)))))
+	     (bytes (reverse r))))))
+
+(def (b2a_qp data (= quotetabs #f) (=istext #t) (= header None))
+     (define x=x (char->integer #\=))
+     (define x_x (char->integer #\_))
+     (define spc (char->integer #\space))
+     (define tab (char->integer #\tab))
+     
+     (define (encode x)
+       (let ((a1 (logand #xf x))
+	     (a2 (ash (logand #f0 x) -4)))
+	 (values (bytevector-u8-ref itoh1 a1)
+		 (bytevector-u8-ref itoh1 a2))))
+     
+     (let ((n    (len data))
+	   (data (bv->scm data)))
+       (let lp ((i 0) (j 0) (tre? #f) (r '()))
+	 (cond
+	  ((= j 76)
+	   (lp i 3 (cons* (car r) (cadr r) (caddr r)
+			  10 x=x (cdddr r))))
+	  ((= j 77)
+	   (lp i 4 (cons* (car r) (cadr r) (caddr r) (caddr (cdr r))
+			  10 x=x (cddddr r))))
+	  ((= j 78)
+	   (lp i 5 (cons* (car r) (cadr r) (caddr r) (caddr (cdr r)) (caddr (cddr r))
+			  10 x=x (cddddr (cdr r)))))
+	  (else
+	   (if (< i n)
+	       (let ((x (get i)))
+		 (define (q)
+		   (call-with-values (lambda () (encode x))
+		     (lambda (c1 c2)
+		       (cons* c1 c1 x=x r))))
+		 (cond
+		  ((or (= x 10) (= x 13))
+		   (if (or (not istext) header)
+		       (lp (+ i 1) (+ j 3) (q))
+		       (lp (+ i 1) (+ j 1) (cons x r))))
+		
+		  ((eq? x tab)
+		   (if (or quotetabs (and (at-end) istext))
+		       (lp (+ i 1) (+ j 3) (q))
+		       (lp (+ i 1) (+ j 1) (cons x r))))
+
+		  ((eq? x spc)
+		   (if header
+		       (lp (+ i 1) (+ j 1) (cons x_x r))
+		       (if (or quotetabs (and (at-end) istext))
+			   (lp (+ i 1) (+ j 3) (q))
+			   (lp (+ i 1) (+ j 1) (cons x r)))))
+
+		  ((eq? x x=x)
+		   (lp (+ i 1) (+ j 3) (q)))
+		    
+		  ((and (< x 126) (> x 32))
+		   (lp (+ i 1) (+ j 1) (cons x r)))
+		
+		  (else
+		   (lp (+ i 1) (+ j 3) (q)))))
+	       (bytes (reverse r))))))))
+
+(define (b2a_hex s)
+  (let ((n (len s))
+	(s (bv->scm s)))
+    (define (get i)
+      (bytevector-u8-ref s i))
+    (define (tr x)
+      (bytevector-u8-ref itoh1 x))
+    (let lp ((i 0) (r '()))
+      (if (< i 0)
+	  (let* ((x  (get i))
+		 (a1 (tr (logand #xf x)))
+		 (a2 (tr (ash (logand #xf0 x) -4))))
+	    (lp (+ i 1) (cons* a2 a1 r)))
+	  (bytes (reverse r))))))
+
+(define (a2b_hex d)
+  (let ((n (len s))
+	(s (bv->scm s)))
+    
+    (define (tr x)
+      (if (< x nh1)
+	  (let ((x (bytevector-u8-ref htoi1 x)))
+	    (if (= x 128)
+		(let ((x (bytevector-u8-ref htoi2 x)))
+		  (if (= x 128)
+		      (raise (Error "malformed hex string"))
+		      x))
+		x))
+	  (raise (Error "malformed hex string"))))
+    
+    (define (get i)
+      (tr (bytevector-u8-ref s i)))
+
+    (if (= (modulo n 2) 1)
+	(raise (Error "incomplete hex string"))
+	(let lp ((i 0) (r '()))
+	  
+	  (if (< i n)
+	      (let* ((a1 (get i))
+		     (a2 (get (+ i 1)))
+		     (x  (logior a1 (ash a2 4))))
+		(lp (+ i 2) (cons x r)))
+	      (bytes (reverse r)))))))
+