;;;; This file implements the Base64 transfer encoding algorithm as
;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
;;;; See: http://www.ietf.org/rfc/rfc1521.txt
;;;;
;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi>
;;;;
;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
;;;;   - .asd file
;;;;   - numerous speed optimizations
;;;;   - conversion to and from integers
;;;;   - Renamed functions now that supporting integer conversions
;;;;   - URI-compatible encoding using :uri key
;;;;
;;;; Copyright 2002-2003 Kevin M. Rosenberg
;;;; Permission to use with BSD-style license included in the COPYING file
;;;;
;;;; $Id: src.lisp,v 1.6 2003/01/04 13:43:27 kevin Exp $

(defpackage #:base64
  (:use #:cl)
  (:export #:base64-to-string #:base64-to-integer
	   #:string-to-base64 #:integer-to-base64))


(in-package #:base64)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *encode-table*
    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  (declaim (type simple-string *encode-table*))
  
  (defvar *uri-encode-table*
    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
  (declaim (type simple-string *uri-encode-table*))
  
  (deftype decode-table () '(simple-array fixnum (256)))

  (defvar *decode-table*
    (let ((da (make-array 256 :adjustable nil :fill-pointer nil
			  :element-type 'fixnum
			  :initial-element -1)))
      (loop for char of-type character across *encode-table*
	    for index of-type fixnum from 0 below 64
	    do (setf (aref da (the fixnum (char-code char))) index))
      da))
  
  (defvar *uri-decode-table*
    (let ((da (make-array 256 :adjustable nil :fill-pointer nil
			  :element-type 'fixnum
			  :initial-element -1)))
      (loop
       for char of-type character across *uri-encode-table*
       for index of-type fixnum from 0 below 64
       do (setf (aref da (the fixnum (char-code char))) index))
      da))
  
  (declaim (type decode-table *decode-table* *uri-decode-table*))
  
  (defvar *pad-char* #\=)
  (defvar *uri-pad-char* #\.)
  (declaim (type character *pad-char* *uri-pad-char*))
  )


;;; Utilities

(defun round-next-multiple (x n)
  "Round x up to the next highest multiple of n."
  (declare (fixnum n)
	   (optimize (speed 3)))
  (let ((remainder (mod x n)))
    (declare (fixnum remainder))
    (if (zerop remainder)
	x
	(the fixnum (+ x (the fixnum (- n remainder)))))))

(declaim (inline whitespace-p))
(defun whitespace-p (c)
  "Returns T for a whitespace character."
  (or (char= c #\Newline) (char= c #\Linefeed)
      (char= c #\Return) (char= c #\Space)
      (char= c #\Tab)))


;; Encode routines

(defun string-to-base64 (string &key (uri nil) (columns 0) (stream nil))
  "Encode a string array to base64. If columns is > 0, designates
maximum number of columns in a line and the string will be terminated
with a #\Newline."
  (declare (string string)
	   (fixnum columns)
	   (optimize (speed 3)))
  (let ((pad (if uri *uri-pad-char* *pad-char*))
	(encode-table (if uri *uri-encode-table* *encode-table*)))
    (declare (simple-string encode-table)
	     (character pad))
    (let* ((string-length (length string))
	   (complete-group-count (truncate string-length 3))
	   (remainder (nth-value 1 (truncate string-length 3)))
	   (padded-length (* 4 (truncate (+ string-length 2) 3)))
	   (num-lines (if (plusp columns)
			  (truncate (+ padded-length (1- columns)) columns)
			  0))
	   (num-breaks (if (plusp num-lines)
			   (1- num-lines)
			   0))
	   (strlen (if stream
		       0
		       (+ padded-length num-breaks)))
	   (result (make-string strlen))
	   (col (if (plusp columns)
		    0
		    (1+ padded-length)))
	   (ioutput 0))
      (declare (fixnum string-length padded-length col ioutput)
	       (simple-string result))
      (labels ((output-char (ch)
		 (when (= col columns)
		   (if stream
		       (write-char #\Newline stream)
		       (progn
			 (setf (schar result ioutput) #\Newline)
			 (incf ioutput)))
		   (setq col 0))
		 (incf col)
		 (if stream
		     (write-char ch stream)
		     (progn
		       (setf (schar result ioutput) ch)
		       (incf ioutput))))
	     (output-group (svalue chars)
	       (declare (fixnum svalue chars))
	       (output-char
		(schar encode-table
		       (the fixnum
			 (logand #x3f
				 (the fixnum (ash svalue -18))))))
	       (output-char
		(schar encode-table
		       (the fixnum
			 (logand #x3f
				 (the fixnum (ash svalue -12))))))
	       (if (> chars 2)
		   (output-char
		    (schar encode-table
			   (the fixnum
			     (logand #x3f
				     (the fixnum (ash svalue -6))))))
		 (output-char pad))
	       (if (> chars 3)
		   (output-char
		    (schar encode-table
			   (the fixnum
			     (logand #x3f svalue))))
		 (output-char pad))))
	(do ((igroup 0 (1+ igroup))
	     (isource 0 (+ isource 3)))
	    ((= igroup complete-group-count)
	     (cond
	       ((= remainder 2)
		(output-group
		 (the fixnum
		   (+
		    (the fixnum
		      (ash (char-code (the character
					(char string isource))) 16))
		    (the fixnum
		      (ash (char-code (the character
					(char string (1+ isource)))) 8))))
		 3))
	       ((= remainder 1)
		(output-group
		 (the fixnum
		   (ash (char-code (the character (char string isource))) 16))
		 2)))
	     result)
	  (declare (fixnum igroup isource))
	  (output-group 
	   (the fixnum
	     (+
	      (the fixnum
		(ash (char-code (the character
				  (char string isource))) 16))
	      (the fixnum
		(ash (char-code (the character (char string (1+ isource)))) 8))
	      (the fixnum
		(char-code (the character (char string (+ 2 isource)))))))
	   4))))))
  
(defun integer-to-base64 (input &key (uri nil) (columns 0) (stream nil))
  (if stream
      (integer-to-base64-stream input stream :uri uri :columns columns)
      (integer-to-base64-string input :uri uri :columns columns)))

(defun integer-to-base64-string (input &key (uri nil) (columns 0))
  "Encode an integer to base64 format."
  (declare (integer input)
	   (fixnum columns)
	   (optimize (speed 3)))
  (let ((pad (if uri *uri-pad-char* *pad-char*))
	(encode-table (if uri *uri-encode-table* *encode-table*)))
    (declare (simple-string encode-table)
	     (character pad))
    (let* ((input-bits (integer-length input))
	   (byte-bits (round-next-multiple input-bits 8))
	   (padded-bits (round-next-multiple byte-bits 6))
	   (remainder-padding (mod padded-bits 24))
	   (padding-bits (if (zerop remainder-padding)
			     0
			     (- 24 remainder-padding)))
	   (padding-chars (/ padding-bits 6))
	   (padded-length (/ (+ padded-bits padding-bits) 6))
	   (last-line-len (if (plusp columns)
			      (- padded-length (* columns
						  (truncate
						   padded-length columns)))
			      0))
	   (num-lines (if (plusp columns)
			  (truncate (+ padded-length (1- columns)) columns)
			  0))
	   (num-breaks (if (plusp num-lines)
			   (1- num-lines)
			   0))
	   (strlen (+ padded-length num-breaks))
	   (last-char (1- strlen))
	   (str (make-string strlen))
	   (col (if (zerop last-line-len)
		    (1- columns)
		    (1- last-line-len))))
      (declare (fixnum padded-length num-lines col last-char
		       padding-chars last-line-len))
      (unless (plusp columns)
	(setq col -1)) ;; set to flag to optimize in loop
      
      (dotimes (i padding-chars)
	(declare (fixnum i))
	(setf (schar str (the fixnum (- last-char i))) pad))

      (do* ((strpos (- last-char padding-chars) (1- strpos))
	    (int (ash input (/ padding-bits 3))))
	   ((minusp strpos)
	    str)
	(declare (fixnum strpos) (integer int))
	(cond
	  ((zerop col)
	   (setf (schar str strpos) #\Newline)
	   (setq col columns))
	  (t
	   (setf (schar str strpos)
		 (schar encode-table (the fixnum (logand int #x3f))))
	   (setq int (ash int -6))
	   (decf col)))))))

(defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
  "Encode an integer to base64 format."
  (declare (integer input)
	   (fixnum columns)
	   (optimize (speed 3)))
  (let ((pad (if uri *uri-pad-char* *pad-char*))
	(encode-table (if uri *uri-encode-table* *encode-table*)))
    (declare (simple-string encode-table)
	     (character pad))
    (let* ((input-bits (integer-length input))
	   (byte-bits (round-next-multiple input-bits 8))
	   (padded-bits (round-next-multiple byte-bits 6))
	   (remainder-padding (mod padded-bits 24))
	   (padding-bits (if (zerop remainder-padding)
			     0
			     (- 24 remainder-padding)))
	   (padding-chars (/ padding-bits 6))
	   (padded-length (/ (+ padded-bits padding-bits) 6))
	   (strlen padded-length)
	   (nonpad-chars (- strlen padding-chars))
	   (last-nonpad-char (1- nonpad-chars))
	   (str (make-string strlen)))
      (declare (fixnum padded-length last-nonpad-char))
      (do* ((strpos 0 (1+ strpos))
	    (int (ash input (/ padding-bits 3)) (ash int -6))
	    (6bit-value (logand int #x3f) (logand int #x3f)))
	   ((= strpos nonpad-chars)
	    (let ((col 0))
	      (declare (fixnum col))
	      (dotimes (i nonpad-chars)
		(declare (fixnum i))
		(write-char (schar str i) stream)
		(when (plusp columns)
		  (incf col)
		  (when (= col columns)
		    (write-char #\Newline stream)
		    (setq col 0))))
	      (dotimes (ipad padding-chars)
		(declare (fixnum ipad))
		(write-char pad stream)
		(when (plusp columns)
		  (incf col)
		  (when (= col columns)
		    (write-char #\Newline stream)
		    (setq col 0)))))
	    stream)
	(declare (fixnum 6bit-value strpos)
		 (integer int))
	(setf (schar str (- last-nonpad-char strpos))
	      (schar encode-table 6bit-value))
	))))

;;; Decoding

(defun base64-to-string (string &key (uri nil))
  "Decode a base64 string to a string array."
  (declare (string string)
	   (optimize (speed 3)))
  (let ((pad (if uri *uri-pad-char* *pad-char*))
	(decode-table (if uri *uri-decode-table* *decode-table*)))
    (declare (type decode-table decode-table)
	     (character pad))
    (let ((result (make-string (* 3 (truncate (length string) 4))))
	  (ridx 0))
      (declare (simple-string result)
	       (fixnum ridx))
      (loop
	 for char of-type character across string
	 for svalue of-type fixnum = (aref decode-table (the fixnum (char-code char)))
	 with bitstore of-type fixnum = 0
	 with bitcount of-type fixnum = 0
	 do
	   (cond
	     ((>= svalue 0)
	      (setf bitstore (logior
			      (the fixnum (ash bitstore 6))
			      svalue))
	      (incf bitcount 6)
	      (when (>= bitcount 8)
		(decf bitcount 8)
		(setf (char result ridx)
		      (code-char (the fixnum
				   (logand
				    (the fixnum
				      (ash bitstore
					   (the fixnum (- bitcount))))
				    #xFF))))
		(incf ridx)
		(setf bitstore (the fixnum (logand bitstore #xFF)))))
	     ((char= char pad)
	      ;; Could add checks to make sure padding is correct
	      ;; Currently, padding is ignored
	      )
	     ((whitespace-p char)
	      ;; Ignore whitespace
	      )
	     ((minusp svalue)
	      (warn "Bad character ~W in base64 decode" char))
))
      (subseq result 0 ridx))))
  
  
(defun base64-to-integer (string &key (uri nil))
  "Decodes a base64 string to an integer"
  (declare (string string)
	   (optimize (speed 3)))
  (let ((pad (if uri *uri-pad-char* *pad-char*))
	(decode-table (if uri *uri-decode-table* *decode-table*)))
    (declare (type decode-table decode-table)
	     (character pad))
    (let ((value 0))
      (declare (integer value))
      (loop
	 for char of-type character across string
	 for svalue of-type fixnum =
	   (aref decode-table (the fixnum (char-code char)))
	 do
	   (cond
	     ((>= svalue 0)
	      (setq value (+ svalue (ash value 6))))
	     ((char= char pad)
	      (setq value (ash value -2)))
	     ((whitespace-p char)
	      ; ignore whitespace
	      )
	     ((minusp svalue)
	      (warn "Bad character ~W in base64 decode" char))))
      value)))