From: Kevin M. Rosenberg Date: Sun, 29 Dec 2002 06:14:49 +0000 (+0000) Subject: r3686: *** empty log message *** X-Git-Tag: v3.3.2~60 X-Git-Url: http://git.kpe.io/?p=cl-base64.git;a=commitdiff_plain;h=39e28cb26ce28f9a69fa366ef9c2f0d6e5afbe23 r3686: *** empty log message *** --- diff --git a/base64.asd b/base64.asd index 565cb5e..fe08b4f 100644 --- 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 " - :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 f329223..5072102 100644 --- 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 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 +;;;; +;;;; 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.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)))