;;;; Purpose: ASDF definition file for Cl-Base64
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
-;;;;
-;;;; $Id$
;;;; *************************************************************************
(in-package #:cl-user)
(defpackage #:cl-base64-system (:use #:asdf #:cl))
(in-package #:cl-base64-system)
-
(defsystem cl-base64
:name "cl-base64"
:author "Kevin M. Rosenberg based on initial code by Juri Pakaste"
- :version "3.1"
+ :version "3.4"
:maintainer "Kevin M. Rosenberg <kmr@debian.org>"
:licence "BSD-style"
:description "Base64 encoding and decoding with URI support."
:components
((:file "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))))
- (operate 'load-op 'cl-base64-tests)
- (operate 'test-op 'cl-base64-tests :force t))
-
-(defsystem cl-base64-tests
+(defsystem cl-base64/test
:depends-on (cl-base64 ptester kmrcl)
:components
- ((:file "tests")))
-
-(defmethod perform ((o test-op) (c (eql (find-system 'cl-base64-tests))))
- (operate 'load-op 'cl-base64-tests)
- (or (funcall (intern (symbol-name '#:do-tests)
- (find-package '#:cl-base64-tests)))
- (error "test-op failed")))
+ ((:file "tests"))
+ :perform (test-op (o s)
+ (or (funcall (intern (symbol-name '#:do-tests)
+ (find-package '#:cl-base64/test)))
+ (error "test-op failed"))))
-cl-base64 (3.3.4-2) unstable; urgency=medium
+cl-base64 (3.4.0-1) unstable; urgency=medium
- * Switch to dpkg-source 3.0 (quilt) format
+ * New upstream.
+ Performance and safety improvements (thanks to Janis Dzerins)
- -- Kevin M. Rosenberg <kmr@debian.org> Wed, 26 Aug 2015 23:42:04 -0600
+ -- Kevin M. Rosenberg <kmr@debian.org> Wed, 30 Sep 2020 18:06:36 +0000
cl-base64 (3.3.4-1) unstable; urgency=medium
* New upstream. (closes:796978) Thanks to Denis Martinez.
+ * Switch to dpkg-source 3.0 (quilt) format
- -- Kevin M. Rosenberg <kmr@debian.org> Wed, 26 Aug 2015 23:39:46 -0600
+ -- Kevin M. Rosenberg <kmr@debian.org> Sun, 30 Aug 2015 21:02:49 -0600
cl-base64 (3.3.3-2) unstable; urgency=low
Priority: optional
Maintainer: Kevin M. Rosenberg <kmr@debian.org>
Build-Depends-Indep: dh-lisp
-Build-Depends: debhelper (>= 7.0.0)
+Build-Depends: debhelper (>= 11.0.0)
Standards-Version: 3.9.5.0
-Homepage: http://files.b9.com/cl-base64/
-Vcs-Git: git://git.b9.com/cl-base64.git
-Vcs-Browser: http://git.b9.com/?p=cl-base64.git
+Homepage: http://files.kpe.io/cl-base64/
+Vcs-Git: git://git.kpe.io/cl-base64.git
+Vcs-Browser: http://git.kpe.io/?p=cl-base64.git
Package: cl-base64
Architecture: all
This package was debianized by Kevin M. Rosenberg <kmr@debian.org> in
Dec 2002.
-It was downloaded from http://files.b9.com/base64/
+It was downloaded from http://files.kpe.io/base64/
Upstream Author: Kevin M. Rosenberg <kevin@rosenberg.net>
This code is based on code placed in the public domain by Juri Pakaste
#!/bin/bash -e
-dup cl-base64 -Ufiles.b9.com -D/home/ftp/cl-base64 -su \
+dup cl-base64 -Ufiles.kpe.io -D/home/ftp/cl-base64 -su \
-C"(umask 022; cd /srv/www/html/cl-base64; make install; find . -type d |xargs chmod go+rx; find . -type f | xargs chmod go+r)" $*
version=3
-http://files.b9.com/cl-base64/cl-base64-(\d+.*)\.tar\.gz
+http://files.kpe.io/cl-base64/cl-base64-(\d+.*)\.tar\.gz
(in-package #:cl-base64)
-(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)))
+(define-condition base64-error (error)
+ ((input
+ :initarg :input
+ :reader base64-error-input)
+ (position
+ :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
-(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)))
- ,(concatenate 'string "Decode base64 stream to " (string-downcase
- (symbol-name output-type)))
- (declare (stream input)
- (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)
- (type character pad))
- (let (,@(case output-type
- (:string
- '((result (make-string (* 3 (truncate (length string) 4))))))
+(deftype array-index (&optional (length array-dimension-limit))
+ `(integer 0 (,length)))
+
+(deftype array-length (&optional (length array-dimension-limit))
+ `(integer 0 ,length))
+
+(deftype character-code ()
+ `(integer 0 (,char-code-limit)))
+
+(defmacro etypecase/unroll ((var &rest types) &body body)
+ #+sbcl `(etypecase ,var
+ ,@(loop for type in types
+ collect `(,type ,@body)))
+ #-sbcl `(locally
+ (declare (type (or ,@types) ,var))
+ ,@body))
+
+(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
- '((result (make-array (* 3 (truncate (length string) 4))
+ (ecase hose
+ (:stream
+ `((result (make-array 1024
:element-type '(unsigned-byte 8)
- :fill-pointer nil
- :adjustable nil)))))
- (ridx 0))
- (declare ,@(case output-type
+ :adjustable t
+ :fill-pointer 0)
+ (array (unsigned-byte 8) (*)))))
+ (:string
+ `((result (make-array (* 3 (ceiling (length input) 4))
+ :element-type '(unsigned-byte 8))
+ (simple-array (unsigned-byte 8) (*)))
+ (rpos 0 array-index)))))
(:string
- '((simple-string result)))
- (: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
+ (case hose
(:stream
- 'stream)
- ((:string :usb8-array)
- 'result)
- ;; ((: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))
+ `((result (make-array 1024
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0)
+ (array character (*)))))
+ (:string
+ `((result (make-array (* 3 (ceiling (length input) 4))
+ :element-type 'character)
+ (simple-array character (*)))
+ (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
- ((>= svalue 0)
- (setf bitstore (logior
- (the fixnum (ash bitstore 6))
+ ((or (< 127 code)
+ (= -1 (setq svalue (aref decode-table code))))
+ (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))
(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)))
+ (let ((byte (logand (the (unsigned-byte 24)
+ (ash bitstore (- bitcount)))
+ #xFF)))
+ (declare (type (unsigned-byte 8) byte))
+ ,@(ecase sink
(:usb8-array
- '(setf (aref result ridx) ovalue))
+ (ecase hose
+ (:string
+ `((setf (aref result rpos) byte)
+ (incf rpos)))
(: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) (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
+ `((vector-push-extend byte result)))))
(: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
+ (ecase hose
(:string
- '((simple-string result)))
- (:usb8-array
- '((type (simple-array (unsigned-byte 8) (*)) result))))
- (fixnum ridx))
- (loop
- 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
- 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 ((ovalue (the fixnum
- (logand
- (the fixnum
- (ash bitstore
- (the fixnum (- bitcount))))
- #xFF))))
- (declare (fixnum ovalue))
- ,(case output-type
+ `((setf (schar result rpos)
+ (code-char byte))
+ (incf rpos)))
+ (:stream
+ `((vector-push-extend (code-char byte)
+ result)))))
+ (:integer
+ `((setq result
+ (logior (ash result 8) byte))))
+ (:stream
+ '((write-char (code-char byte) stream)))))
+ (setf bitstore (logand bitstore #xFF)))))
+ (incf ipos))
+ (unless (zerop bitcount)
+ (incomplete-input ipos))
+ ,(ecase sink
+ ((:string :usb8-array)
+ (ecase hose
(:string
- '(setf (char result ridx) (code-char ovalue)))
- (:usb8-array
- '(setf (aref result ridx) ovalue))
+ `(if (= rpos (length result))
+ result
+ (subseq result 0 rpos)))
(: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))
- ))
- ,(case output-type
- (:stream
- 'stream)
- ((:usb8-array :string)
- '(subseq result 0 ridx)))))))
+ `(copy-seq result))))
+ (:integer
+ 'result)
+ (:stream
+ 'stream)))))
+ (ecase hose
+ (:string
+ `(let ((length (length input)))
+ (declare (type array-length length))
+ (etypecase/unroll (input simple-base-string
+ simple-string
+ string)
+ ,body)))
+ (:stream
+ body)))))))
+
+(define-base64-decoder :string :usb8-array)
+(define-base64-decoder :string :string)
+(define-base64-decoder :string :integer)
+(define-base64-decoder :string :stream)
-(def-base64-string-to-* :string)
-(def-base64-string-to-* :stream)
-(def-base64-string-to-* :usb8-array)
+(define-base64-decoder :stream :usb8-array)
+(define-base64-decoder :stream :string)
+(define-base64-decoder :stream :integer)
+(define-base64-decoder :stream :stream)
;; 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) (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)))))))
(defun round-next-multiple (x n)
"Round x up to the next highest multiple of n."
(declare (fixnum n)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 1) (space 0)))
(let ((remainder (mod x n)))
(declare (fixnum remainder))
(if (zerop remainder)
(:usb8-array
'((type (array (unsigned-byte 8) (*)) input))))
(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*))
(encode-table (if uri *uri-encode-table* *encode-table*)))
(declare (simple-string encode-table)
"Encode an integer to base64 format."
(declare (integer input)
(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*))
(encode-table (if uri *uri-encode-table* *encode-table*)))
(declare (simple-string encode-table)
"Encode an integer to base64 format."
(declare (integer input)
(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*))
(encode-table (if uri *uri-encode-table* *encode-table*)))
(declare (simple-string encode-table)
(:nicknames #:base64)
(:use #:cl)
(: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-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
#:integer-to-base64-string
#: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-decode-table*
- #:make-decode-table
-
- #:test-base64
))
(in-package #:cl-base64)
-
+(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *encode-table*
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(declaim (type simple-string *encode-table*))
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
(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 *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*))
(in-package #:cl-user)
-(defpackage #:cl-base64-tests
+(defpackage #:cl-base64/test
(: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")
- (let ((*break-on-test-failures* t))
+ (test-valid)
+ (test-broken-1)
+ (test-broken-2)
(do* ((length 0 (+ 3 length))
(string (make-string length) (make-string length))
(usb8 (make-usb8-array length) (make-usb8-array length))
(test string (base64-string-to-string
(string-to-base64-string string :columns columns))
:test #'string=)
+ (test usb8 (base64-string-to-usb8-array
+ (usb8-array-to-base64-string usb8))
+ :test #'equalp)
;; Test against AllegroCL built-in routines
#+allegro
(if (zerop columns)
nil
columns)))
- :test #'string=))))))
+ :test #'string=)))))
t)
-(defun time-routines ()
- (let* ((str "abcdefghijklmnopqwertyu1234589jhwf2ff")
- (usb8 (string-to-usb8-array str))
+(defun time-routines (&key (iterations nil)
+ (length 256)
+ (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)
- (n 50000))
- (time-iterations n (integer-to-base64-string int))
+ (n (or iterations (ceiling (* 32 1024 1024) length))))
+ (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))
- #+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
(time-iterations n (excl:integer-to-base64-string int))
(time-iterations n (excl:usb8-array-to-base64-string usb8)))))
projects / cl-base64.git / commitdiff