Skip to content
Snippets Groups Projects
Commit 9d5e8be8 authored by Kevin M. Rosenberg's avatar Kevin M. Rosenberg
Browse files

r3746: *** empty log message ***

parent 1b3ea245
No related branches found
No related tags found
No related merge requests found
;;;; -*- 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")))
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;;; Programmer: Kevin M. Rosenberg ;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002 ;;;; 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) (in-package :asdf)
...@@ -24,4 +24,7 @@ ...@@ -24,4 +24,7 @@
(pushnew :base64 cl:*features*)) (pushnew :base64 cl:*features*))
:components :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 cl-base64 (2.1.0-1) unstable; urgency=low
* Fix broken string-to-base64 * Fix broken string-to-base64
......
...@@ -42,8 +42,9 @@ install: build ...@@ -42,8 +42,9 @@ install: build
dh_clean -k dh_clean -k
# Add here commands to install the package into debian/base64. # Add here commands to install the package into debian/base64.
dh_installdirs $(clc-systems) $(clc-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.asd $(clc-systems)/base64.asd
dh_link $(clc-base64)/base64-test.asd $(clc-systems)/base64-test.asd
# Build architecture-independent files here. # Build architecture-independent files here.
binary-indep: build install binary-indep: build install
......
;;;; -*- 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)))
;;;; -*- 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 ;;;; This file implements the Base64 transfer encoding algorithm as
;;;; defined in RFC 1521 by Borensten & Freed, September 1993. ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
;;;; See: http://www.ietf.org/rfc/rfc1521.txt ;;;; See: http://www.ietf.org/rfc/rfc1521.txt
;;;; ;;;;
;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi> ;;;; 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>: ;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
;;;; - .asd file ;;;; - .asd file
;;;; - numerous speed optimizations ;;;; - numerous speed optimizations
...@@ -11,58 +28,10 @@ ...@@ -11,58 +28,10 @@
;;;; - Renamed functions now that supporting integer conversions ;;;; - Renamed functions now that supporting integer conversions
;;;; - URI-compatible encoding using :uri key ;;;; - URI-compatible encoding using :uri key
;;;; ;;;;
;;;; Copyright 2002-2003 Kevin M. Rosenberg ;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
;;;; 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) (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 () '(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) (defun round-next-multiple (x n)
"Round x up to the next highest multiple of n." "Round x up to the next highest multiple of n."
...@@ -74,16 +43,6 @@ ...@@ -74,16 +43,6 @@
x x
(the fixnum (+ x (the fixnum (- n remainder))))))) (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)) (defun string-to-base64 (string &key (uri nil) (columns 0) (stream nil))
"Encode a string array to base64. If columns is > 0, designates "Encode a string array to base64. If columns is > 0, designates
maximum number of columns in a line and the string will be terminated maximum number of columns in a line and the string will be terminated
...@@ -116,14 +75,15 @@ with a #\Newline." ...@@ -116,14 +75,15 @@ with a #\Newline."
(declare (fixnum string-length padded-length col ioutput) (declare (fixnum string-length padded-length col ioutput)
(simple-string result)) (simple-string result))
(labels ((output-char (ch) (labels ((output-char (ch)
(when (= col columns) (if (= col columns)
(if stream (progn
(write-char #\Newline stream) (if stream
(progn (write-char #\Newline stream)
(setf (schar result ioutput) #\Newline) (progn
(incf ioutput))) (setf (schar result ioutput) #\Newline)
(setq col 0)) (incf ioutput)))
(incf col) (setq col 1))
(incf col))
(if stream (if stream
(write-char ch stream) (write-char ch stream)
(progn (progn
...@@ -226,8 +186,8 @@ with a #\Newline." ...@@ -226,8 +186,8 @@ with a #\Newline."
(last-char (1- strlen)) (last-char (1- strlen))
(str (make-string strlen)) (str (make-string strlen))
(col (if (zerop last-line-len) (col (if (zerop last-line-len)
(1- columns) columns
(1- last-line-len)))) last-line-len)))
(declare (fixnum padded-length num-lines col last-char (declare (fixnum padded-length num-lines col last-char
padding-chars last-line-len)) padding-chars last-line-len))
(unless (plusp columns) (unless (plusp columns)
...@@ -304,79 +264,3 @@ with a #\Newline." ...@@ -304,79 +264,3 @@ with a #\Newline."
(schar encode-table 6bit-value)) (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)))
;;;; -*- 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*))
)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment