(define-module (language python module binascii)
  #:use-module (language python list)
  #:use-module (language python bytes)
  #:use-module (language python exceptions)
  #:use-module (language python try)
  #:use-module (language python def)
  #:use-module (rnrs bytevectors)
  #:use-module (oop pf-objects)
  #:export (Error Incomplete a2b_uu b2a_uu a2b_base64 b2a_base64 a2b_qp b2a_qp
		  a2b_hex b2a_hex))

(define-python-class Error (Exception))
(define-python-class Incomplete (Exception))

(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 (+ (ceiling-quotient (* 3 N) 4) 1))))
	  (let lp ((i 1) (j 0) (r '()))
	    (if (< i n)
		(let* ((a1 (get n 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)
  (list->u8vector
   (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 y)
      (let lp ((i 0))
	(if (< i (len x))
	    (if (= y (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))
	  (list->u8vector (reverse r))))))
	   
(define to64
  (str2vec "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"))
(define from64 (vec2str to64 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)
	  (bytevector-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
           ((>= i n)
            (bytes (reverse r)))
           
	   ((or (= (get1 n i) 10) (= (get1 n i) 13))
	    (lp (+ i 1) r))
	   	   
	   (else
	    (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 b2)))
		(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))))))))))))
	    

(def (b2a_base64 data (= newline #t))
     (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 '()))
             (define (get i)
               (bytevector-u8-ref s i))
             (define (get2 i)
               (bytevector-u8-ref to64 i))
	     (cond
	      ((= i (- n 2))
	       (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 1))
	       (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 htoi1))

(define itoh2 (str2vec "0123456789ABCDEF"))
(define htoi2 (vec2str itoh2 128))
(define nh2   (len htoi1))


(def (a2b_qp data (= header #f))
     (define x=x (char->integer #\=))
     (define x_x (char->integer #\_))
     (define spc (char->integer #\space))

     (define (tr i)
       (let ((x (bytevector-u8-ref htoi1 i)))
	 (if (= x 128)
	     (let ((x (bytevector-u8-ref htoi2 i)))
	       (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 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 #xf0 x) -4)))
	 (values (bytevector-u8-ref itoh1 a1)
		 (bytevector-u8-ref itoh1 a2))))
     (let ((n    (len data))
	   (data (bv-scm data)))
       
       (define (get i)
         (bytevector-u8-ref data i))

       (let lp ((i 0) (j 0) (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 (at-end)
                   (let lp ((i i))
                     (if (< i n)
                         (if (or (eq? (get i) spc) (eq? (get i) tab))
                             (lp (+ i 1))
                             (if (or (eq? (get i) 10) (eq? (get i) 13))
                                 #t
                                 #f))
                         #t)))
                 
		 (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 n)
	  (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 s)
  (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)))))))