From 98dfcc6acae8710d4577652fcb2b7c12ee86da22 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 13 Jan 2003 21:40:20 +0000 Subject: [PATCH] r3750: *** empty log message *** --- debian/changelog | 7 +- encode.lisp | 270 +++++++++++++++++++++++++---------------------- test.lisp | 75 +++++++++++++ 3 files changed, 223 insertions(+), 129 deletions(-) create mode 100644 test.lisp diff --git a/debian/changelog b/debian/changelog index 81e12a0..fb13c48 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,10 +1,11 @@ cl-base64 (3.0.0-1) unstable; urgency=low + * Remove src.lisp and add package.lisp, decode.lisp, encode.lisp + * Add support for usb8-arrays + * Rewrite routines as macros to create efficient functions for + converting to and from streams, strings, and usb8-arrays. * 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 Sat, 4 Jan 2003 06:40:32 -0700 diff --git a/encode.lisp b/encode.lisp index d079515..803c9ce 100644 --- a/encode.lisp +++ b/encode.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: encode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $ +;;;; $Id: encode.lisp,v 1.3 2003/01/13 21:38:01 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.2 2003/01/12 22:32:40 kevin Exp $ +;;;; $Id: encode.lisp,v 1.3 2003/01/13 21:38:01 kevin Exp $ (in-package #:cl-base64) @@ -123,16 +123,23 @@ with a #\Newline." (the fixnum (+ (the fixnum - (ash (char-code (the character - (char string isource))) 16)) + (ash (the fixnum + (char-code (the character + (char string isource)))) + 16)) (the fixnum - (ash (char-code (the character - (char string (1+ isource)))) 8)))) + (ash (the fixnum + (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)) + (ash + (the fixnum + (char-code (the character (char string isource)))) + 16)) 2))) result) (declare (fixnum igroup isource)) @@ -150,22 +157,22 @@ with a #\Newline." (defmacro def-*-to-base64-* (input-type output-type) `(defun ,(intern (concatenate 'string (symbol-name input-type) - (symbol-name :-to-base-64-) + (symbol-name :-to-base64-) (symbol-name output-type))) (input ,@(when (eq output-type :stream) - 'output) + '(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)))) + (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) @@ -174,126 +181,137 @@ with a #\Newline." (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 + ,@(when (eq output-type :string) + '((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)) + (result (make-string strlen)) + (ioutput 0))) + (col (if (plusp columns) 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)) + (1+ padded-length)))) + (declare (fixnum string-length padded-length col + ,@(when (eq output-type :string) + '(ioutput))) + ,@(when (eq output-type :string) + '((simple-string result)))) + (labels ((output-char (ch) + (if (= col columns) + (progn + ,@(case output-type + (:stream + '((write-char #\Newline output))) + (:string + '((setf (schar result ioutput) #\Newline) + (incf ioutput)))) + (setq col 1)) + (incf col)) + ,@(case output-type + (:stream + '((write-char ch output))) + (:string + '((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 + (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 + (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 + (ash + ,(case input-type + (:string + '(char-code (the character (char input isource)))) + (:usb8-array + '(the fixnum (aref input isource)))) + 16)) + 2))) + ,(case output-type + (:string + 'result) + (:stream + 'output))) + (declare (fixnum igroup isource)) + (output-group + (the fixnum + (+ + (the fixnum + (ash + (the fixnum + ,(case input-type + (:string + '(char-code (the character (char input isource)))) + (:usb8-array + '(aref input isource)))) + 16)) + (the fixnum + (ash + (the fixnum ,(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)))))))) + (:usb8-array + '(aref input (1+ isource))))) + 8)) + (the fixnum + ,(case input-type + (:string + '(char-code (the character (char input (+ 2 isource))))) + (:usb8-array + '(aref input (+ 2 isource)))) + ))) + 4))))))) (def-*-to-base64-* :string :string) (def-*-to-base64-* :string :stream) diff --git a/test.lisp b/test.lisp new file mode 100644 index 0000000..a21da95 --- /dev/null +++ b/test.lisp @@ -0,0 +1,75 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test.lisp +;;;; Purpose: Regression tests for cl-base64 +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jan 2003 +;;;; +;;;; $Id: test.lisp,v 1.1 2003/01/13 21:39:46 kevin Exp $ +;;;; ************************************************************************* + +(in-package :cl-user) + +(defpackage #:base64-test + (:use #:cl #:kmrcl #:base64 #:util.test)) + +(in-package #:base64-test) + +(defun test-base64 () + (with-tests (:name "cl-base64 tests") + (do* ((length 0 (+ 3 length)) + (string (make-string length) (make-string length)) + (usb8 (make-usb8-array length) (make-usb8-array length)) + (integer (random (expt 10 length)) (random (expt 10 length)))) + ((>= length 300)) + (dotimes (i length) + (declare (fixnum i)) + (let ((code (random 256))) + (setf (schar string i) (code-char code)) + (setf (aref usb8 i) code))) + + (do* ((columns 0 (+ columns 4))) + ((> columns length)) + ;; Test against cl-base64 routines + (test integer (base64-string-to-integer + (integer-to-base64-string integer :columns columns))) + (test string (base64-string-to-string + (string-to-base64-string string :columns columns)) + :test #'string=) + + ;; Test against AllegroCL built-in routines + #+allegro + (progn + (test integer (excl:base64-string-to-integer + (integer-to-base64-string integer :columns columns))) + (test integer (base64-string-to-integer + (excl:integer-to-base64-string integer))) + (test (string-to-base64-string string :columns columns) + (excl:usb8-array-to-base64-string usb8 + (if (zerop columns) + nil + columns)) + :test #'string=) + (test string (base64-string-to-string + (excl:usb8-array-to-base64-string + usb8 + (if (zerop columns) + nil + columns))) + :test #'string=)))))) + + +(defun time-routines () + (let* ((str "abcdefghijklmnopqwertyu1234589jhwf2ff") + (usb8 (string-to-usb8-array str)) + (int 12345678901234567890) + (n 50000)) + (time-iterations n (integer-to-base64 int)) + (time-iterations n (excl:integer-to-base64-string int)) + (time-iterations n (string-to-base64 str)) + (time-iterations n (excl:usb8-array-to-base64-string usb8)))) + + +;;#+run-test (test-base64) -- 2.34.1