This is the mail archive of the
guile@sourceware.cygnus.com
mailing list for the Guile project.
base64.scm version 0.1
below is version 0.1 of base64.scm, an implementation of rfc 2045
base64 encoding and decoding in guile using ports.
two functions `encode-base64' and 'decode-base64' are provided.
each one takes a port as an argument. both functions write the
resulting data to `base64-output-port', which defaults to
(current-output-port).
thanks to everyone for their feedback up to now.
comments and suggestions welcome!
;;;; base64.scm -- urn:ietf:rfc:2045 base64 encoding and decoding
;;;;
;;;; Copyright (C) 2000 Sen Nagata
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; version 2.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; http://www.gnu.org/copyleft/gpl.html
;;;;
;;;
;;; This file contains routines to perform base64 encoding and decoding.
;;; See section 6.8 of RFC 2045 for details.
(define-module (ice9 base64))
(export encode-base64
decode-base64
base64-output-port
base64-version)
(define base64-version "0.1")
(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 #f)
(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
#t)
(lambda (key value)
(cond
((eqv? value 'invalid-state-encountered)
(display "an invalid state was encountered\n"))
(#t
(display "unexpected arrival\n")))))))
(define (decode-base64 port)
(let ((current-state 1)
(current-char nil)
;; again, may be not the best name
(byte #f)
(top-bits nil)
(bottom-bits nil))
(catch
'done
(lambda ()
(while (not (eof-object? current-char))
(set! current-char (read-char port))
(cond
((eqv? current-state 1)
(if (eqv? current-char #\=)
(begin
(throw 'done 'end-reached))
(if (eof-object? current-char)
(begin
;; do nothing -- done
(throw 'done 'eof-reached))
(begin
(set! byte
(hashv-ref base64-decode-table current-char))
(if byte
(begin
(set! top-bits
(* (logand byte #b00111111) 4)))
(begin
;; ignore byte -- it is noise
(sleep 0)))))))
((eqv? current-state 2)
(if (eqv? current-char #\=)
(begin
(throw 'done 'end-reached))
(if (eof-object? current-char)
(begin
(set! bottom-bits #b00000000)
(write-char (integer->char
(logior top-bits bottom-bits))
base64-output-port)
(throw 'done 'eof-reached))
(begin
(set! byte
(hashv-ref base64-decode-table current-char))
(if byte
(begin
(set! bottom-bits
(/ (logand byte #b00110000) 16))
(write-char (integer->char
(logior top-bits bottom-bits))
base64-output-port)
(set! top-bits
(* (logand byte #b00001111) 16)))
(begin
;; ignore byte -- it is noise
(sleep 0)))))))
((eqv? current-state 3)
(if (eqv? current-char #\=)
(begin
(throw 'done 'end-reached))
(if (eof-object? current-char)
(begin
(set! bottom-bits #b00000000)
(write-char (integer->char
(logior top-bits bottom-bits))
base64-output-port)
(throw 'done 'eof-reached))
(begin
(set! byte
(hashv-ref base64-decode-table current-char))
(if byte
(begin
(set! bottom-bits
(/ (logand byte #b00111100) 4))
(write-char (integer->char
(logior top-bits bottom-bits))
base64-output-port)
(set! top-bits
(* (logand byte #b00000011) 64)))
(begin
;; ignore byte -- it is noise
(sleep 0)))))))
((eqv? current-state 4)
(if (eqv? current-char #\=)
(begin
(throw 'done 'end-reached))
(if (eof-object? current-char)
(begin
(set! bottom-bits #b00000000)
(write-char (integer->char
(logior top-bits bottom-bits))
base64-output-port)
(throw 'done 'eof-reached))
(begin
(set! byte
(hashv-ref base64-decode-table current-char))
(if byte
(begin
(set! bottom-bits
(logand byte #b00111111))
(write-char (integer->char
(logior top-bits bottom-bits))
base64-output-port))
(begin
;; ignore byte -- it is noise
(sleep 0)))))))
(#t
(throw 'done 'invalid-state-encountered)))
(if byte ; abusing byte to determine need for state change
(begin
(if (eqv? current-state 4)
(set! current-state 1)
(set! current-state (1+ current-state)))
;; TODO: decide whether there is a better place to do this
(set! byte #f))))
;; result
#t)
(lambda (key value)
(cond
((eqv? value 'end-reached)
#t)
((eqv? value 'eof-reached)
#t)
((eqv? value 'invalid-state-encountered)
(display "an invalid state was encountered\n"))
(#t
(display "unexpected arrival\n")))))))
; (display "SEVMTE8= is decoded as: ")
; (call-with-input-string "SEVMTE8=" decode-base64)
; (display "\n")
; (display "SEVMTE8h is decoded as: ")
; (call-with-input-string "SEVMTE8h" decode-base64)
; (display "\n")
; (display "SEVMTE8hPw== is decoded as: ")
; (call-with-input-string "SEVMTE8hPw==" decode-base64)
; (display "\n")
; (display "HELLO is encoded as: ")
; (call-with-input-string "HELLO" encode-base64)
; (display "\n")
; (display "HELLO! is encoded as: ")
; (call-with-input-string "HELLO!" encode-base64)
; (display "\n")
; (display "HELLO!? is encoded as: ")
; (call-with-input-string "HELLO!?" encode-base64)
; (display "\n")