r3686: *** empty log message ***

diff --git a/base64.asd b/base64.asd
index 565cb5e5a287d8e102860622c982f9b892cec4b6..fe08b4f4a5e1e9dfb11667253e75dff5c361f8d8 100644 (file)
--- a/base64.asd
+++ b/base64.asd
@@ -7,21 +7,21 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: base64.asd,v 1.1 2002/12/29 06:08:15 kevin Exp $
+;;;; $Id: base64.asd,v 1.2 2002/12/29 06:14:49 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package :asdf)
 
 (defsystem :base64
   :name "cl-base64"
-  :author "Kevin M. Rosenberg and Juri Pakaste"
+  :author "Kevin M. Rosenberg based on code by Juri Pakaste"
   :version "1.0"
   :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
-  :licence "Public domain"
-  :description "Base64 encode and decoding"
+  :licence "BSD-style"
+  :description "Base64 encoding and decoding with URI support."
   
   :perform (load-op :after (op base64)
            (pushnew :base64 cl:*features*))
   
   :components
-  ((:file "base64")))
+  ((:file "src")))

diff --git a/base64.lisp b/base64.lisp
index f329223419e15d07d1716bd1649c8671562fc9c4..50721029744a7a9e19ef79c0d7ba5c6d2d807f0f 100644 (file)
--- a/base64.lisp
+++ b/base64.lisp
@@ -14,7 +14,7 @@
 ;;;; Copyright 2002-2003 Kevin M. Rosenberg
 ;;;; Permission to use with BSD-style license included in the COPYING file
 ;;;;
-;;;; $Id: base64.lisp,v 1.1 2002/12/29 06:08:15 kevin Exp $
+;;;; $Id: base64.lisp,v 1.2 2002/12/29 06:11:24 kevin Exp $
 
 (defpackage #:base64
   (:use #:cl)
@@ -24,17 +24,17 @@
 (in-package #:base64)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defparameter *encode-table*
+  (defvar *encode-table*
     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
   (declaim (type simple-string *encode-table*))
   
-  (defparameter *uri-encode-table*
+  (defvar *uri-encode-table*
     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
   (declaim (type simple-string *uri-encode-table*))
   
   (deftype decode-table () '(simple-array fixnum (256)))
 
-  (defparameter *decode-table*
+  (defvar *decode-table*
     (let ((da (make-array 256 :adjustable nil :fill-pointer nil
                          :element-type 'fixnum
                          :initial-element -1)))
@@ -43,7 +43,7 @@
            do (setf (aref da (the fixnum (char-code char))) index))
       da))
   
-  (defparameter *uri-decode-table*
+  (defvar *uri-decode-table*
     (let ((da (make-array 256 :adjustable nil :fill-pointer nil
                          :element-type 'fixnum
                          :initial-element -1)))
@@ -55,8 +55,10 @@
   
   (declaim (type decode-table *decode-table* *uri-decode-table*))
   
-  (defparameter *pad-char* #\=)
-  (defparameter *uri-pad-char* #\.))
+  (defvar *pad-char* #\=)
+  (defvar *uri-pad-char* #\.)
+  (declaim (type character *pad-char* *uri-pad-char*))
+  )
 
 (defun string-to-base64 (string &key (uri nil))
   "Encode a string array to base64."

diff --git a/src.lisp b/src.lisp
new file mode 100644 (file)
index 0000000..b6d5a8a
--- /dev/null
+++ b/src.lisp
@@ -0,0 +1,227 @@
+;;;; 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.1 2002/12/29 06:14:49 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*))
+  )
+
+(defun string-to-base64 (string &key (uri nil))
+  "Encode a string array to base64."
+  (declare (string string)
+          (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))
+          (result (make-string
+                   (* 4 (truncate (/ (+ 2 string-length) 3))))))
+      (declare (fixnum string-length)
+              (simple-string result))
+      (do ((sidx 0 (the fixnum (+ sidx 3)))
+          (didx 0 (the fixnum (+ didx 4)))
+          (chars 2 2)
+          (value 0 0))
+         ((>= sidx string-length) t)
+       (declare (fixnum sidx didx chars value))
+       (setf value (ash (logand #xFF (char-code (char string sidx))) 8))
+       (dotimes (n 2)
+         (declare (fixnum n))
+         (when (< (the fixnum (+ sidx n 1)) string-length)
+           (setf value
+                 (logior value
+                         (the fixnum
+                           (logand #xFF
+                                   (the fixnum
+                                     (char-code (char string
+                                                       (the fixnum
+                                                         (+ sidx n 1)))))))))
+           (incf chars))
+         (when (zerop n)
+           (setf value (the fixnum (ash value 8)))))
+       (setf (schar result (the fixnum (+ didx 3)))
+             (if (> chars 3)
+                 (schar encode-table (logand value #x3F))
+                 pad))
+       (setf value (the fixnum (ash value -6)))
+       (setf (schar result (the fixnum (+ didx 2)))
+             (if (> chars 2)
+                 (schar encode-table (logand value #x3F))
+                 pad))
+       (setf value (the fixnum (ash value -6)))
+       (setf (schar result (the fixnum (1+ didx)))
+             (schar encode-table (logand value #x3F)))
+       (setf value (the fixnum (ash value -6)))
+       (setf (schar result didx)
+             (schar encode-table (logand value #x3F))))
+      result)))
+
+
+(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 integer-to-base64 (input &key (uri nil))
+  "Encode an integer to base64 format."
+  (declare (integer input)
+          (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))
+    (do* ((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)))
+         (strlen (/ (+ padded-bits padding-bits) 6))
+         (padding-chars (/ padding-bits 6))
+         (nonpad-chars (- strlen padding-chars))
+         (last-nonpad-char (1- nonpad-chars))
+         (str (make-string strlen))
+         (strpos 0 (1+ strpos))
+         (int (ash input (/ padding-bits 3)) (ash int -6))
+         (6bit-value (logand int #x3f) (logand int #x3f)))
+        ((= strpos nonpad-chars)
+         (dotimes (ipad padding-chars)
+           (setf (schar str strpos) pad)
+           (incf strpos))
+         str)
+      (declare (fixnum 6bit-value strpos strlen last-nonpad-char)
+              (integer int))
+      (setf (schar str (the fixnum (- 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
+            ((char= char pad)
+             ;; Could add checks to make sure padding is correct
+             ;; Currently, padding is ignored
+             )
+            ((minusp svalue)
+             (warn "Bad character ~W in base64 decode" char))
+            (t
+             (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)))))))
+      (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
+            ((char= char pad)
+             (setq value (the fixnum (ash value -2))))
+            ((minusp svalue)
+             (warn "Bad character ~W in base64 decode" char))
+            (t
+             (setq value (the fixnum
+                           (+ svalue (the fixnum (ash value 6))))))))
+      value)))