base64 encoding using ports

[sen_ml at eccosys dot com]

ok, here's my first attempt at base64-encode that takes a port as its
only argument.  the resulting characters are written to a port named
base64-output-port which defaults to (current-output-port) -- i tested
it a little bit so unlike my original code posted (which was full of
errors) this should run ;-)

p.s. please tell me if ^L is not welcome and i should use mime
attachments instead.



#! /usr/bin/guile -s
!#

(define-module (ice9 base64))

(export encode-base64
;       decode-base64
)

(define base64-encode-table (make-vector 64))
(define base64-decode-table (make-vector 64))
;; may be this shouldn't be sitting out here naked...
(let ((index 0))
  ;; A-Z
  (while (< index 26)
	 (hashv-set! base64-encode-table
		     index
		     (integer->char (+ index 65)))
	 (hashv-set! base64-decode-table
		     (integer->char (+ index 65))
		     index)
	 (set! index (1+ index)))
  ;; a-z
  (while (< index 52)
	 (hashv-set! base64-encode-table
		     index
		     (integer->char (+ index 71)))
	 (hashv-set! base64-decode-table
		     (integer->char (+ index 71))
		     index)
	 (set! index (1+ index)))
  ;; 0-9
  (while (< index 62)
	 (hashv-set! base64-encode-table
		     index
		     (integer->char (- index 4)))
	 (hashv-set! base64-decode-table
		     (integer->char (- index 4))
		     index)
	 (set! index (1+ index)))
  ;; +
  (hashv-set! base64-encode-table 62 #\+)
  (hashv-set! base64-decode-table #\+ 62)
  ;; /
  (hashv-set! base64-encode-table 63 #\/)
  (hashv-set! base64-decode-table #\/ 63))

;(define base64-eol-chars '(#\n))
(define base64-eol-chars nil)

(define base64-output-port (current-output-port))

(define (encode-base64 port)
  (let ((current-state 1)
	(current-char nil)
	;; byte might not be the best name in the world...
	(byte nil)
	(column 1)
	(top-bits nil)
	(bottom-bits nil)
	(table-index nil))
    (catch 
     'done
     (lambda ()
       (while (not (eof-object? current-char))
	      (set! current-char (read-char port))
	      (cond
	       ((eqv? current-state 1)
		(if (eof-object? current-char)
		    ;; following this branch should mean exiting the while
		    (begin
		      ;; nothing to do actually, we're done
		      (sleep 0))
		    (begin
		      (set! byte (char->integer current-char))
		      (set! table-index
			    ;; rshift top 6 bits by 2 (2^2)
			    (/ (logand byte #b11111100) 4))
		      (set! top-bits
			    ;; lshift bottom 2 bits by 4 (2^4)
			    (* (logand byte #b00000011) 16))
		      (write-char (hashv-ref base64-encode-table table-index)
				  base64-output-port))))
	       ((eqv? current-state 2)
		(if (eof-object? current-char)
		    ;; following this branch should mean exiting the while
		    (begin
		      (set! table-index
			    ;; logior unnecessary here?
			    (logior top-bits #b00000000))
		      (write-char (hashv-ref base64-encode-table table-index)
				  base64-output-port)
		      (write-char #\= base64-output-port)
		      (write-char #\= base64-output-port))
		    (begin
		      (set! byte (char->integer current-char))
		      (set! bottom-bits
			    ;; rshift top 4 bits by 4 (2^4)
			    (/ (logand byte #b11110000) 16))
		      (set! table-index
			    (logior top-bits bottom-bits))
		      (set! top-bits
			    ;; lshift bottom 4 bits by 2 (2^2)
			    (* (logand byte #b00001111) 4))
		      (write-char (hashv-ref base64-encode-table table-index)
				  base64-output-port))))
	       ((eqv? current-state 3)
		(if (eof-object? current-char)
		    ;; following this branch should mean exiting the while
		    (begin
		      (set! table-index
			    ;; logior unnecessary here?
			    (logior top-bits #b00000000))
		      (write-char (hashv-ref base64-encode-table table-index)
				  base64-output-port)
		      (write-char #\= base64-output-port))
		    (begin
		      (set! byte (char->integer current-char))
		      (set! bottom-bits
			    ;; rshift top 2 bits by 6 (2^6)
			    (/ (logand byte #b11000000) 64))
		      (set! table-index
			    (logior top-bits bottom-bits))
		      (write-char (hashv-ref base64-encode-table table-index)
				  base64-output-port)
		      (set! table-index
			    ;; last 6 bits
			    (logand byte #b00111111))
		      (write-char (hashv-ref base64-encode-table table-index)
				  base64-output-port))))
	       (t
		(throw 'done 'invalid-state-encountered)))
	      ;; TODO: determine whether this is appropriate
	      (if (not (null? base64-eol-chars))
		  (begin
		    (set! column (1+ column))
		    (if (eqv? 76 column)
			(begin
			  (for-each (lambda (i)
				      (write-char i base64-output-port))
				    base64-eol-chars)
			  (set! column 1)))))
	      ;; move to the next state
	      (if (eqv? current-state 3)
		  (set! current-state 1)
		  (set! current-state (1+ current-state))))
       ;; result
       )
     (lambda (key value)
       (cond
	((eqv? key 'invalid-state-encountered)
	 (display "an invalid state was encountered\n")))))))

(display "HELLO is encoded as: ")    
(call-with-input-string "HELLO" encode-base64)
(display "\n")