Eliminate the dependency on quicklisp for unpacking/unzipping files, including...

Eliminate the dependency on quicklisp for unpacking/unzipping files, including quicklisp's minitar and Pierre Mai's deflate.
parent 979edcc6
Copyright (C) 2000-2010 PMSF IT Consulting Pierre R. Mai
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
Except as contained in this notice, the name of the author shall
not be used in advertising or otherwise to promote the sale, use or
other dealings in this Software without prior written authorization
from the author.
This library is an implementation of Deflate (RFC 1951) decompression,
with optional support for ZLIB-style (RFC 1950) and gzip-style (RFC
1952) wrappers of deflate streams. It currently does not handle
compression, although this is a natural extension.
The implementation should be portable across all ANSI compliant CL
implementations, but has been optimized mostly for SBCL and CMU CL
(and other implementations that can generate fast code for word-sized
integer calculations based on standard type declarations), and
somewhat (mostly the otherwise very expensive CRC-32 calculations) for
Lispworks. The performance is still a bit off from zlib/gzip (by a
factor of around 3-3.5 on my systems), and while much of the
performance loss is likely to be in the stream-based I/O, a less naive
implementation of the huffman decoding step is also likely to benefit
performance a bit.
The implementation is licensed under the MIT-style license contained
in the file COPYING and the header of each source file.
Please direct any feedback to pmai@pmsf.de. A git repository of this
library is available under http://github.com/pmai/Deflate/tree/master
;;;; Deflate --- RFC 1951 Deflate Decompression
;;;;
;;;; Copyright (C) 2000-2010 PMSF IT Consulting Pierre R. Mai.
;;;;
;;;; Permission is hereby granted, free of charge, to any person obtaining
;;;; a copy of this software and associated documentation files (the
;;;; "Software"), to deal in the Software without restriction, including
;;;; without limitation the rights to use, copy, modify, merge, publish,
;;;; distribute, sublicense, and/or sell copies of the Software, and to
;;;; permit persons to whom the Software is furnished to do so, subject to
;;;; the following conditions:
;;;;
;;;; The above copyright notice and this permission notice shall be
;;;; included in all copies or substantial portions of the Software.
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR
;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;;; OTHER DEALINGS IN THE SOFTWARE.
;;;;
;;;; Except as contained in this notice, the name of the author shall
;;;; not be used in advertising or otherwise to promote the sale, use or
;;;; other dealings in this Software without prior written authorization
;;;; from the author.
;;;;
;;;; $Id$
(cl:in-package "CL-USER")
;;;; %File Description:
;;;;
;;;; This file contains the system definition form for the
;;;; Deflate Decompression Library. System definitions use the
;;;; ASDF system definition facility.
;;;;
(asdf:defsystem "deflate"
:description "Deflate Decompression Library"
:author "Pierre R. Mai <pmai@pmsf.de>"
:components ((:file "deflate")))
This diff is collapsed.
Copyright (c) 2011 Zachary Beane <zach@quicklisp.org>
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
(defpackage #:ql-minitar
(:documentation
"A simple implementation of unpacking the 'tar' file format.")
(:use #:cl)
(:export #:tarball-contents
#:unpack-tarball))
(in-package #:ql-minitar)
(defun make-block-buffer ()
(make-array 512 :element-type '(unsigned-byte 8) :initial-element 0))
(defun skip-n-blocks (n stream)
(let ((block (make-block-buffer)))
(dotimes (i n)
(read-sequence block stream))))
(defun ascii-subseq (vector start end)
(let ((string (make-string (- end start))))
(loop for i from 0
for j from start below end
do (setf (char string i) (code-char (aref vector j))))
string))
(defun block-asciiz-string (block start length)
(let* ((end (+ start length))
(eos (or (position 0 block :start start :end end)
end)))
(ascii-subseq block start eos)))
(defun prefix (header)
(when (plusp (aref header 345))
(block-asciiz-string header 345 155)))
(defun name (header)
(block-asciiz-string header 0 100))
(defun payload-size (header)
(values (parse-integer (block-asciiz-string header 124 12) :radix 8)))
(defun nth-block (n file)
(with-open-file (stream file :element-type '(unsigned-byte 8))
(let ((block (make-block-buffer)))
(skip-n-blocks (1- n) stream)
(read-sequence block stream)
block)))
(defun payload-type (code)
(case code
(0 :file)
(48 :file)
(50 :symlink)
(76 :long-name)
(53 :directory)
(103 :global-header)
(t :unsupported)))
(defun full-path (header)
(let ((prefix (prefix header))
(name (name header)))
(if prefix
(format nil "~A/~A" prefix name)
name)))
(defun save-file (file size stream)
(multiple-value-bind (full-blocks partial)
(truncate size 512)
(ensure-directories-exist file)
(with-open-file (outstream file
:direction :output
:if-exists :supersede
:element-type '(unsigned-byte 8))
(let ((block (make-block-buffer)))
(dotimes (i full-blocks)
(read-sequence block stream)
(write-sequence block outstream))
(when (plusp partial)
(read-sequence block stream)
(write-sequence block outstream :end partial))))))
(defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*))
(let ((block (make-block-buffer)))
(with-open-file (stream tarfile :element-type '(unsigned-byte 8))
(loop
(let ((size (read-sequence block stream)))
(when (zerop size)
(return))
(unless (= size 512)
(error "Bad size on tarfile"))
(when (every #'zerop block)
(return))
(let* ((payload-code (aref block 156))
(payload-type (payload-type payload-code))
(tar-path (full-path block))
(full-path (merge-pathnames tar-path directory))
(payload-size (payload-size block))
(block-count (ceiling (payload-size block) 512)))
(case payload-type
(:file
(save-file full-path payload-size stream))
(:directory
(ensure-directories-exist full-path))
((:symlink :long-name :global-header)
;; These block types aren't required for Quicklisp archives
(skip-n-blocks block-count stream))
(t
(warn "Unknown tar block payload code -- ~D" payload-code)
(skip-n-blocks block-count stream)))))))))
(defun contents (tarfile)
(let ((block (make-block-buffer))
(result '()))
(with-open-file (stream tarfile :element-type '(unsigned-byte 8))
(loop
(let ((size (read-sequence block stream)))
(when (zerop size)
(return (nreverse result)))
(unless (= size 512)
(error "Bad size on tarfile"))
(when (every #'zerop block)
(return (nreverse result)))
(let* ((payload-type (payload-type (aref block 156)))
(tar-path (full-path block))
(payload-size (payload-size block)))
(skip-n-blocks (ceiling payload-size 512) stream)
(case payload-type
(:file
(push tar-path result))
(:directory
(push tar-path result)))))))))
......@@ -251,6 +251,20 @@
:prefix "EXT"
:builtin nil)
#+WANTS-SOCKETS
(build-module "ql-minitar"
'("ext:quicklisp;minitar.lisp")
:dir "build:ext;"
:prefix "EXT"
:builtin nil)
#+WANTS-SOCKETS
(build-module "deflate"
'("ext:deflate;deflate.lisp")
:dir "build:ext;"
:prefix "EXT"
:builtin nil)
;;;
;;; * Test suite
;;;
......
......@@ -64,7 +64,9 @@
(defvar *cleanup-extensions* '("fasl" "fasb" "c" "h" "obj" "o" "a" "lib" "dll" "dylib" "data"))
(load "@top_srcdir@/../contrib/ecl-curl/ecl-curl.lisp")
(require :ecl-curl)
(require :deflate)
(require :ql-minitar)
;;;
;;; PREPARATION OF DIRECTORIES AND FILES
......@@ -129,14 +131,6 @@
(load *quicklisp-setup-file*))
t)
(defun unpack-tarball-symbol ()
(ensure-quicklisp)
(intern "UNPACK-TARBALL" (find-package "QL-MINITAR")))
(defun gunzip-symbol ()
(ensure-quicklisp)
(intern "GUNZIP" (find-package "QL-GUNZIPPER")))
(defun copy-directory (orig dest)
(loop for f in (directory (merge-pathnames *wild-inferiors* orig))
for f2 = (enough-namestring f orig)
......@@ -151,12 +145,10 @@
(let ((temp-filename (ext:mkstemp "fooXXXXXXX")))
(unwind-protect
(progn
(format t "~&;;;~%;;; Deflating ~a to ~a~%;;;"
filename temp-filename)
(funcall (gunzip-symbol) filename temp-filename)
(deflate:gunzip filename temp-filename)
(extract-tarball temp-filename))
(delete-file temp-filename)))
(funcall (unpack-tarball-symbol) filename)))
(ql-minitar:unpack-tarball filename)))
(defun extract-distribution (filename url)
(let ((distribution (loop for base in (list *cache*
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment