;;;; -*- mode: lisp -*-
;;;;
;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
;;;;
;;;; This is a Common Lisp implementation of Base64 encoding and decoding.
;;;;
;;;; Copyright (C) 2002-2005 Sven Van Caekenberghe, Beta Nine BVBA.
;;;;
;;;; You are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser General Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

(in-package :s-base64)

(defparameter +base64-alphabet+
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")

(defparameter +inverse-base64-alphabet+
  (let ((inverse-base64-alphabet (make-array 127)))
    (dotimes (i 127 inverse-base64-alphabet)
      (setf (aref inverse-base64-alphabet i)
	    (position (code-char i) +base64-alphabet+)))))
      
(defun core-encode-base64 (byte1 byte2 byte3)
  (values (char +base64-alphabet+ (ash byte1 -2))
	  (char +base64-alphabet+ (logior (ash (logand byte1 #B11) 4)
					   (ash (logand byte2 #B11110000) -4)))
	  (char +base64-alphabet+ (logior (ash (logand byte2 #B00001111) 2)
					   (ash (logand byte3 #B11000000) -6)))
	  (char +base64-alphabet+ (logand byte3 #B111111))))

(defun core-decode-base64 (char1 char2 char3 char4)
  (let ((v1 (aref +inverse-base64-alphabet+ (char-code char1)))
	(v2 (aref +inverse-base64-alphabet+ (char-code char2)))
	(v3 (aref +inverse-base64-alphabet+ (char-code char3)))
	(v4 (aref +inverse-base64-alphabet+ (char-code char4))))
    (values (logior (ash v1 2)
		    (ash v2 -4))
	    (logior (ash (logand v2 #B1111) 4)
		    (ash v3 -2))
	    (logior (ash (logand v3 #B11) 6)
		    v4))))

(defun skip-base64-whitespace (stream)
  (loop
   (let ((char (peek-char nil stream nil nil)))
     (cond ((null char) (return nil))
	   ((null (aref +inverse-base64-alphabet+ (char-code char))) (read-char stream))
	   (t (return char))))))

(defun decode-base64-bytes (stream)
  "Decode a base64 encoded character stream, returns a byte array"
  (let ((out (make-array 256
			 :element-type '(unsigned-byte 8)
			 :adjustable t
			 :fill-pointer 0)))
    (loop
     (skip-base64-whitespace stream)
     (let ((in1 (read-char stream nil nil))
	   (in2 (read-char stream nil nil))
	   (in3 (read-char stream nil nil))
	   (in4 (read-char stream nil nil)))
       (if (null in1) (return))
       (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded for base64 encoding")) 
       (multiple-value-bind (out1 out2 out3)
	   (core-decode-base64 in1
			       in2
			       (if (char= in3 #\=) #\A in3)
			       (if (char= in4 #\=) #\A in4))
	 (vector-push-extend out1 out)
	 (when (char/= in3 #\=)
	   (vector-push-extend out2 out)
	   (when (char/= in4 #\=)
	     (vector-push-extend out3 out))))))
    out))

(defun encode-base64-bytes (array stream &optional (break-lines t))
  "Encode a byte array into a base64 encoded character stream"
  (let ((index 0)
	(counter 0)
	(len (length array)))
    (loop
     (when (>= index len) (return))
     (let ((in1 (aref array index))
	   (in2 (if (< (+ index 1) len) (aref array (+ index 1)) nil))
	   (in3 (if (< (+ index 2) len) (aref array (+ index 2)) nil)))
       (multiple-value-bind (out1 out2 out3 out4)
	   (core-encode-base64 in1
			       (if (null in2) 0 in2)
			       (if (null in3) 0 in3))
	 (write-char out1 stream)
	 (write-char out2 stream)
	 (if (null in2)
	     (progn
	       (write-char #\= stream)
	       (write-char #\= stream))
	   (progn
	     (write-char out3 stream)
	     (if (null in3)
		 (write-char #\= stream)
	       (write-char out4 stream))))
	 (incf index 3)
	 (incf counter 4)
	 (when (and break-lines (= counter 76))
	   (terpri stream)
	   (setf counter 0)))))))

(defun decode-base64 (in out)
  "Decode a base64 encoded character input stream into a binary output stream" 
  (loop
   (skip-base64-whitespace in)
   (let ((in1 (read-char in nil nil))
	 (in2 (read-char in nil nil))
	 (in3 (read-char in nil nil))
	 (in4 (read-char in nil nil)))
     (if (null in1) (return))
     (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded for base64 encoding")) 
     (multiple-value-bind (out1 out2 out3)
	 (core-decode-base64 in1 in2 (if (char= in3 #\=) #\A in3) (if (char= in4 #\=) #\A in4))
       (write-byte out1 out)
       (when (char/= in3 #\=)
	 (write-byte out2 out)
	 (when (char/= in4 #\=)
	   (write-byte out3 out)))))))

(defun encode-base64 (in out &optional (break-lines t))
  "Encode a binary input stream into a base64 encoded character output stream"
  (let ((counter 0))
    (loop
     (let ((in1 (read-byte in nil nil))
	   (in2 (read-byte in nil nil))
	   (in3 (read-byte in nil nil)))
       (if (null in1) (return))
       (multiple-value-bind (out1 out2 out3 out4)
	   (core-encode-base64 in1 (if (null in2) 0 in2) (if (null in3) 0 in3))
	 (write-char out1 out)
	 (write-char out2 out)
	 (if (null in2)
	     (progn
	       (write-char #\= out)
	       (write-char #\= out))
	   (progn
	     (write-char out3 out)
	     (if (null in3)
		 (write-char #\= out)
	       (write-char out4 out))))
	 (incf counter 4)
	 (when (and break-lines (= counter 76))
	   (terpri out)
	   (setf counter 0)))))))

;;;; eof