From ddb83b1fb2d305e0c06fc067d82d6bab5458b0fd Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Fri, 30 Oct 2009 20:52:07 +0100 Subject: Add third-party XML processing libraries. Ignore-this: 5ca28497555bf944858ca2f58bc8a62b darcs-hash:a0b0f9baa7c9b1259e755435db1fb17123630a6c --- third-party/s-base64/src/base64.lisp | 152 +++++++++++++++++++++++++++++++++++ 1 file changed, 152 insertions(+) create mode 100644 third-party/s-base64/src/base64.lisp (limited to 'third-party/s-base64/src/base64.lisp') diff --git a/third-party/s-base64/src/base64.lisp b/third-party/s-base64/src/base64.lisp new file mode 100644 index 0000000..f6b799f --- /dev/null +++ b/third-party/s-base64/src/base64.lisp @@ -0,0 +1,152 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $ +;;;; +;;;; This is a Common Lisp implementation of Base64 encoding and decoding. +;;;; +;;;; Copyright (C) 2002-2005 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-base64) + +(defparameter +base64-alphabet+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") + +(defparameter +inverse-base64-alphabet+ + (let ((inverse-base64-alphabet (make-array 127))) + (dotimes (i 127 inverse-base64-alphabet) + (setf (aref inverse-base64-alphabet i) + (position (code-char i) +base64-alphabet+))))) + +(defun core-encode-base64 (byte1 byte2 byte3) + (values (char +base64-alphabet+ (ash byte1 -2)) + (char +base64-alphabet+ (logior (ash (logand byte1 #B11) 4) + (ash (logand byte2 #B11110000) -4))) + (char +base64-alphabet+ (logior (ash (logand byte2 #B00001111) 2) + (ash (logand byte3 #B11000000) -6))) + (char +base64-alphabet+ (logand byte3 #B111111)))) + +(defun core-decode-base64 (char1 char2 char3 char4) + (let ((v1 (aref +inverse-base64-alphabet+ (char-code char1))) + (v2 (aref +inverse-base64-alphabet+ (char-code char2))) + (v3 (aref +inverse-base64-alphabet+ (char-code char3))) + (v4 (aref +inverse-base64-alphabet+ (char-code char4)))) + (values (logior (ash v1 2) + (ash v2 -4)) + (logior (ash (logand v2 #B1111) 4) + (ash v3 -2)) + (logior (ash (logand v3 #B11) 6) + v4)))) + +(defun skip-base64-whitespace (stream) + (loop + (let ((char (peek-char nil stream nil nil))) + (cond ((null char) (return nil)) + ((null (aref +inverse-base64-alphabet+ (char-code char))) (read-char stream)) + (t (return char)))))) + +(defun decode-base64-bytes (stream) + "Decode a base64 encoded character stream, returns a byte array" + (let ((out (make-array 256 + :element-type '(unsigned-byte 8) + :adjustable t + :fill-pointer 0))) + (loop + (skip-base64-whitespace stream) + (let ((in1 (read-char stream nil nil)) + (in2 (read-char stream nil nil)) + (in3 (read-char stream nil nil)) + (in4 (read-char stream nil nil))) + (if (null in1) (return)) + (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded for base64 encoding")) + (multiple-value-bind (out1 out2 out3) + (core-decode-base64 in1 + in2 + (if (char= in3 #\=) #\A in3) + (if (char= in4 #\=) #\A in4)) + (vector-push-extend out1 out) + (when (char/= in3 #\=) + (vector-push-extend out2 out) + (when (char/= in4 #\=) + (vector-push-extend out3 out)))))) + out)) + +(defun encode-base64-bytes (array stream &optional (break-lines t)) + "Encode a byte array into a base64 encoded character stream" + (let ((index 0) + (counter 0) + (len (length array))) + (loop + (when (>= index len) (return)) + (let ((in1 (aref array index)) + (in2 (if (< (+ index 1) len) (aref array (+ index 1)) nil)) + (in3 (if (< (+ index 2) len) (aref array (+ index 2)) nil))) + (multiple-value-bind (out1 out2 out3 out4) + (core-encode-base64 in1 + (if (null in2) 0 in2) + (if (null in3) 0 in3)) + (write-char out1 stream) + (write-char out2 stream) + (if (null in2) + (progn + (write-char #\= stream) + (write-char #\= stream)) + (progn + (write-char out3 stream) + (if (null in3) + (write-char #\= stream) + (write-char out4 stream)))) + (incf index 3) + (incf counter 4) + (when (and break-lines (= counter 76)) + (terpri stream) + (setf counter 0))))))) + +(defun decode-base64 (in out) + "Decode a base64 encoded character input stream into a binary output stream" + (loop + (skip-base64-whitespace in) + (let ((in1 (read-char in nil nil)) + (in2 (read-char in nil nil)) + (in3 (read-char in nil nil)) + (in4 (read-char in nil nil))) + (if (null in1) (return)) + (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded for base64 encoding")) + (multiple-value-bind (out1 out2 out3) + (core-decode-base64 in1 in2 (if (char= in3 #\=) #\A in3) (if (char= in4 #\=) #\A in4)) + (write-byte out1 out) + (when (char/= in3 #\=) + (write-byte out2 out) + (when (char/= in4 #\=) + (write-byte out3 out))))))) + +(defun encode-base64 (in out &optional (break-lines t)) + "Encode a binary input stream into a base64 encoded character output stream" + (let ((counter 0)) + (loop + (let ((in1 (read-byte in nil nil)) + (in2 (read-byte in nil nil)) + (in3 (read-byte in nil nil))) + (if (null in1) (return)) + (multiple-value-bind (out1 out2 out3 out4) + (core-encode-base64 in1 (if (null in2) 0 in2) (if (null in3) 0 in3)) + (write-char out1 out) + (write-char out2 out) + (if (null in2) + (progn + (write-char #\= out) + (write-char #\= out)) + (progn + (write-char out3 out) + (if (null in3) + (write-char #\= out) + (write-char out4 out)))) + (incf counter 4) + (when (and break-lines (= counter 76)) + (terpri out) + (setf counter 0))))))) + +;;;; eof -- cgit v1.2.3