From 9d5e8be84951cef7f6a11bb60af0c64d8bd1e254 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 12 Jan 2003 20:25:26 +0000 Subject: [PATCH] r3746: *** empty log message *** --- base64-test.asd | 27 +++++ base64.asd | 7 +- debian/changelog | 7 ++ debian/rules | 3 +- decode.lisp | 224 ++++++++++++++++++++++++++++++++++++++++ src.lisp => encode.lisp | 176 ++++++------------------------- package.lisp | 74 +++++++++++++ 7 files changed, 369 insertions(+), 149 deletions(-) create mode 100644 base64-test.asd create mode 100644 decode.lisp rename src.lisp => encode.lisp (64%) create mode 100644 package.lisp diff --git a/base64-test.asd b/base64-test.asd new file mode 100644 index 0000000..db28e51 --- /dev/null +++ b/base64-test.asd @@ -0,0 +1,27 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: base64-test.asd +;;;; Purpose: ASDF definition file for Base64 Regression Test +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jan 2003 +;;;; +;;;; $Id: base64-test.asd,v 1.1 2003/01/12 20:25:26 kevin Exp $ +;;;; ************************************************************************* + +(in-package :asdf) + +#+allegro (require 'tester) + +(defsystem :base64-test + :name "cl-base64-test" + :author "Kevin M. Rosenberg based on code by Juri Pakaste" + :version "1.0" + :maintainer "Kevin M. Rosenberg " + :licence "BSD-style" + :description "Regression test for cl-base64 package" + + :depends-on (:base64 :kmrcl #-allegro :tester) + :components + ((:file "test"))) diff --git a/base64.asd b/base64.asd index fe08b4f..5d3dad5 100644 --- a/base64.asd +++ b/base64.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: base64.asd,v 1.2 2002/12/29 06:14:49 kevin Exp $ +;;;; $Id: base64.asd,v 1.3 2003/01/12 20:25:26 kevin Exp $ ;;;; ************************************************************************* (in-package :asdf) @@ -24,4 +24,7 @@ (pushnew :base64 cl:*features*)) :components - ((:file "src"))) + ((:file "package") + (:file "encode" :depends-on ("package")) + (:file "decode" :depends-on ("package")) + )) diff --git a/debian/changelog b/debian/changelog index ed92b63..857f024 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +cl-base64 (2.2.0-1) unstable; urgency=low + + * Fix error in integer-to-base64 when using columns + * Add base64-test.asd and test.lisp regression suite + + -- Kevin M. Rosenberg Sat, 4 Jan 2003 06:40:32 -0700 + cl-base64 (2.1.0-1) unstable; urgency=low * Fix broken string-to-base64 diff --git a/debian/rules b/debian/rules index 54ac3fe..3da7d80 100755 --- a/debian/rules +++ b/debian/rules @@ -42,8 +42,9 @@ install: build dh_clean -k # Add here commands to install the package into debian/base64. dh_installdirs $(clc-systems) $(clc-base64) - dh_install base64.asd $(shell echo *.lisp) $(clc-base64) + dh_install *.asd $(shell echo *.lisp) $(clc-base64) dh_link $(clc-base64)/base64.asd $(clc-systems)/base64.asd + dh_link $(clc-base64)/base64-test.asd $(clc-systems)/base64-test.asd # Build architecture-independent files here. binary-indep: build install diff --git a/decode.lisp b/decode.lisp new file mode 100644 index 0000000..ea0cdf2 --- /dev/null +++ b/decode.lisp @@ -0,0 +1,224 @@ +;;;; -*- 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,v 1.1 2003/01/12 20:25:26 kevin Exp $ +;;;; +;;;; 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 +;;;; +;;;; Copyright 2002-2003 Kevin M. Rosenberg +;;;; Permission to use with BSD-style license included in the COPYING file +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) + +(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 + +(defun base64-to-string (string &key (uri nil)) + "Decode a base64 string to a string array." + (declare (string string) + (optimize (speed 3))) + (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 ((result (make-string (* 3 (truncate (length string) 4)))) + (ridx 0)) + (declare (simple-string result) + (fixnum ridx)) + (loop + for char of-type character across string + 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) + (setf (char result ridx) + (code-char (the fixnum + (logand + (the fixnum + (ash bitstore + (the fixnum (- bitcount)))) + #xFF)))) + (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)) +)) + (subseq result 0 ridx)))) + +#| +(def-base64-stream-to-* :string) +(def-base64-stream-to-* :stream) +(def-base64-stream-to-* :usb8-array) +|# + +(defmacro def-base64-string-to-* (output-type) + `(defun ,(case output-type + (:string + 'base64-string-to-string) + (:stream + 'base64-string-to-stream) + (:usb8-array + 'base64-string-to-usb8-array)) + (input &key (uri nil) + ,@(when (eq output-type :stream) + '(stream))) + "Decode base64 string" + (declare (input string) + (optimize (speed 3))) + (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 (,@(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 (array fixnum (*)) result))))) + (fixnum ridx)) + (loop + for char of-type character across string + 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 ((svalue (the fixnum + (logand + (the fixnum + (ash bitstore + (the fixnum (- bitcount)))) + #xFF)))) + (declare (fixnum svalue)) + ,@(case output-type + (:string + (setf (char result ridx) (code-char svalue))) + (:usb8-array + (setf (aref result ridx) svalue)) + (:stream + (write-char (code-char svalue) 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)) + )) + (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))) + (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))) + (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 (value integer) + (char character)) + (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)))) + value))) diff --git a/src.lisp b/encode.lisp similarity index 64% rename from src.lisp rename to encode.lisp index 48cde5b..e6ee841 100644 --- a/src.lisp +++ b/encode.lisp @@ -1,9 +1,26 @@ +;;;; -*- 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,v 1.1 2003/01/12 20:25:26 kevin Exp $ +;;;; ;;;; 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 ;;;; +;;;; Copyright 2002-2003 Kevin M. Rosenberg +;;;; Permission to use with BSD-style license included in the COPYING file +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) + ;;;; Extended by Kevin M. Rosenberg : ;;;; - .asd file ;;;; - numerous speed optimizations @@ -11,58 +28,10 @@ ;;;; - Renamed functions now that supporting integer conversions ;;;; - URI-compatible encoding using :uri key ;;;; -;;;; Copyright 2002-2003 Kevin M. Rosenberg -;;;; Permission to use with BSD-style license included in the COPYING file -;;;; -;;;; $Id: src.lisp,v 1.6 2003/01/04 13:43:27 kevin Exp $ - -(defpackage #:base64 - (:use #:cl) - (:export #:base64-to-string #:base64-to-integer - #:string-to-base64 #:integer-to-base64)) - +;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $ -(in-package #:base64) +(in-package #:cl-base64) -(eval-when (:compile-toplevel :load-toplevel :execute) - (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))) - - (defvar *decode-table* - (let ((da (make-array 256 :adjustable nil :fill-pointer nil - :element-type 'fixnum - :initial-element -1))) - (loop for char of-type character across *encode-table* - for index of-type fixnum from 0 below 64 - do (setf (aref da (the fixnum (char-code char))) index)) - da)) - - (defvar *uri-decode-table* - (let ((da (make-array 256 :adjustable nil :fill-pointer nil - :element-type 'fixnum - :initial-element -1))) - (loop - for char of-type character across *uri-encode-table* - for index of-type fixnum from 0 below 64 - do (setf (aref da (the fixnum (char-code char))) index)) - da)) - - (declaim (type decode-table *decode-table* *uri-decode-table*)) - - (defvar *pad-char* #\=) - (defvar *uri-pad-char* #\.) - (declaim (type character *pad-char* *uri-pad-char*)) - ) - - -;;; Utilities (defun round-next-multiple (x n) "Round x up to the next highest multiple of n." @@ -74,16 +43,6 @@ x (the fixnum (+ x (the fixnum (- n remainder))))))) -(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))) - - -;; Encode routines - (defun string-to-base64 (string &key (uri nil) (columns 0) (stream nil)) "Encode a string array to base64. If columns is > 0, designates maximum number of columns in a line and the string will be terminated @@ -116,14 +75,15 @@ with a #\Newline." (declare (fixnum string-length padded-length col ioutput) (simple-string result)) (labels ((output-char (ch) - (when (= col columns) - (if stream - (write-char #\Newline stream) - (progn - (setf (schar result ioutput) #\Newline) - (incf ioutput))) - (setq col 0)) - (incf col) + (if (= col columns) + (progn + (if stream + (write-char #\Newline stream) + (progn + (setf (schar result ioutput) #\Newline) + (incf ioutput))) + (setq col 1)) + (incf col)) (if stream (write-char ch stream) (progn @@ -226,8 +186,8 @@ with a #\Newline." (last-char (1- strlen)) (str (make-string strlen)) (col (if (zerop last-line-len) - (1- columns) - (1- last-line-len)))) + columns + last-line-len))) (declare (fixnum padded-length num-lines col last-char padding-chars last-line-len)) (unless (plusp columns) @@ -304,79 +264,3 @@ with a #\Newline." (schar encode-table 6bit-value)) )))) -;;; Decoding - -(defun base64-to-string (string &key (uri nil)) - "Decode a base64 string to a string array." - (declare (string string) - (optimize (speed 3))) - (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 ((result (make-string (* 3 (truncate (length string) 4)))) - (ridx 0)) - (declare (simple-string result) - (fixnum ridx)) - (loop - for char of-type character across string - 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) - (setf (char result ridx) - (code-char (the fixnum - (logand - (the fixnum - (ash bitstore - (the fixnum (- bitcount)))) - #xFF)))) - (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)) -)) - (subseq result 0 ridx)))) - - -(defun base64-to-integer (string &key (uri nil)) - "Decodes a base64 string to an integer" - (declare (string string) - (optimize (speed 3))) - (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))) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..7c119de --- /dev/null +++ b/package.lisp @@ -0,0 +1,74 @@ +;;;; -*- 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,v 1.1 2003/01/12 20:25:26 kevin Exp $ +;;;; +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) + +(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 + )) + +(in-package #:cl-base64) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (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 () '(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))) + (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*)) + + (declaim (type decode-table *decode-table* *uri-decode-table*)) + + (defvar *pad-char* #\=) + (defvar *uri-pad-char* #\.) + (declaim (type character *pad-char* *uri-pad-char*)) + ) -- 2.34.1