Author: hhubner Date: 2006-10-15 19:21:43 -0400 (Sun, 15 Oct 2006) New Revision: 2005
Added: branches/xml-class-rework/thirdparty/cl-base64/ branches/xml-class-rework/thirdparty/cl-base64/COPYING branches/xml-class-rework/thirdparty/cl-base64/cl-base64.asd branches/xml-class-rework/thirdparty/cl-base64/decode.lisp branches/xml-class-rework/thirdparty/cl-base64/encode.lisp branches/xml-class-rework/thirdparty/cl-base64/package.lisp branches/xml-class-rework/thirdparty/cl-base64/tests.lisp Log: Import cl-base64-3.3.2
Added: branches/xml-class-rework/thirdparty/cl-base64/COPYING =================================================================== --- branches/xml-class-rework/thirdparty/cl-base64/COPYING 2006-10-15 23:20:32 UTC (rev 2004) +++ branches/xml-class-rework/thirdparty/cl-base64/COPYING 2006-10-15 23:21:43 UTC (rev 2005) @@ -0,0 +1,26 @@ +Copyright (c) 2002-2003 by Kevin Rosenberg + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the Authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/xml-class-rework/thirdparty/cl-base64/cl-base64.asd =================================================================== --- branches/xml-class-rework/thirdparty/cl-base64/cl-base64.asd 2006-10-15 23:20:32 UTC (rev 2004) +++ branches/xml-class-rework/thirdparty/cl-base64/cl-base64.asd 2006-10-15 23:21:43 UTC (rev 2005) @@ -0,0 +1,46 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: cl-base64.asd +;;;; Purpose: ASDF definition file for Cl-Base64 +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id: cl-base64.asd 11051 2006-08-27 18:23:13Z kevin $ +;;;; ************************************************************************* + +(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" + :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")) + )) + +(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 + :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")))
Added: branches/xml-class-rework/thirdparty/cl-base64/decode.lisp =================================================================== --- branches/xml-class-rework/thirdparty/cl-base64/decode.lisp 2006-10-15 23:20:32 UTC (rev 2004) +++ branches/xml-class-rework/thirdparty/cl-base64/decode.lisp 2006-10-15 23:21:43 UTC (rev 2005) @@ -0,0 +1,256 @@ +;;;; -*- 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 7061 2003-09-07 06:34:45Z kevin $ +;;;; +;;;; 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 +;;;; ************************************************************************* + +(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))) + + +;;; Decoding + +#+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)))))) + (: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 (simple-array (usigned-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) + ((: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)) + (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 + '(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) (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 + '((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 (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 + (: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)))))) + ((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))))))) + +(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) (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)))))))
Added: branches/xml-class-rework/thirdparty/cl-base64/encode.lisp =================================================================== --- branches/xml-class-rework/thirdparty/cl-base64/encode.lisp 2006-10-15 23:20:32 UTC (rev 2004) +++ branches/xml-class-rework/thirdparty/cl-base64/encode.lisp 2006-10-15 23:21:43 UTC (rev 2005) @@ -0,0 +1,322 @@ +;;;; -*- 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 7061 2003-09-07 06:34:45Z kevin $ +;;;; +;;;; 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 +;;;; ************************************************************************* + +;;;; Extended by Kevin M. Rosenberg kevin@rosenberg.net: +;;;; - .asd file +;;;; - numerous speed optimizations +;;;; - conversion to and from integers +;;;; - Renamed functions now that supporting integer conversions +;;;; - URI-compatible encoding using :uri key +;;;; +;;;; $Id: encode.lisp 7061 2003-09-07 06:34:45Z kevin $ + +(in-package #:cl-base64) + +(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))) + (let ((remainder (mod x n))) + (declare (fixnum remainder)) + (if (zerop remainder) + x + (the fixnum (+ x (the fixnum (- n remainder))))))) + +(defmacro def-*-to-base64-* (input-type output-type) + `(defun ,(intern (concatenate 'string (symbol-name input-type) + (symbol-name :-to-base64-) + (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 (unsigned-byte 8) (*)) input)))) + (fixnum columns) + (optimize (speed 3) (safety 0) (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) + (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))) + ,@(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 + (the fixnum (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 (the fixnum (1+ igroup))) + (isource 0 (the fixnum (+ 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 + (the fixnum (1+ isource)))))) + (:usb8-array + '(the fixnum (aref input (the fixnum + (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 + (the fixnum (1+ isource)))))) + (:usb8-array + '(aref input (1+ isource))))) + 8)) + (the fixnum + ,(case input-type + (:string + '(char-code (the character (char input + (the fixnum (+ 2 isource)))))) + (:usb8-array + '(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." + (declare (integer input) + (fixnum columns) + (optimize (speed 3) (space 0) (safety 0))) + (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* ((input-bits (integer-length input)) + (byte-bits (round-next-multiple input-bits 8)) + (padded-bits (round-next-multiple byte-bits 6)) + (remainder-padding (mod padded-bits 24)) + (padding-bits (if (zerop remainder-padding) + 0 + (- 24 remainder-padding))) + (padding-chars (/ padding-bits 6)) + (padded-length (/ (+ padded-bits padding-bits) 6)) + (last-line-len (if (plusp columns) + (- padded-length (* columns + (truncate + padded-length columns))) + 0)) + (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)) + (last-char (1- strlen)) + (str (make-string strlen)) + (col (if (zerop last-line-len) + columns + last-line-len))) + (declare (fixnum padded-length num-lines col last-char + padding-chars last-line-len)) + (unless (plusp columns) + (setq col -1)) ;; set to flag to optimize in loop + + (dotimes (i padding-chars) + (declare (fixnum i)) + (setf (schar str (the fixnum (- last-char i))) pad)) + + (do* ((strpos (- last-char padding-chars) (1- strpos)) + (int (ash input (/ padding-bits 3)))) + ((minusp strpos) + str) + (declare (fixnum strpos) (integer int)) + (cond + ((zerop col) + (setf (schar str strpos) #\Newline) + (setq col columns)) + (t + (setf (schar str strpos) + (schar encode-table (the fixnum (logand int #x3f)))) + (setq int (ash int -6)) + (decf col))))))) + +(defun integer-to-base64-stream (input stream &key (uri nil) (columns 0)) + "Encode an integer to base64 format." + (declare (integer input) + (fixnum columns) + (optimize (speed 3) (space 0) (safety 0))) + (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* ((input-bits (integer-length input)) + (byte-bits (round-next-multiple input-bits 8)) + (padded-bits (round-next-multiple byte-bits 6)) + (remainder-padding (mod padded-bits 24)) + (padding-bits (if (zerop remainder-padding) + 0 + (- 24 remainder-padding))) + (padding-chars (/ padding-bits 6)) + (padded-length (/ (+ padded-bits padding-bits) 6)) + (strlen padded-length) + (nonpad-chars (- strlen padding-chars)) + (last-nonpad-char (1- nonpad-chars)) + (str (make-string strlen))) + (declare (fixnum padded-length last-nonpad-char)) + (do* ((strpos 0 (the fixnum (1+ strpos))) + (int (ash input (/ padding-bits 3)) (ash int -6)) + (6bit-value (the fixnum (logand int #x3f)) + (the fixnum (logand int #x3f)))) + ((= strpos nonpad-chars) + (let ((col 0)) + (declare (fixnum col)) + (dotimes (i nonpad-chars) + (declare (fixnum i)) + (write-char (schar str i) stream) + (when (plusp columns) + (incf col) + (when (= col columns) + (write-char #\Newline stream) + (setq col 0)))) + (dotimes (ipad padding-chars) + (declare (fixnum ipad)) + (write-char pad stream) + (when (plusp columns) + (incf col) + (when (= col columns) + (write-char #\Newline stream) + (setq col 0))))) + stream) + (declare (fixnum 6bit-value strpos) + (integer int)) + (setf (schar str (- last-nonpad-char strpos)) + (schar encode-table 6bit-value)) + )))) +
Added: branches/xml-class-rework/thirdparty/cl-base64/package.lisp =================================================================== --- branches/xml-class-rework/thirdparty/cl-base64/package.lisp 2006-10-15 23:20:32 UTC (rev 2004) +++ branches/xml-class-rework/thirdparty/cl-base64/package.lisp 2006-10-15 23:21:43 UTC (rev 2005) @@ -0,0 +1,71 @@ +;;; -*- 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 7061 2003-09-07 06:34:45Z kevin $ +;;;; +;;;; ************************************************************************* + +(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 + + #:test-base64 + )) + +(in-package #:cl-base64) + + +(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))) + +(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*))
Added: branches/xml-class-rework/thirdparty/cl-base64/tests.lisp =================================================================== --- branches/xml-class-rework/thirdparty/cl-base64/tests.lisp 2006-10-15 23:20:32 UTC (rev 2004) +++ branches/xml-class-rework/thirdparty/cl-base64/tests.lisp 2006-10-15 23:21:43 UTC (rev 2005) @@ -0,0 +1,79 @@ +;;;; -*- 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: tests.lisp 9055 2004-04-18 16:49:36Z kevin $ +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:cl-base64-tests + (:use #:cl #:kmrcl #:cl-base64 #:ptester)) + +(in-package #:cl-base64-tests) + +(defun do-tests () + (with-tests (:name "cl-base64 tests") + (let ((*break-on-test-failures* t)) + (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=)))))) + t) + + +(defun time-routines () + (let* ((str "abcdefghijklmnopqwertyu1234589jhwf2ff") + (usb8 (string-to-usb8-array str)) + (int 12345678901234567890) + (n 50000)) + (time-iterations n (integer-to-base64-string int)) + (time-iterations n (string-to-base64-string str)) + #+allego + (progn + (time-iterations n (excl:integer-to-base64-string int)) + (time-iterations n (excl:usb8-array-to-base64-string usb8))))) + + +;;#+run-test (test-base64)