From 8d11e40eb06556b995b963ee7c72e59a5368d21e Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Sun, 12 Jan 2003 22:32:40 +0000
Subject: [PATCH] r3747: *** empty log message ***

---
 debian/changelog |   5 +-
 decode.lisp      | 201 +++++++++++++++++++++++++++--------------------
 encode.lisp      | 162 ++++++++++++++++++++++++++++++++++++--
 package.lisp     |  53 ++++++-------
 4 files changed, 300 insertions(+), 121 deletions(-)

diff --git a/debian/changelog b/debian/changelog
index 857f024..81e12a0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,7 +1,10 @@
-cl-base64 (2.2.0-1) unstable; urgency=low
+cl-base64 (3.0.0-1) unstable; urgency=low
 
   * Fix error in integer-to-base64 when using columns
   * Add base64-test.asd and test.lisp regression suite
+  * Rewrite routines as macros to create efficient functions to
+    converting from strings or streams and converting to streams, strings,
+    and usb8-arrays.
 
  -- Kevin M. Rosenberg <kmr@debian.org>  Sat,  4 Jan 2003 06:40:32 -0700
 
diff --git a/decode.lisp b/decode.lisp
index ea0cdf2..775bb8e 100644
--- a/decode.lisp
+++ b/decode.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: decode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: decode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
 ;;;;
 ;;;; This file implements the Base64 transfer encoding algorithm as
 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
@@ -21,6 +21,8 @@
 
 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
 
+(in-package #:cl-base64)
+
 (declaim (inline whitespace-p))
 (defun whitespace-p (c)
   "Returns T for a whitespace character."
@@ -31,78 +33,21 @@
 
 ;;; 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))))
-
-#|
-(def-base64-stream-to-* :string)
-(def-base64-stream-to-* :stream)
-(def-base64-stream-to-* :usb8-array)
-|#
-
-(defmacro def-base64-string-to-* (output-type)
-  `(defun ,(case output-type
-	    (:string
-	     'base64-string-to-string)
-	    (:stream
-	     'base64-string-to-stream)
-	    (:usb8-array
-	     'base64-string-to-usb8-array))
+#+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)))
-     "Decode base64 string"
-     (declare (input string)
+     ,(concatenate 'string "Decode base64 stream to " (string-downcase
+						       (symbol-name output-type)))
+     (declare (stream input)
 	      (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))
+		(type character pad))
        (let (,@(case output-type
 		     (:string
 		      '((result (make-string (* 3 (truncate (length string) 4))))))
@@ -114,12 +59,94 @@
 	       (ridx 0))
 	 (declare ,@(case output-type
 			  (:string
-			   '((simple-string result))
+			   '((simple-string result)))
+			  (:usb8-array
+			   '((type (array fixnum (*)) 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)
+		      ((or :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
-			    '((type (array fixnum (*)) result)))))
+			    '(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)))
+     (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 (array fixnum (*)) result))))
 		  (fixnum ridx))
 	 (loop 
-	    for char of-type character across string
+	    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
@@ -133,22 +160,22 @@
 		 (incf bitcount 6)
 		 (when (>= bitcount 8)
 		   (decf bitcount 8)
-		   (let ((svalue (the fixnum
+		   (let ((ovalue (the fixnum
 				   (logand
 				    (the fixnum
 				      (ash bitstore
 					   (the fixnum (- bitcount))))
 				    #xFF))))
-		     (declare (fixnum svalue))
-		     ,@(case output-type
-			     (:string
-			      (setf (char result ridx) (code-char svalue)))
-			     (:usb8-array
-			      (setf (aref result ridx) svalue))
-			     (:stream
-			      (write-char (code-char svalue) stream)))
+		     (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)))))
+		     (setf bitstore (the fixnum (logand bitstore #xFF))))))
 		 ((char= char pad)
 		  ;; Could add checks to make sure padding is correct
 		  ;; Currently, padding is ignored
@@ -159,12 +186,16 @@
 		 ((minusp svalue)
 		  (warn "Bad character ~W in base64 decode" char))
 		 ))
-	      (subseq result 0 ridx))))))
+	 ,(case output-type
+		(:stream
+		 'stream)
+		((:stream :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
 
@@ -195,6 +226,7 @@
 	      (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)
@@ -208,8 +240,8 @@
 		(read-char stream nil #\null)))
 	 ((eq char #\null)
 	  value)
-      (declare (value integer)
-	       (char character))
+      (declare (integer value)
+	       (character char))
       (let ((svalue (aref decode-table (the fixnum (char-code char)))))
 	   (declare (fixnum svalue))
 	   (cond
@@ -220,5 +252,4 @@
 	     ((whitespace-p char)		; ignore whitespace
 	      )
 	     ((minusp svalue)
-	      (warn "Bad character ~W in base64 decode" char))))
-	value)))
+	      (warn "Bad character ~W in base64 decode" char)))))))
diff --git a/encode.lisp b/encode.lisp
index e6ee841..d079515 100644
--- a/encode.lisp
+++ b/encode.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: encode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
 ;;;;
 ;;;; This file implements the Base64 transfer encoding algorithm as
 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
@@ -28,7 +28,7 @@
 ;;;;   - Renamed functions now that supporting integer conversions
 ;;;;   - URI-compatible encoding using :uri key
 ;;;;
-;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: encode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
 
 (in-package #:cl-base64)
 
@@ -147,11 +147,159 @@ with a #\Newline."
 	      (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)))
+
+(defmacro def-*-to-base64-* (input-type output-type)
+  `(defun ,(intern (concatenate 'string (symbol-name input-type)
+				(symbol-name :-to-base-64-)
+				(symbol-name output-type)))
+       (input
+	,@(when (eq output-type :stream)
+		'output)
+	&key (uri nil) (columns 0))
+     "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 (,@(case input-type
+		       (:string
+			'((string input)))
+		       (:usb8-array)
+		       '((type (array fixnum (*))) 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* ((string-length (length input))
+	      (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))
+      (macrolet ((output-char (ch)
+		   (if (= col columns)
+		       (progn
+			 (if stream
+			     (write-char #\Newline stream)
+			     (progn
+			       (setf (schar result ioutput) #\Newline)
+			       (incf ioutput)))
+			 (setq col 1))
+		       (incf col))
+		   ,@(case output-type
+			   (:stream
+			    '((write-char ch stream))
+			    (:string
+			     '((setf (schar result ioutput) ch)
+			       (incf ioutput)))))))
+	(labels ((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
+		       ,(case input-type
+			      (:string
+			       '(char-code (the character (char input isource))))
+			      (:usb8-array
+			       '(the fixnum (aref input isource))))
+		       16))
+		    (the fixnum
+		      (ash
+		       ,(case input-type
+			      (:string
+			       '(char-code (the character (char input (1+ isource)))))
+			      (:usb8-array
+			       '(the fixnum (aref input (1+ isource)))))
+		       8))))
+		   3))
+		 ((= remainder 1)
+		  (output-group
+		   (the fixnum
+		     ,(case input-type
+			    (:string
+			     '(char-code (the character (char input isource))))
+			    (:usb8-array
+			     '(the fixnum (aref input isource)))))
+		   2)))
+	       result)
+	    (declare (fixnum igroup isource))
+	    (output-group 
+	     (the fixnum
+	       (+
+		(the fixnum
+		  (ash
+		   ,(case input-type
+			  (:string
+			   '(char-code (the character (char input isource))))
+			  (:usb8-array
+			   '(the fixnum (aref input isource))))
+		   16))
+		(the fixnum
+		  (ash
+		   ,(case input-type
+			  (:string
+			   '(char-code (the character (char input (1+ isource)))))
+			  (:usb8-array
+			   '(the fixnum (aref input (1+ isource)))))
+		   8))
+		(the fixnum
+		  ,(case input-type
+			 (:string
+			  '(char-code (the character (char input (+ 2 isource)))))
+			 (:usb8-array
+			  '(the fixnum (aref input (+ 2 isource)))))
+		  )))
+	     4))))))))
+
+(def-*-to-base64-* :string :string)
+(def-*-to-base64-* :string :stream)
+(def-*-to-base64-* :usb8-array :string)
+(def-*-to-base64-* :usb8-array :stream)
+
 
 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
   "Encode an integer to base64 format."
diff --git a/package.lisp b/package.lisp
index 7c119de..014cd1f 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: package.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: package.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
 ;;;;
 ;;;; *************************************************************************
 
@@ -42,33 +42,30 @@
 (in-package #:cl-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 () '(array fixnum (256)))
+(defvar *encode-table*
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+(declaim (type simple-string *encode-table*))
+
+(defvar *uri-encode-table*
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
+(declaim (type simple-string *uri-encode-table*))
 
-  (defun make-decode-table (encode-table)
-    (let ((dt (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 dt (the fixnum (char-code char))) index))
-      dt))
+(deftype decode-table () '(array fixnum (256)))
+
+(defun make-decode-table (encode-table)
+  (let ((dt (make-array 256 :adjustable nil :fill-pointer nil
+			:element-type 'fixnum
+			:initial-element -1)))
+    (declare (type decode-table dt))
+    (loop for char of-type character across encode-table
+       for index of-type fixnum from 0 below 64
+       do (setf (aref dt (the fixnum (char-code char))) index))
+    dt))
     
-  (defvar *decode-table* (make-decode-table *encode-table*))
-  
-  (defvar *uri-decode-table* (make-decode-table *uri-encode-table*))
+(defvar *decode-table* (make-decode-table *encode-table*))
   
-  (declaim (type decode-table *decode-table* *uri-decode-table*))
+(defvar *uri-decode-table* (make-decode-table *uri-encode-table*))
   
-  (defvar *pad-char* #\=)
-  (defvar *uri-pad-char* #\.)
-  (declaim (type character *pad-char* *uri-pad-char*))
-  )
+(defvar *pad-char* #\=)
+(defvar *uri-pad-char* #\.)
+(declaim (type character *pad-char* *uri-pad-char*))
-- 
GitLab