--- /dev/null
+;;;; -*- 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")))
;;;; 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)
(pushnew :base64 cl:*features*))
:components
- ((:file "src")))
+ ((:file "package")
+ (:file "encode" :depends-on ("package"))
+ (:file "decode" :depends-on ("package"))
+ ))
+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
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
--- /dev/null
+;;;; -*- 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)))
--- /dev/null
+;;;; -*- 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))
+ ))))
+
--- /dev/null
+;;;; -*- 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*))
+ )
+++ /dev/null
-;;;; 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)))
projects / cl-base64.git / commitdiff