Skip to content
Snippets Groups Projects
Commit ecff5c55 authored by Kevin M. Rosenberg's avatar Kevin M. Rosenberg
Browse files

Updates for modern ASDF test-op. Performance and safety improvements (thanks to Janis Dzerins)

parent 9d5a88ec
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,6 @@ ...@@ -7,7 +7,6 @@
;;;; Programmer: Kevin M. Rosenberg ;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002 ;;;; Date Started: Dec 2002
;;;; ;;;;
;;;; $Id$
;;;; ************************************************************************* ;;;; *************************************************************************
(in-package #:cl-user) (in-package #:cl-user)
...@@ -18,27 +17,21 @@ ...@@ -18,27 +17,21 @@
(defsystem cl-base64 (defsystem cl-base64
:name "cl-base64" :name "cl-base64"
:author "Kevin M. Rosenberg based on initial code by Juri Pakaste" :author "Kevin M. Rosenberg based on initial code by Juri Pakaste"
:version "3.1" :version "3.4"
:maintainer "Kevin M. Rosenberg <kmr@debian.org>" :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
:licence "BSD-style" :licence "BSD-style"
:description "Base64 encoding and decoding with URI support." :description "Base64 encoding and decoding with URI support."
:components :components
((:file "package") ((:file "package")
(:file "encode" :depends-on ("package")) (:file "encode" :depends-on ("package"))
(:file "decode" :depends-on ("package")) (:file "decode" :depends-on ("package")))
)) :in-order-to ((test-op (test-op "cl-base64/test"))))
(defmethod perform ((o test-op) (c (eql (find-system 'cl-base64)))) (defsystem cl-base64/test
(operate 'load-op 'cl-base64-tests)
(operate 'test-op 'cl-base64-tests :force t))
(defsystem cl-base64-tests
:depends-on (cl-base64 ptester kmrcl) :depends-on (cl-base64 ptester kmrcl)
:components :components
((:file "tests"))) ((:file "tests"))
:perform (test-op (o s)
(defmethod perform ((o test-op) (c (eql (find-system 'cl-base64-tests)))) (or (funcall (intern (symbol-name '#:do-tests)
(operate 'load-op 'cl-base64-tests) (find-package '#:cl-base64/test)))
(or (funcall (intern (symbol-name '#:do-tests) (error "test-op failed"))))
(find-package '#:cl-base64-tests)))
(error "test-op failed")))
cl-base64 (3.4.0-1) unstable; urgency=medium
* New upstream.
Performance and safety improvements (thanks to Janis Dzerins)
-- Kevin M. Rosenberg <kmr@debian.org> Wed, 30 Sep 2020 18:06:36 +0000
cl-base64 (3.3.4-1) unstable; urgency=medium cl-base64 (3.3.4-1) unstable; urgency=medium
* New upstream. (closes:796978) Thanks to Denis Martinez. * New upstream. (closes:796978) Thanks to Denis Martinez.
......
7 11
...@@ -3,7 +3,7 @@ Section: lisp ...@@ -3,7 +3,7 @@ Section: lisp
Priority: optional Priority: optional
Maintainer: Kevin M. Rosenberg <kmr@debian.org> Maintainer: Kevin M. Rosenberg <kmr@debian.org>
Build-Depends-Indep: dh-lisp Build-Depends-Indep: dh-lisp
Build-Depends: debhelper (>= 7.0.0) Build-Depends: debhelper (>= 11.0.0)
Standards-Version: 3.9.5.0 Standards-Version: 3.9.5.0
Homepage: http://files.kpe.io/cl-base64/ Homepage: http://files.kpe.io/cl-base64/
Vcs-Git: git://git.kpe.io/cl-base64.git Vcs-Git: git://git.kpe.io/cl-base64.git
......
...@@ -21,236 +21,240 @@ ...@@ -21,236 +21,240 @@
(in-package #:cl-base64) (in-package #:cl-base64)
(declaim (inline whitespace-p)) (define-condition base64-error (error)
(defun whitespace-p (c) ((input
"Returns T for a whitespace character." :initarg :input
(or (char= c #\Newline) (char= c #\Linefeed) :reader base64-error-input)
(char= c #\Return) (char= c #\Space) (position
(char= c #\Tab))) :initarg :position
:reader base64-error-position
:type unsigned-byte)))
(define-condition bad-base64-character (base64-error)
((code :initarg :code :reader bad-base64-character-code))
(:report (lambda (condition stream)
(format stream "Bad character ~S at index ~D of ~S"
(code-char (bad-base64-character-code condition))
(base64-error-position condition)
(base64-error-input condition)))))
;;; Decoding (define-condition incomplete-base64-data (base64-error)
()
(:report (lambda (condition stream)
(format stream "Unexpected end of Base64 data at index ~D of ~S"
(base64-error-position condition)
(base64-error-input condition)))))
#+ignore (deftype array-index (&optional (length array-dimension-limit))
(defmacro def-base64-stream-to-* (output-type) `(integer 0 (,length)))
`(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-)
(symbol-name output-type))) (deftype array-length (&optional (length array-dimension-limit))
(input &key (uri nil) `(integer 0 ,length))
,@(when (eq output-type :stream)
'(stream))) (deftype character-code ()
,(concatenate 'string "Decode base64 stream to " (string-downcase `(integer 0 (,char-code-limit)))
(symbol-name output-type)))
(declare (stream input) (defmacro etypecase/unroll ((var &rest types) &body body)
(optimize (speed 3) (space 0) (safety 0))) #+sbcl `(etypecase ,var
(let ((pad (if uri *uri-pad-char* *pad-char*)) ,@(loop for type in types
(decode-table (if uri *uri-decode-table* *decode-table*))) collect `(,type ,@body)))
(declare (type decode-table decode-table) #-sbcl `(locally
(type character pad)) (declare (type (or ,@types) ,var))
(let (,@(case output-type ,@body))
(:string
'((result (make-string (* 3 (truncate (length string) 4)))))) (defmacro let/typed ((&rest vars) &body body)
`(let ,(loop for (var value) in vars
collect (list var value))
(declare ,@(loop for (var nil type) in vars
when type
collect (list 'type type var)))
,@body))
(defmacro define-base64-decoder (hose sink)
`(defun ,(intern (format nil "~A-~A-~A-~A" '#:base64 hose '#:to sink))
(input &key (table +decode-table+)
(uri nil)
,@(when (eq sink :stream) `(stream))
(whitespace :ignore))
,(format nil "~
Decode Base64 ~(~A~) to ~(~A~).
TABLE is the decode table to use. Two decode tables are provided:
+DECODE-TABLE+ (used by default) and +URI-DECODE-TABLE+. See
MAKE-DECODE-TABLE.
For backwards-compatibility the URI parameter is supported. If it is
true, then +URI-DECODE-TABLE+ is used, and the value for TABLE
parameter is ignored.
WHITESPACE can be one of:
:ignore - Whitespace characters are ignored (default).
:signal - Signal a BAD-BASE64-CHARACTER condition using SIGNAL.
:error - Signal a BAD-BASE64-CHARACTER condition using ERROR."
hose sink)
(declare (optimize (speed 3) (safety 1))
(type decode-table table)
(type ,(ecase hose
(:stream 'stream)
(:string 'string))
input))
(let/typed ((decode-table (if uri +uri-decode-table+ table)
decode-table)
,@(ecase sink
(:stream)
(:usb8-array (:usb8-array
'((result (make-array (* 3 (truncate (length string) 4)) (ecase hose
(:stream
`((result (make-array 1024
:element-type '(unsigned-byte 8) :element-type '(unsigned-byte 8)
:fill-pointer nil :adjustable t
:adjustable nil))))) :fill-pointer 0)
(ridx 0)) (array (unsigned-byte 8) (*)))))
(declare ,@(case output-type (:string
`((result (make-array (* 3 (ceiling (length input) 4))
:element-type '(unsigned-byte 8))
(simple-array (unsigned-byte 8) (*)))
(rpos 0 array-index)))))
(:string (:string
'((simple-string result))) (case hose
(:usb8-array
'((type (simple-array (unsigned-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
'stream) `((result (make-array 1024
((:string :usb8-array) :element-type 'character
'result) :adjustable t
;; ((:stream :string) :fill-pointer 0)
;; '(subseq result 0 ridx)))) (array character (*)))))
)) (:string
(declare (fixnum bitstore bitcount) `((result (make-array (* 3 (ceiling (length input) 4))
(character char)) :element-type 'character)
(let ((svalue (aref decode-table (the fixnum (char-code char))))) (simple-array character (*)))
(declare (fixnum svalue)) (rpos 0 array-index)))))
(:integer
`((result 0 unsigned-byte)))))
(flet ((bad-char (pos code &optional (action :error))
(let ((args (list 'bad-base64-character
:input input
:position pos
:code code)))
(ecase action
(:error
(apply #'error args))
(:cerror
(apply #'cerror "Ignore the error and continue." args))
(:signal
(apply #'signal args)))))
(incomplete-input (pos)
(error 'incomplete-base64-data :input input :position pos)))
,(let ((body
`(let/typed ((ipos 0 array-index)
(bitstore 0 (unsigned-byte 24))
(bitcount 0 (integer 0 14))
(svalue -1 (signed-byte 8))
(padchar 0 (integer 0 3))
(code 0 fixnum))
(loop
,@(ecase hose
(:string
`((if (< ipos length)
(setq code (char-code (aref input ipos)))
(return))))
(:stream
`((let ((char (read-char input nil nil)))
(if char
(setq code (char-code char))
(return))))))
(cond (cond
((>= svalue 0) ((or (< 127 code)
(setf bitstore (logior (= -1 (setq svalue (aref decode-table code))))
(the fixnum (ash bitstore 6)) (bad-char ipos code))
((= -2 svalue)
(cond ((<= (incf padchar) 2)
(unless (<= 2 bitcount)
(bad-char ipos code))
(decf bitcount 2))
(t
(bad-char ipos code))))
((= -3 svalue)
(ecase whitespace
(:ignore
;; Do nothing.
)
(:error
(bad-char ipos code :error))
(:signal
(bad-char ipos code :signal))))
((not (zerop padchar))
(bad-char ipos code))
(t
(setf bitstore (logior (the (unsigned-byte 24)
(ash bitstore 6))
svalue)) svalue))
(incf bitcount 6) (incf bitcount 6)
(when (>= bitcount 8) (when (>= bitcount 8)
(decf bitcount 8) (decf bitcount 8)
(let ((ovalue (the fixnum (let ((byte (logand (the (unsigned-byte 24)
(logand (ash bitstore (- bitcount)))
(the fixnum #xFF)))
(ash bitstore (declare (type (unsigned-byte 8) byte))
(the fixnum (- bitcount)))) ,@(ecase sink
#xFF))))
(declare (fixnum ovalue))
,(case output-type
(:string
'(setf (char result ridx) (code-char ovalue)))
(:usb8-array (:usb8-array
'(setf (aref result ridx) ovalue)) (ecase hose
(:string
`((setf (aref result rpos) byte)
(incf rpos)))
(:stream (:stream
'(write-char (code-char ovalue) stream))) `((vector-push-extend byte result)))))
(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 (:string
'((result (make-string (* 3 (truncate (length input) 4)))))) (ecase hose
(: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 (:string
'((simple-string result))) `((setf (schar result rpos)
(:usb8-array (code-char byte))
'((type (simple-array (unsigned-byte 8) (*)) result)))) (incf rpos)))
(fixnum ridx)) (:stream
(loop `((vector-push-extend (code-char byte)
for char of-type character across input result)))))
for svalue of-type fixnum = (aref decode-table (:integer
(the fixnum (char-code char))) `((setq result
with bitstore of-type fixnum = 0 (logior (ash result 8) byte))))
with bitcount of-type fixnum = 0 (:stream
do '((write-char (code-char byte) stream)))))
(cond (setf bitstore (logand bitstore #xFF)))))
((>= svalue 0) (incf ipos))
(setf bitstore (logior (unless (zerop bitcount)
(the fixnum (ash bitstore 6)) (incomplete-input ipos))
svalue)) ,(ecase sink
(incf bitcount 6) ((:string :usb8-array)
(when (>= bitcount 8) (ecase hose
(decf bitcount 8)
(let ((ovalue (the fixnum
(logand
(the fixnum
(ash bitstore
(the fixnum (- bitcount))))
#xFF))))
(declare (fixnum ovalue))
,(case output-type
(:string (:string
'(setf (char result ridx) (code-char ovalue))) `(if (= rpos (length result))
(:usb8-array result
'(setf (aref result ridx) ovalue)) (subseq result 0 rpos)))
(:stream (:stream
'(write-char (code-char ovalue) stream))) `(copy-seq result))))
(incf ridx) (:integer
(setf bitstore (the fixnum (logand bitstore #xFF)))))) 'result)
((char= char pad) (:stream
;; Could add checks to make sure padding is correct 'stream)))))
;; Currently, padding is ignored (ecase hose
) (:string
((whitespace-p char) `(let ((length (length input)))
;; Ignore whitespace (declare (type array-length length))
) (etypecase/unroll (input simple-base-string
((minusp svalue) simple-string
(warn "Bad character ~W in base64 decode" char)) string)
)) ,body)))
,(case output-type (:stream
(:stream body)))))))
'stream)
((:usb8-array :string) (define-base64-decoder :string :usb8-array)
'(subseq result 0 ridx))))))) (define-base64-decoder :string :string)
(define-base64-decoder :string :integer)
(define-base64-decoder :string :stream)
(def-base64-string-to-* :string) (define-base64-decoder :stream :usb8-array)
(def-base64-string-to-* :stream) (define-base64-decoder :stream :string)
(def-base64-string-to-* :usb8-array) (define-base64-decoder :stream :integer)
(define-base64-decoder :stream :stream)
;; input-mode can be :string or :stream ;; input-mode can be :string or :stream
;; input-format can be :character or :usb8 ;; 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)))))))
...@@ -33,7 +33,7 @@ ...@@ -33,7 +33,7 @@
(defun round-next-multiple (x n) (defun round-next-multiple (x n)
"Round x up to the next highest multiple of n." "Round x up to the next highest multiple of n."
(declare (fixnum n) (declare (fixnum n)
(optimize (speed 3) (safety 0) (space 0))) (optimize (speed 3) (safety 1) (space 0)))
(let ((remainder (mod x n))) (let ((remainder (mod x n)))
(declare (fixnum remainder)) (declare (fixnum remainder))
(if (zerop remainder) (if (zerop remainder)
...@@ -57,7 +57,7 @@ with a #\Newline." ...@@ -57,7 +57,7 @@ with a #\Newline."
(:usb8-array (:usb8-array
'((type (array (unsigned-byte 8) (*)) input)))) '((type (array (unsigned-byte 8) (*)) input))))
(fixnum columns) (fixnum columns)
(optimize (speed 3) (safety 0) (space 0))) (optimize (speed 3) (safety 1) (space 0)))
(let ((pad (if uri *uri-pad-char* *pad-char*)) (let ((pad (if uri *uri-pad-char* *pad-char*))
(encode-table (if uri *uri-encode-table* *encode-table*))) (encode-table (if uri *uri-encode-table* *encode-table*)))
(declare (simple-string encode-table) (declare (simple-string encode-table)
...@@ -212,7 +212,7 @@ with a #\Newline." ...@@ -212,7 +212,7 @@ with a #\Newline."
"Encode an integer to base64 format." "Encode an integer to base64 format."
(declare (integer input) (declare (integer input)
(fixnum columns) (fixnum columns)
(optimize (speed 3) (space 0) (safety 0))) (optimize (speed 3) (space 0) (safety 1)))
(let ((pad (if uri *uri-pad-char* *pad-char*)) (let ((pad (if uri *uri-pad-char* *pad-char*))
(encode-table (if uri *uri-encode-table* *encode-table*))) (encode-table (if uri *uri-encode-table* *encode-table*)))
(declare (simple-string encode-table) (declare (simple-string encode-table)
...@@ -271,7 +271,7 @@ with a #\Newline." ...@@ -271,7 +271,7 @@ with a #\Newline."
"Encode an integer to base64 format." "Encode an integer to base64 format."
(declare (integer input) (declare (integer input)
(fixnum columns) (fixnum columns)
(optimize (speed 3) (space 0) (safety 0))) (optimize (speed 3) (space 0) (safety 1)))
(let ((pad (if uri *uri-pad-char* *pad-char*)) (let ((pad (if uri *uri-pad-char* *pad-char*))
(encode-table (if uri *uri-encode-table* *encode-table*))) (encode-table (if uri *uri-encode-table* *encode-table*)))
(declare (simple-string encode-table) (declare (simple-string encode-table)
......
...@@ -15,13 +15,13 @@ ...@@ -15,13 +15,13 @@
(:nicknames #:base64) (:nicknames #:base64)
(:use #:cl) (:use #:cl)
(:export #:base64-stream-to-integer (:export #:base64-stream-to-integer
#:base64-stream-to-string
#:base64-stream-to-stream
#:base64-stream-to-usb8-array
#:base64-string-to-integer #:base64-string-to-integer
#:base64-string-to-string #:base64-string-to-string
#:base64-stream-to-string
#:base64-string-to-stream #:base64-string-to-stream
#:base64-stream-to-stream
#:base64-string-to-usb8-array #:base64-string-to-usb8-array
#:base64-stream-to-usb8-array
#:string-to-base64-string #:string-to-base64-string
#:string-to-base64-stream #:string-to-base64-stream
#:usb8-array-to-base64-string #:usb8-array-to-base64-string
...@@ -31,17 +31,23 @@ ...@@ -31,17 +31,23 @@
#:integer-to-base64-string #:integer-to-base64-string
#:integer-to-base64-stream #:integer-to-base64-stream
;; For creating custom encode/decode tables ;; Conditions.
#:base64-error
#:bad-base64-character
#:incomplete-base64-data
;; For creating custom encode/decode tables.
#:make-decode-table
#:+decode-table+
#:+uri-decode-table+
;; What's the point of exporting these?
#:*uri-encode-table* #:*uri-encode-table*
#:*uri-decode-table* #:*uri-decode-table*
#:make-decode-table
#:test-base64
)) ))
(in-package #:cl-base64) (in-package #:cl-base64)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *encode-table* (defvar *encode-table*
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(declaim (type simple-string *encode-table*)) (declaim (type simple-string *encode-table*))
...@@ -50,22 +56,38 @@ ...@@ -50,22 +56,38 @@
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
(declaim (type simple-string *uri-encode-table*)) (declaim (type simple-string *uri-encode-table*))
(deftype decode-table () '(simple-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 *pad-char* #\=) (defvar *pad-char* #\=)
(defvar *uri-pad-char* #\.) (defvar *uri-pad-char* #\.)
(declaim (type character *pad-char* *uri-pad-char*)) (declaim (type character *pad-char* *uri-pad-char*))
(deftype decode-table () '(simple-array (signed-byte 8) (128)))
(defun make-decode-table (encode-table pad-char
&key (whitespace-chars
'(#\Linefeed #\Return #\Space #\Tab)))
(assert (< (length encode-table) 128)
(encode-table)
"Encode table too big: ~S" encode-table)
(let ((dt (make-array 128 :element-type '(signed-byte 8)
:initial-element -1)))
(declare (type decode-table dt))
(loop for char across encode-table
for index upfrom 0
do (setf (aref dt (char-code char)) index))
(setf (aref dt (char-code pad-char)) -2)
(loop for char in whitespace-chars
do (setf (aref dt (char-code char)) -3))
dt)))
(defconstant +decode-table+
(if (boundp '+decode-table+)
(symbol-value '+decode-table+)
(make-decode-table *encode-table* *pad-char*)))
(defvar *decode-table* +decode-table+ "Deprecated.")
(declaim (type decode-table +decode-table+ *decode-table*))
(defconstant +uri-decode-table+
(if (boundp '+uri-decode-table+)
(symbol-value '+uri-decode-table+)
(make-decode-table *uri-encode-table* *uri-pad-char*)))
(defvar *uri-decode-table* +uri-decode-table+ "Deprecated.")
(declaim (type decode-table +uri-decode-table+ *uri-decode-table*))
...@@ -12,14 +12,86 @@ ...@@ -12,14 +12,86 @@
(in-package #:cl-user) (in-package #:cl-user)
(defpackage #:cl-base64-tests (defpackage #:cl-base64/test
(:use #:cl #:kmrcl #:cl-base64 #:ptester)) (:use #:cl #:kmrcl #:cl-base64 #:ptester))
(in-package #:cl-base64-tests) (in-package #:cl-base64/test)
(defun do-tests () (defun test-valid-input (exp input)
(test exp (base64-string-to-usb8-array input) :test #'equalp))
(defun test-broken-input (arg)
(let ((.hole. (make-broadcast-stream)))
(test-error (base64-string-to-usb8-array arg)
:condition-type 'base64-error
:include-subtypes t)
(test-error (base64-string-to-string arg)
:condition-type 'base64-error
:include-subtypes t)
(test-error (base64-string-to-integer arg)
:condition-type 'base64-error
:include-subtypes t)
(test-error (base64-string-to-stream arg :stream .hole.)
:condition-type 'base64-error
:include-subtypes t)
(test-error (with-input-from-string (in arg)
(base64-stream-to-usb8-array in))
:condition-type 'base64-error
:include-subtypes t)
(test-error (with-input-from-string (in arg)
(base64-stream-to-string in))
:condition-type 'base64-error
:include-subtypes t)
(test-error (with-input-from-string (in arg)
(base64-stream-to-stream in :stream .hole.))
:condition-type 'base64-error
:include-subtypes t)
(test-error (with-input-from-string (in arg)
(base64-stream-to-integer in))
:condition-type 'base64-error
:include-subtypes t)))
(defun test-valid ()
(test-valid-input #(0) "AA==")
(test-valid-input #(0 0) "AAA=")
(test-valid-input #(0 0 0) "AAAA")
(test-valid-input #(0) " A A = = ")
(test-valid-input #(0 0) " A A A = ")
(test-valid-input #(0 0 0) " A A A A "))
(defun test-broken-1 ()
(test-broken-input "A")
(test-broken-input "AA")
(test-broken-input "AAA")
(test-broken-input "AA=")
(test-broken-input "A==")
(test-broken-input "A===")
(test-broken-input "AA===")
(test-broken-input "AAA===")
(test-broken-input "AAA==")
(test-broken-input "A=A")
(test-broken-input "AA=A")
(test-broken-input "AAA=A")
(test-broken-input "A==A"))
(defun test-broken-2 ()
(flet ((test-invalid-char (char)
(test-broken-input (format nil "~C" char))
(test-broken-input (format nil "A~C" char))
(test-broken-input (format nil "AA~C" char))
(test-broken-input (format nil "AAA~C" char))
(test-broken-input (format nil "AAAA~C" char))
(test-broken-input (format nil "AAA=~C" char))
(test-broken-input (format nil "AA==~C" char))))
(test-invalid-char #\$)
(test-invalid-char (code-char 0))
(test-invalid-char (code-char 256))))
(defun do-tests (&key ((:break-on-failures *break-on-test-failures*) nil))
(with-tests (:name "cl-base64 tests") (with-tests (:name "cl-base64 tests")
(let ((*break-on-test-failures* t)) (test-valid)
(test-broken-1)
(test-broken-2)
(do* ((length 0 (+ 3 length)) (do* ((length 0 (+ 3 length))
(string (make-string length) (make-string length)) (string (make-string length) (make-string length))
(usb8 (make-usb8-array length) (make-usb8-array length)) (usb8 (make-usb8-array length) (make-usb8-array length))
...@@ -39,6 +111,9 @@ ...@@ -39,6 +111,9 @@
(test string (base64-string-to-string (test string (base64-string-to-string
(string-to-base64-string string :columns columns)) (string-to-base64-string string :columns columns))
:test #'string=) :test #'string=)
(test usb8 (base64-string-to-usb8-array
(usb8-array-to-base64-string usb8))
:test #'equalp)
;; Test against AllegroCL built-in routines ;; Test against AllegroCL built-in routines
#+allegro #+allegro
...@@ -59,18 +134,35 @@ ...@@ -59,18 +134,35 @@
(if (zerop columns) (if (zerop columns)
nil nil
columns))) columns)))
:test #'string=)))))) :test #'string=)))))
t) t)
(defun time-routines () (defun time-routines (&key (iterations nil)
(let* ((str "abcdefghijklmnopqwertyu1234589jhwf2ff") (length 256)
(usb8 (string-to-usb8-array str)) (padding 0))
(assert (zerop (rem length 4)) (length))
(assert (<= 0 padding 2) (padding))
(let* ((str (make-string length :initial-element #\q))
(usb8 (map '(simple-array (unsigned-byte 8) (*)) #'char-code str))
(int 12345678901234567890) (int 12345678901234567890)
(n 50000)) (n (or iterations (ceiling (* 32 1024 1024) length))))
(time-iterations n (integer-to-base64-string int)) (loop for i downfrom (1- length)
repeat padding
do (setf (aref str i) #\=))
(time-iterations 50000 (integer-to-base64-string int))
(time-iterations n (string-to-base64-string str)) (time-iterations n (string-to-base64-string str))
#+allego (time-iterations n (usb8-array-to-base64-string usb8))
(let ((displaced (make-array (length str)
:displaced-to str
:element-type (array-element-type str)))
(base (coerce str 'simple-base-string)))
(time-iterations n (base64-string-to-usb8-array displaced))
(time-iterations n (base64-string-to-usb8-array str))
(time-iterations n (base64-string-to-usb8-array base)))
#+allegro
(progn (progn
(time-iterations n (excl:integer-to-base64-string int)) (time-iterations n (excl:integer-to-base64-string int))
(time-iterations n (excl:usb8-array-to-base64-string usb8))))) (time-iterations n (excl:usb8-array-to-base64-string usb8)))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment