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

r3685: *** empty log message ***

parents
No related branches found
No related tags found
No related merge requests found
.bin
*.fasl*
*.dfsl
*.pfsl
*.ufsl
*.fas
*.x86f
*.sparcf
*.cfsl
COPYING 0 → 100644
Copyright (c) 2002-2003 by Kevin Rosenberg
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the Authors may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: base64.asd
;;;; Purpose: ASDF definition file for Base64
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
;;;; $Id: base64.asd,v 1.1 2002/12/29 06:08:15 kevin Exp $
;;;; *************************************************************************
(in-package :asdf)
(defsystem :base64
:name "cl-base64"
:author "Kevin M. Rosenberg and Juri Pakaste"
:version "1.0"
:maintainer "Kevin M. Rosenberg <kmr@debian.org>"
:licence "Public domain"
:description "Base64 encode and decoding"
:perform (load-op :after (op base64)
(pushnew :base64 cl:*features*))
:components
((:file "base64")))
;;;; 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: base64.lisp,v 1.1 2002/12/29 06:08:15 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)
(defparameter *encode-table*
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(declaim (type simple-string *encode-table*))
(defparameter *uri-encode-table*
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
(declaim (type simple-string *uri-encode-table*))
(deftype decode-table () '(simple-array fixnum (256)))
(defparameter *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))
(defparameter *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*))
(defparameter *pad-char* #\=)
(defparameter *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)))
cl-base64 (1.1-1) unstable; urgency=low
* Rewritten version, significant optimizations
* BSD-style license
* Adds conversion to and from integers
* Renamed functions
-- Kevin M. Rosenberg <kmr@debian.org> Sat, 28 Dec 2002 21:28:42 -0700
cl-base64 (1.0-1) unstable; urgency=low
* Initial upload
* Changes compared to upstream:
- Added .asd file for use with Common Lisp Controller
- Changes for Allegro's case sensitive mode
-- Kevin M. Rosenberg <kmr@debian.org> Thu, 26 Dec 2002 19:17:51 -0700
Source: cl-base64
Section: devel
Priority: optional
Maintainer: Kevin M. Rosenberg <kmr@debian.org>
Build-Depends-Indep: debhelper (>= 4.0.0)
Standards-Version: 3.5.8.0
Package: cl-base64
Architecture: all
Depends: ${shlibs:Depends}, common-lisp-controller (>= 3.47)
Description: Common Lisp package to encode and decode base64 with URI support
This package provides highly optimized base64 encoding and decoding.
Besides conversion to and from strings, integer conversions are supported.
Encoding with Uniform Resource Indentifiers is supported by using
a modified encoding table that uses only URI-compatible characters.
This package was debianized by Kevin M. Rosenberg <kmr@debian.org> in
Dec 2002.
It was downloaded from ftp://ftp.b9.com/base64/
Upstream Author: Kevin M. Rosenberg <kevin@rosenberg.net>
This code is based on code placed in the public domain by Juri Pakaste
<juri@iki.fr> and available for download at
http://www.helsinki.fi/~pakaste/store/dl/base64.lisp
Copyright:
Copyright (c) 2002-2003 by Kevin Rosenberg
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the Authors may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#! /bin/sh
#
# see: dh_installdeb(1)
set -e
# package name according to lisp
LISP_PKG=base64
# summary of how this script can be called:
# * <postinst> `configure' <most-recently-configured-version>
# * <old-postinst> `abort-upgrade' <new version>
# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
# <new-version>
# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
# <failed-install-package> <version> `removing'
# <conflicting-package> <version>
# for details, see http://www.debian.org/doc/debian-policy/ or
# the debian-policy package
#
# quoting from the policy:
# Any necessary prompting should almost always be confined to the
# post-installation script, and should be protected with a conditional
# so that unnecessary prompting doesn't happen if a package's
# installation fails and the `postinst' is called with `abort-upgrade',
# `abort-remove' or `abort-deconfigure'.
case "$1" in
configure)
/usr/sbin/register-common-lisp-source ${LISP_PKG}
;;
abort-upgrade|abort-remove|abort-deconfigure)
;;
*)
echo "postinst called with unknown argument \`$1'" >&2
exit 1
;;
esac
# dh_installdeb will replace this with shell code automatically
# generated by other debhelper scripts.
#DEBHELPER#
exit 0
#! /bin/sh
#
# see: dh_installdeb(1)
set -e
# package name according to lisp
LISP_PKG=base64
# summary of how this script can be called:
# * <prerm> `remove'
# * <old-prerm> `upgrade' <new-version>
# * <new-prerm> `failed-upgrade' <old-version>
# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
# * <deconfigured's-prerm> `deconfigure' `in-favour'
# <package-being-installed> <version> `removing'
# <conflicting-package> <version>
# for details, see http://www.debian.org/doc/debian-policy/ or
# the debian-policy package
case "$1" in
remove|upgrade|deconfigure)
/usr/sbin/unregister-common-lisp-source ${LISP_PKG}
;;
failed-upgrade)
;;
*)
echo "prerm called with unknown argument \`$1'" >&2
exit 1
;;
esac
# dh_installdeb will replace this with shell code automatically
# generated by other debhelper scripts.
#DEBHELPER#
exit 0
#!/usr/bin/make -f
export DH_COMPAT=4
pkg := base64
debpkg := cl-base64
clc-source := usr/share/common-lisp/source
clc-systems := usr/share/common-lisp/systems
clc-base64 := $(clc-source)/$(pkg)
doc-dir := usr/share/doc/$(debpkg)
configure: configure-stamp
configure-stamp:
dh_testdir
# Add here commands to configure the package.
touch configure-stamp
build: build-stamp
build-stamp: configure-stamp
dh_testdir
# Add here commands to compile the package.
touch build-stamp
clean:
dh_testdir
dh_testroot
rm -f build-stamp configure-stamp
# Add here commands to clean up after the build process.
rm -f debian/cl-base64.postinst.* debian/cl-base64.prerm.*
dh_clean
install: build
dh_testdir
dh_testroot
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_link $(clc-base64)/base64.asd $(clc-systems)/base64.asd
# Build architecture-independent files here.
binary-indep: build install
# Build architecture-dependent files here.
binary-arch: build install
dh_testdir
dh_testroot
dh_installdocs
dh_installchangelogs
dh_strip
dh_compress
dh_fixperms
dh_installdeb
dh_shlibdeps
dh_gencontrol
dh_md5sums
dh_builddeb
binary: binary-indep binary-arch
.PHONY: build clean binary-indep binary-arch binary install configure
#!/bin/bash -e
dup uffi -Uftp.med-info.com -D/home/ftp/base64 -su $*
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment