From 9d5e8be84951cef7f6a11bb60af0c64d8bd1e254 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Sun, 12 Jan 2003 20:25:26 +0000
Subject: [PATCH] r3746: *** empty log message ***

---
 base64-test.asd         |  27 +++++
 base64.asd              |   7 +-
 debian/changelog        |   7 ++
 debian/rules            |   3 +-
 decode.lisp             | 224 ++++++++++++++++++++++++++++++++++++++++
 src.lisp => encode.lisp | 176 ++++++-------------------------
 package.lisp            |  74 +++++++++++++
 7 files changed, 369 insertions(+), 149 deletions(-)
 create mode 100644 base64-test.asd
 create mode 100644 decode.lisp
 rename src.lisp => encode.lisp (64%)
 create mode 100644 package.lisp

diff --git a/base64-test.asd b/base64-test.asd
new file mode 100644
index 0000000..db28e51
--- /dev/null
+++ b/base64-test.asd
@@ -0,0 +1,27 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          base64-test.asd
+;;;; Purpose:       ASDF definition file for Base64 Regression Test
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Jan 2003
+;;;;
+;;;; $Id: base64-test.asd,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; *************************************************************************
+
+(in-package :asdf)
+
+#+allegro (require 'tester)
+
+(defsystem :base64-test
+  :name "cl-base64-test"
+  :author "Kevin M. Rosenberg based on code by Juri Pakaste"
+  :version "1.0"
+  :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+  :licence "BSD-style"
+  :description "Regression test for cl-base64 package"
+  
+  :depends-on (:base64 :kmrcl #-allegro :tester)  
+  :components
+  ((:file "test")))
diff --git a/base64.asd b/base64.asd
index fe08b4f..5d3dad5 100644
--- a/base64.asd
+++ b/base64.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: base64.asd,v 1.2 2002/12/29 06:14:49 kevin Exp $
+;;;; $Id: base64.asd,v 1.3 2003/01/12 20:25:26 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package :asdf)
@@ -24,4 +24,7 @@
 	    (pushnew :base64 cl:*features*))
   
   :components
-  ((:file "src")))
+  ((:file "package")
+   (:file "encode" :depends-on ("package"))
+   (:file "decode" :depends-on ("package"))
+   ))
diff --git a/debian/changelog b/debian/changelog
index ed92b63..857f024 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,10 @@
+cl-base64 (2.2.0-1) unstable; urgency=low
+
+  * Fix error in integer-to-base64 when using columns
+  * Add base64-test.asd and test.lisp regression suite
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Sat,  4 Jan 2003 06:40:32 -0700
+
 cl-base64 (2.1.0-1) unstable; urgency=low
 
   * Fix broken string-to-base64
diff --git a/debian/rules b/debian/rules
index 54ac3fe..3da7d80 100755
--- a/debian/rules
+++ b/debian/rules
@@ -42,8 +42,9 @@ install: build
 	dh_clean -k
 	# Add here commands to install the package into debian/base64.
 	dh_installdirs $(clc-systems) $(clc-base64)
-	dh_install base64.asd $(shell echo *.lisp) $(clc-base64)
+	dh_install *.asd $(shell echo *.lisp) $(clc-base64)
 	dh_link $(clc-base64)/base64.asd $(clc-systems)/base64.asd
+	dh_link $(clc-base64)/base64-test.asd $(clc-systems)/base64-test.asd
 
 # Build architecture-independent files here.
 binary-indep: build install
diff --git a/decode.lisp b/decode.lisp
new file mode 100644
index 0000000..ea0cdf2
--- /dev/null
+++ b/decode.lisp
@@ -0,0 +1,224 @@
+;;;; -*- 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: decode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;;
+;;;; 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
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+(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
+
+(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))
+       (input &key (uri nil)
+	,@(when (eq output-type :stream)
+		'(stream)))
+     "Decode base64 string"
+     (declare (input 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 (,@(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 (array fixnum (*)) 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)
+		   (let ((svalue (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)))
+		     (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-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)))
+  (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)))
+  (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 (value integer)
+	       (char character))
+      (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))))
+	value)))
diff --git a/src.lisp b/encode.lisp
similarity index 64%
rename from src.lisp
rename to encode.lisp
index 48cde5b..e6ee841 100644
--- a/src.lisp
+++ b/encode.lisp
@@ -1,9 +1,26 @@
+;;;; -*- 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: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;;
 ;;;; 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
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
 ;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
 ;;;;   - .asd file
 ;;;;   - numerous speed optimizations
@@ -11,58 +28,10 @@
 ;;;;   - 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))
-
+;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
 
-(in-package #:base64)
+(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 () '(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."
@@ -74,16 +43,6 @@
 	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
@@ -116,14 +75,15 @@ with a #\Newline."
       (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 (= col columns)
+		     (progn
+		       (if stream
+			   (write-char #\Newline stream)
+			   (progn
+			     (setf (schar result ioutput) #\Newline)
+			     (incf ioutput)))
+		       (setq col 1))
+		     (incf col))
 		 (if stream
 		     (write-char ch stream)
 		     (progn
@@ -226,8 +186,8 @@ with a #\Newline."
 	   (last-char (1- strlen))
 	   (str (make-string strlen))
 	   (col (if (zerop last-line-len)
-		    (1- columns)
-		    (1- last-line-len))))
+		     columns
+		    last-line-len)))
       (declare (fixnum padded-length num-lines col last-char
 		       padding-chars last-line-len))
       (unless (plusp columns)
@@ -304,79 +264,3 @@ with a #\Newline."
 	      (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)))
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..7c119de
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,74 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          package.lisp
+;;;; Purpose:       Package definition for cl-base64
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Dec 2002
+;;;;
+;;;; $Id: package.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;;
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+(defpackage #:cl-base64
+  (:nicknames #:base64)
+  (:use #:cl)
+  (:export #:base64-stream-to-integer
+	   #:base64-string-to-integer
+	   #:base64-string-to-string
+	   #:base64-stream-to-string
+	   #:base64-string-to-stream
+	   #:base64-stream-to-stream
+	   #:base64-string-to-usb8-array
+	   #:base64-stream-to-usb8-array
+	   #:string-to-base64-string
+	   #:string-to-base64-stream
+	   #:usb8-array-to-base64-string
+	   #:usb8-array-to-base64-stream
+	   #:stream-to-base64-string
+	   #:stream-to-base64-stream
+	   #:integer-to-base64-string
+	   #:integer-to-base64-stream
+
+	   ;; For creating custom encode/decode tables
+	   #:*uri-encode-table*
+	   #:*uri-decode-table*
+	   #:make-decode-table
+	   ))
+
+(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)))
+
+  (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))
+    
+  (defvar *decode-table* (make-decode-table *encode-table*))
+  
+  (defvar *uri-decode-table* (make-decode-table *uri-encode-table*))
+  
+  (declaim (type decode-table *decode-table* *uri-decode-table*))
+  
+  (defvar *pad-char* #\=)
+  (defvar *uri-pad-char* #\.)
+  (declaim (type character *pad-char* *uri-pad-char*))
+  )
-- 
GitLab