mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-06 02:40:26 -08:00
130 lines
4.3 KiB
Common Lisp
130 lines
4.3 KiB
Common Lisp
(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)))))))))
|