[bknr-cvs] r2005 - in branches/xml-class-rework/thirdparty: . cl-base64
bknr at bknr.net
bknr at bknr.net
Sun Oct 15 23:21:43 UTC 2006
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 at 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 at 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 at 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 at 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)
More information about the Bknr-cvs
mailing list