X-Git-Url: http://git.kpe.io/?p=cl-base64.git;a=blobdiff_plain;f=src.lisp;fp=src.lisp;h=0000000000000000000000000000000000000000;hp=48cde5b6d64fadd243644eb0f4ba93d28e255386;hb=9d5e8be84951cef7f6a11bb60af0c64d8bd1e254;hpb=1b3ea245129cdd7b33b2fc28da5fda8300c31a97

diff --git a/src.lisp b/src.lisp
deleted file mode 100644
index 48cde5b..0000000
--- a/src.lisp
+++ /dev/null
@@ -1,382 +0,0 @@
-;;;; 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)))