;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          encode.lisp
;;;; Purpose:       cl-base64 encoding routines
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Dec 2002
;;;;
;;;; $Id$
;;;;
;;;; 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>
;;;;
;;;; Copyright 2002-2003 Kevin M. Rosenberg
;;;; Permission to use with BSD-style license included in the COPYING file
;;;; *************************************************************************

(in-package #:cl-base64)

(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)))


;;; Decoding

#+ignore
(defmacro def-base64-stream-to-* (output-type)
  `(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-)
				(symbol-name output-type)))
    (input &key (uri nil)
	,@(when (eq output-type :stream)
		'(stream)))
     ,(concatenate 'string "Decode base64 stream to " (string-downcase
						       (symbol-name output-type)))
     (declare (stream input)
	      (optimize (speed 3) (space 0) (safety 0)))
     (let ((pad (if uri *uri-pad-char* *pad-char*))
	   (decode-table (if uri *uri-decode-table* *decode-table*)))
       (declare (type decode-table decode-table)
		(type character pad))
       (let (,@(case output-type
		     (:string
		      '((result (make-string (* 3 (truncate (length string) 4))))))
		     (:usb8-array
		      '((result (make-array (* 3 (truncate (length string) 4))
				 :element-type '(unsigned-byte 8)
				 :fill-pointer nil
				 :adjustable nil)))))
	       (ridx 0))
	 (declare ,@(case output-type
			  (:string
			   '((simple-string result)))
			  (:usb8-array
			   '((type (simple-array (usigned-byte 8) (*)) result))))
		  (fixnum ridx))
	 (do* ((bitstore 0)
	       (bitcount 0)
	       (char (read-char stream nil #\null)
		     (read-char stream nil #\null)))
	      ((eq char #\null)
	       ,(case output-type
		      (:stream
		       'stream)
		      ((:string :usb8-array)
		       'result)
		      ;; ((:stream :string)
		      ;; '(subseq result 0 ridx))))
		      ))
	   (declare (fixnum bitstore bitcount)
		    (character char))
	   (let ((svalue (aref decode-table (the fixnum (char-code char)))))
	     (declare (fixnum svalue))
	     (cond
	       ((>= svalue 0)
		(setf bitstore (logior
				(the fixnum (ash bitstore 6))
				svalue))
		(incf bitcount 6)
		(when (>= bitcount 8)
		  (decf bitcount 8)
		  (let ((ovalue (the fixnum
				  (logand
				   (the fixnum
				     (ash bitstore
					  (the fixnum (- bitcount))))
				   #xFF))))
		    (declare (fixnum ovalue))
		    ,(case output-type
			   (:string
			    '(setf (char result ridx) (code-char ovalue)))
			   (:usb8-array
			    '(setf (aref result ridx) ovalue))
			   (:stream
			    '(write-char (code-char ovalue) stream)))
		    (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))
	       )))))))

;;(def-base64-stream-to-* :string)
;;(def-base64-stream-to-* :stream)
;;(def-base64-stream-to-* :usb8-array)

(defmacro def-base64-string-to-* (output-type)
  `(defun ,(intern (concatenate 'string (symbol-name :base64-string-to-)
				(symbol-name output-type)))
    (input &key (uri nil)
	,@(when (eq output-type :stream)
		'(stream)))
     ,(concatenate 'string "Decode base64 string to " (string-downcase
						       (symbol-name output-type)))
     (declare (string input)
	      (optimize (speed 3) (safety 0) (space 0)))
     (let ((pad (if uri *uri-pad-char* *pad-char*))
	   (decode-table (if uri *uri-decode-table* *decode-table*)))
       (declare (type decode-table decode-table)
		(type character pad))
       (let (,@(case output-type
		     (:string
		      '((result (make-string (* 3 (truncate (length input) 4))))))
		     (:usb8-array
		      '((result (make-array (* 3 (truncate (length input) 4))
				 :element-type '(unsigned-byte 8)
				 :fill-pointer nil
				 :adjustable nil)))))
	       (ridx 0))
	 (declare ,@(case output-type
			  (:string
			   '((simple-string result)))
			  (:usb8-array
			   '((type (simple-array (unsigned-byte 8) (*)) result))))
		  (fixnum ridx))
	 (loop 
	    for char of-type character across input
	    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)
		   (let ((ovalue (the fixnum
				   (logand
				    (the fixnum
				      (ash bitstore
					   (the fixnum (- bitcount))))
				    #xFF))))
		     (declare (fixnum ovalue))
		     ,(case output-type
			    (:string
			     '(setf (char result ridx) (code-char ovalue)))
			    (:usb8-array
			     '(setf (aref result ridx) ovalue))
			    (:stream
			     '(write-char (code-char ovalue) stream)))
		     (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))
		 ))
	 ,(case output-type
		(:stream
		 'stream)
		((:usb8-array :string)
		 '(subseq result 0 ridx)))))))

(def-base64-string-to-* :string)
(def-base64-string-to-* :stream)
(def-base64-string-to-* :usb8-array)

;; input-mode can be :string or :stream
;; input-format can be :character or :usb8

(defun base64-string-to-integer (string &key (uri nil))
  "Decodes a base64 string to an integer"
  (declare (string string)
	   (optimize (speed 3) (safety 0) (space 0)))
  (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)))


(defun base64-stream-to-integer (stream &key (uri nil))
  "Decodes a base64 string to an integer"
  (declare (stream stream)
	   (optimize (speed 3) (space 0) (safety 0)))
  (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))
    (do* ((value 0)
	  (char (read-char stream nil #\null)
		(read-char stream nil #\null)))
	 ((eq char #\null)
	  value)
      (declare (integer value)
	       (character char))
      (let ((svalue (aref decode-table (the fixnum (char-code char)))))
	   (declare (fixnum svalue))
	   (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)))))))