From: Kevin M. Rosenberg Date: Sun, 12 Jan 2003 20:25:26 +0000 (+0000) Subject: r3746: *** empty log message *** X-Git-Tag: v3.3.2~50 X-Git-Url: http://git.kpe.io/?p=cl-base64.git;a=commitdiff_plain;h=9d5e8be84951cef7f6a11bb60af0c64d8bd1e254 r3746: *** empty log message *** --- 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/encode.lisp b/encode.lisp new file mode 100644 index 0000000..e6ee841 --- /dev/null +++ b/encode.lisp @@ -0,0 +1,266 @@ +;;;; -*- 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 +;;;; - conversion to and from integers +;;;; - Renamed functions now that supporting integer conversions +;;;; - URI-compatible encoding using :uri key +;;;; +;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $ + +(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))) + (let ((remainder (mod x n))) + (declare (fixnum remainder)) + (if (zerop remainder) + x + (the fixnum (+ x (the fixnum (- n remainder))))))) + +(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 +with a #\Newline." + (declare (string string) + (fixnum columns) + (optimize (speed 3))) + (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 string)) + (complete-group-count (truncate string-length 3)) + (remainder (nth-value 1 (truncate string-length 3))) + (padded-length (* 4 (truncate (+ string-length 2) 3))) + (num-lines (if (plusp columns) + (truncate (+ padded-length (1- columns)) columns) + 0)) + (num-breaks (if (plusp num-lines) + (1- num-lines) + 0)) + (strlen (if stream + 0 + (+ padded-length num-breaks))) + (result (make-string strlen)) + (col (if (plusp columns) + 0 + (1+ padded-length))) + (ioutput 0)) + (declare (fixnum string-length padded-length col ioutput) + (simple-string result)) + (labels ((output-char (ch) + (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 + (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 (1+ igroup)) + (isource 0 (+ isource 3))) + ((= igroup complete-group-count) + (cond + ((= remainder 2) + (output-group + (the fixnum + (+ + (the fixnum + (ash (char-code (the character + (char string isource))) 16)) + (the fixnum + (ash (char-code (the character + (char string (1+ isource)))) 8)))) + 3)) + ((= remainder 1) + (output-group + (the fixnum + (ash (char-code (the character (char string isource))) 16)) + 2))) + result) + (declare (fixnum igroup isource)) + (output-group + (the fixnum + (+ + (the fixnum + (ash (char-code (the character + (char string isource))) 16)) + (the fixnum + (ash (char-code (the character (char string (1+ isource)))) 8)) + (the fixnum + (char-code (the character (char string (+ 2 isource))))))) + 4)))))) + +(defun integer-to-base64 (input &key (uri nil) (columns 0) (stream nil)) + (if stream + (integer-to-base64-stream input stream :uri uri :columns columns) + (integer-to-base64-string input :uri uri :columns columns))) + +(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))) + (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))) + (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 (1+ strpos)) + (int (ash input (/ padding-bits 3)) (ash int -6)) + (6bit-value (logand int #x3f) (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)) + )))) + 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*)) + ) diff --git a/src.lisp b/src.lisp deleted file mode 100644 index 48cde5b..0000000 --- a/src.lisp +++ /dev/null @@ -1,382 +0,0 @@ -;;;; 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 -;;;; -;;;; Extended by Kevin M. Rosenberg : -;;;; - .asd file -;;;; - numerous speed optimizations -;;;; - conversion to and from integers -;;;; - 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)) - - -(in-package #: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." - (declare (fixnum n) - (optimize (speed 3))) - (let ((remainder (mod x n))) - (declare (fixnum remainder)) - (if (zerop remainder) - 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 -with a #\Newline." - (declare (string string) - (fixnum columns) - (optimize (speed 3))) - (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 string)) - (complete-group-count (truncate string-length 3)) - (remainder (nth-value 1 (truncate string-length 3))) - (padded-length (* 4 (truncate (+ string-length 2) 3))) - (num-lines (if (plusp columns) - (truncate (+ padded-length (1- columns)) columns) - 0)) - (num-breaks (if (plusp num-lines) - (1- num-lines) - 0)) - (strlen (if stream - 0 - (+ padded-length num-breaks))) - (result (make-string strlen)) - (col (if (plusp columns) - 0 - (1+ padded-length))) - (ioutput 0)) - (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 stream - (write-char ch stream) - (progn - (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 (1+ igroup)) - (isource 0 (+ isource 3))) - ((= igroup complete-group-count) - (cond - ((= remainder 2) - (output-group - (the fixnum - (+ - (the fixnum - (ash (char-code (the character - (char string isource))) 16)) - (the fixnum - (ash (char-code (the character - (char string (1+ isource)))) 8)))) - 3)) - ((= remainder 1) - (output-group - (the fixnum - (ash (char-code (the character (char string isource))) 16)) - 2))) - result) - (declare (fixnum igroup isource)) - (output-group - (the fixnum - (+ - (the fixnum - (ash (char-code (the character - (char string isource))) 16)) - (the fixnum - (ash (char-code (the character (char string (1+ isource)))) 8)) - (the fixnum - (char-code (the character (char string (+ 2 isource))))))) - 4)))))) - -(defun integer-to-base64 (input &key (uri nil) (columns 0) (stream nil)) - (if stream - (integer-to-base64-stream input stream :uri uri :columns columns) - (integer-to-base64-string input :uri uri :columns columns))) - -(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))) - (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) - (1- columns) - (1- 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))) - (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 (1+ strpos)) - (int (ash input (/ padding-bits 3)) (ash int -6)) - (6bit-value (logand int #x3f) (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)) - )))) - -;;; 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)))