r3746: *** empty log message ***
authorKevin M. Rosenberg <kevin@rosenberg.net>
Sun, 12 Jan 2003 20:25:26 +0000 (20:25 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Sun, 12 Jan 2003 20:25:26 +0000 (20:25 +0000)
base64-test.asd [new file with mode: 0644]
base64.asd
debian/changelog
debian/rules
decode.lisp [new file with mode: 0644]
encode.lisp [new file with mode: 0644]
package.lisp [new file with mode: 0644]
src.lisp [deleted file]

diff --git a/base64-test.asd b/base64-test.asd
new file mode 100644 (file)
index 0000000..db28e51
--- /dev/null
@@ -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 <kmr@debian.org>"
+  :licence "BSD-style"
+  :description "Regression test for cl-base64 package"
+  
+  :depends-on (:base64 :kmrcl #-allegro :tester)  
+  :components
+  ((:file "test")))
index fe08b4f..5d3dad5 100644 (file)
@@ -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"))
+   ))
index ed92b63..857f024 100644 (file)
@@ -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 <kmr@debian.org>  Sat,  4 Jan 2003 06:40:32 -0700
+
 cl-base64 (2.1.0-1) unstable; urgency=low
 
   * Fix broken string-to-base64
index 54ac3fe..3da7d80 100755 (executable)
@@ -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 (file)
index 0000000..ea0cdf2
--- /dev/null
@@ -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 <juri@iki.fi>
+;;;;
+;;;; 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 (file)
index 0000000..e6ee841
--- /dev/null
@@ -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 <juri@iki.fi>
+;;;;
+;;;; 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 <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,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 (file)
index 0000000..7c119de
--- /dev/null
@@ -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 (file)
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 <juri@iki.fi>
-;;;;
-;;;; 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
-;;;;
-;;;; 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)))