344 lines
14 KiB
Common Lisp
344 lines
14 KiB
Common Lisp
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
|
;;;; This is copyrighted software. See documentation for terms.
|
|
;;;;
|
|
;;;; zip-utilities.lisp --- Utilities concerned with ZIP archives
|
|
;;;;
|
|
;;;; $Id$
|
|
|
|
(cl:in-package #:pmsf-lib)
|
|
|
|
;;;; %File Description:
|
|
;;;;
|
|
;;;; This file contains utilities for ZIP archive processing.
|
|
;;;;
|
|
|
|
(defvar *zip-processing-pathname*)
|
|
|
|
(define-condition zip-processing-warning (simple-warning)
|
|
((pathname :initarg :pathname :initform *zip-processing-pathname*
|
|
:reader zip-processing-warning-pathname))
|
|
(:report
|
|
(lambda (c s)
|
|
(with-standard-io-syntax
|
|
(let ((*print-readably* nil))
|
|
(format s
|
|
"Warning processing ZIP archive ~A: ~?"
|
|
(zip-processing-warning-pathname c)
|
|
(simple-condition-format-control c)
|
|
(simple-condition-format-arguments c)))))))
|
|
|
|
(define-condition zip-processing-error (simple-error)
|
|
((pathname :initarg :pathname :initform *zip-processing-pathname*
|
|
:reader zip-processing-error-pathname))
|
|
(:report
|
|
(lambda (c s)
|
|
(with-standard-io-syntax
|
|
(let ((*print-readably* nil))
|
|
(format s
|
|
"Error processing ZIP archive ~A: ~?"
|
|
(zip-processing-error-pathname c)
|
|
(simple-condition-format-control c)
|
|
(simple-condition-format-arguments c)))))))
|
|
|
|
(defun zip-processing-error (datum &rest arguments)
|
|
(error 'zip-processing-error :format-control datum :format-arguments arguments))
|
|
|
|
(defun zip-processing-warn (datum &rest arguments)
|
|
(warn 'zip-processing-warning :format-control datum :format-arguments arguments))
|
|
|
|
(defun read-zip-field (stream length)
|
|
(ecase length
|
|
(1 (read-byte stream))
|
|
(2 (let ((low (read-byte stream)))
|
|
(dpb (read-byte stream) (byte 8 8) low)))
|
|
(4 (let* ((low (read-byte stream))
|
|
(mid1 (read-byte stream))
|
|
(mid2 (read-byte stream)))
|
|
(dpb (read-byte stream) (byte 8 24)
|
|
(dpb mid2 (byte 8 16)
|
|
(dpb mid1 (byte 8 8)
|
|
low)))))))
|
|
|
|
(defun ensure-zip-signature (stream signature)
|
|
(let ((read-signature (read-zip-field stream 4)))
|
|
(unless (= signature read-signature)
|
|
(zip-processing-error
|
|
"Expected Record Signature ~8,'0X, but got ~8,'0X instead!"
|
|
signature read-signature))
|
|
read-signature))
|
|
|
|
(defmacro define-zip-record (name signature &rest fields)
|
|
(loop with package = (symbol-package name)
|
|
with constructor-name = (symbolicate* package '#:make- name)
|
|
with reader-name = (symbolicate* package '#:read- name)
|
|
with size-name = (symbolicate* package name '#:-size)
|
|
for (field-name field-size) in fields
|
|
collect field-name into field-names
|
|
collect (intern (symbol-name field-name) (find-package "KEYWORD"))
|
|
into field-keys
|
|
collect field-size into field-sizes
|
|
sum field-size into total-size
|
|
finally
|
|
(return
|
|
`(progn
|
|
(defstruct ,name
|
|
,@field-names)
|
|
(defun ,reader-name (stream)
|
|
(ensure-zip-signature stream ,signature)
|
|
(,constructor-name
|
|
,@(loop for field-key in field-keys
|
|
for field-size in field-sizes
|
|
nconcing
|
|
(list field-key `(read-zip-field stream ,field-size)))))
|
|
(defconstant ,size-name ,(+ 4 total-size))))))
|
|
|
|
(define-zip-record zip-end-of-central-directory-record #x06054b50
|
|
(disk-no-this-disk 2)
|
|
(disk-no-central-directory 2)
|
|
(entries-this-disk 2)
|
|
(total-entries 2)
|
|
(size 4)
|
|
(offset 4)
|
|
(file-comment-length 2))
|
|
|
|
(define-zip-record zip-central-directory-record #x02014b50
|
|
(version-made-by 2)
|
|
(version-needed 2)
|
|
(general-purpose 2)
|
|
(compression-method 2)
|
|
(last-mod-file-time 2)
|
|
(last-mod-file-date 2)
|
|
(crc-32 4)
|
|
(compressed-size 4)
|
|
(uncompressed-size 4)
|
|
(file-name-length 2)
|
|
(extra-field-length 2)
|
|
(file-comment-length 2)
|
|
(disk-number-start 2)
|
|
(internal-file-attributes 2)
|
|
(external-file-attributes 4)
|
|
(relative-offset-local-header 4))
|
|
|
|
(define-zip-record zip-local-file-header-record #x04034b50
|
|
(version-needed 2)
|
|
(general-purpose 2)
|
|
(compression-method 2)
|
|
(last-mod-file-time 2)
|
|
(last-mod-file-date 2)
|
|
(crc-32 4)
|
|
(compressed-size 4)
|
|
(uncompressed-size 4)
|
|
(file-name-length 2)
|
|
(extra-field-length 2))
|
|
|
|
(defun find-zip-end-of-central-directory-record (stream)
|
|
(let* ((buffer (make-array (+ 65536 zip-end-of-central-directory-record-size)
|
|
:element-type '(unsigned-byte 8)))
|
|
(file-length (file-length stream))
|
|
(file-start (max 0 (- file-length (length buffer)))))
|
|
(file-position stream file-start)
|
|
(loop with end = (read-sequence buffer stream)
|
|
for start = (search #(#x50 #x4b #x05 #x06) buffer :start2 0 :end2 end)
|
|
then (search #(#x50 #x4b #x05 #x06) buffer :start2 (1+ start) :end2 end)
|
|
while start
|
|
do
|
|
(when (and (<= (+ start zip-end-of-central-directory-record-size)
|
|
(length buffer))
|
|
(= (+ file-start
|
|
start
|
|
zip-end-of-central-directory-record-size
|
|
(dpb (aref buffer (+ start 21))
|
|
(byte 8 8)
|
|
(aref buffer (+ start 20))))
|
|
file-length))
|
|
(file-position stream (+ file-start start))
|
|
(return t)))))
|
|
|
|
(defstruct zip-archive
|
|
entries)
|
|
|
|
(defstruct zip-entry
|
|
file-name
|
|
file-date
|
|
file-comment
|
|
file-offset
|
|
compression-method
|
|
crc-32
|
|
compressed-size
|
|
uncompressed-size)
|
|
|
|
(defun zip-entry-directory-p (entry)
|
|
(let ((last (char (zip-entry-file-name entry)
|
|
(1- (length (zip-entry-file-name entry))))))
|
|
(or (char= last #\/) (char= last #\\))))
|
|
|
|
(defun is-zip-archive-p (pathname)
|
|
(let ((*zip-processing-pathname* (pathname pathname)))
|
|
(handler-bind ((zip-processing-error
|
|
(lambda (c)
|
|
(declare (ignore c))
|
|
(return-from is-zip-archive-p nil))))
|
|
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
|
|
(when (find-zip-end-of-central-directory-record stream)
|
|
(let ((end-record (read-zip-end-of-central-directory-record stream)))
|
|
(zerop
|
|
(zip-end-of-central-directory-record-disk-no-this-disk
|
|
end-record))))))))
|
|
|
|
(defun read-zip-archive (pathname)
|
|
(let ((*zip-processing-pathname* (pathname pathname)))
|
|
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
|
|
(unless (find-zip-end-of-central-directory-record stream)
|
|
(zip-processing-error
|
|
"Did not locate end of central directory record, not a ZIP archive."))
|
|
(let ((end-record (read-zip-end-of-central-directory-record stream)))
|
|
(file-position stream
|
|
(zip-end-of-central-directory-record-offset end-record))
|
|
(loop repeat (zip-end-of-central-directory-record-total-entries end-record)
|
|
for raw = (read-zip-central-directory-record stream)
|
|
for name = (make-array
|
|
(zip-central-directory-record-file-name-length raw)
|
|
:element-type '(unsigned-byte 8))
|
|
do
|
|
(read-sequence name stream)
|
|
(file-position
|
|
stream
|
|
(+ (file-position stream)
|
|
(zip-central-directory-record-extra-field-length raw)
|
|
(zip-central-directory-record-file-comment-length raw)))
|
|
collect
|
|
(make-zip-entry
|
|
:file-name
|
|
(external-format:decode-external-string
|
|
name
|
|
(if (zerop
|
|
(ldb (byte 1 11)
|
|
(zip-central-directory-record-general-purpose raw)))
|
|
#+mswindows '(win32:code-page :id 437)
|
|
#-mswindows :latin-1-safe
|
|
:utf-8))
|
|
:file-date
|
|
(let ((date (zip-central-directory-record-last-mod-file-date raw))
|
|
(time (zip-central-directory-record-last-mod-file-time raw)))
|
|
(encode-universal-time (min 59 (* 2 (ldb (byte 5 0) time)))
|
|
(min 59 (ldb (byte 6 5) time))
|
|
(min 23 (ldb (byte 5 11) time))
|
|
(min 31 (max 1 (ldb (byte 5 0) date)))
|
|
(min 12 (max 1 (ldb (byte 4 5) date)))
|
|
(+ 1980 (ldb (byte 7 9) date))))
|
|
:file-offset
|
|
(zip-central-directory-record-relative-offset-local-header raw)
|
|
:compression-method
|
|
(case (zip-central-directory-record-compression-method raw)
|
|
(0 :stored)
|
|
(1 :shrunk)
|
|
(2 :reduced1)
|
|
(3 :reduced2)
|
|
(4 :reduced3)
|
|
(5 :reduced4)
|
|
(6 :imploded)
|
|
(7 :tokenized)
|
|
(8 :deflated)
|
|
(9 :deflated64)
|
|
(10 :dcl-imploded)
|
|
(12 :bzip2)
|
|
(14 :lzma)
|
|
(18 :terse)
|
|
(19 :lz77)
|
|
(97 :wavpack)
|
|
(98 :ppmd)
|
|
(t (zip-central-directory-record-compression-method raw)))
|
|
:crc-32
|
|
(zip-central-directory-record-crc-32 raw)
|
|
:compressed-size
|
|
(zip-central-directory-record-compressed-size raw)
|
|
:uncompressed-size
|
|
(zip-central-directory-record-uncompressed-size raw))
|
|
into entries
|
|
finally (return (make-zip-archive :entries entries)))))))
|
|
|
|
(defun unzip-zip-entry-from-stream-to-stream (stream entry output)
|
|
(file-position stream (zip-entry-file-offset entry))
|
|
(let ((header (read-zip-local-file-header-record stream)))
|
|
(file-position stream
|
|
(+ (file-position stream)
|
|
(zip-local-file-header-record-file-name-length header)
|
|
(zip-local-file-header-record-extra-field-length header)))
|
|
(case (zip-entry-compression-method entry)
|
|
(:stored
|
|
(loop with bsize = 65536
|
|
with block = (make-array bsize :element-type '(unsigned-byte 8))
|
|
for length = (zip-entry-compressed-size entry)
|
|
then (- length read)
|
|
for read = (read-sequence block stream :end (min bsize length))
|
|
until (progn (write-sequence block output :end read)
|
|
(or (zerop read) (zerop (- length read))))))
|
|
(:deflated
|
|
(deflate:inflate-stream stream output))
|
|
(t
|
|
(zip-processing-error
|
|
"Unsupported ZIP compression method: ~A."
|
|
(zip-entry-compression-method entry))))))
|
|
|
|
(defun unzip-zip-entry-to-stream (pathname entry output)
|
|
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
|
|
(unzip-zip-entry-from-stream-to-stream stream entry output)))
|
|
|
|
(defun sanitized-zip-entry-pathname (entry-filename)
|
|
(let ((pathname (pathname entry-filename)))
|
|
(make-pathname
|
|
:host
|
|
(when (pathname-host pathname)
|
|
(zip-processing-warn "Ignoring strange host component in zip entry filename: ~S" pathname)
|
|
nil)
|
|
:device
|
|
(when (pathname-device pathname)
|
|
(zip-processing-warn "Ignoring strange device component in zip entry filename: ~S" pathname)
|
|
nil)
|
|
:directory
|
|
(let ((directory (pathname-directory pathname)))
|
|
(when (and (consp directory)
|
|
(not (eq (first directory) :relative)))
|
|
(zip-processing-warn "Ignoring non-relative directory in zip entry filename: ~S" pathname)
|
|
(if (keywordp (first directory))
|
|
(setf (first directory) :relative)
|
|
(push :relative directory)))
|
|
(when (and (consp directory) (member :back directory))
|
|
(zip-processing-warn "Ignoring :back entries in directory in zip entry filename: ~S" pathname)
|
|
(setq directory (delete :back directory)))
|
|
directory)
|
|
:name (pathname-name pathname)
|
|
:type (pathname-type pathname)
|
|
:version
|
|
(when (pathname-version pathname)
|
|
(zip-processing-warn "Ignoring strange version component in zip entry filename: ~S" pathname)
|
|
nil))))
|
|
|
|
(defun unzip-zip-archive (pathname directory &key prefix)
|
|
(let* ((*zip-processing-pathname* (pathname pathname))
|
|
(archive (read-zip-archive pathname)))
|
|
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
|
|
(dolist (entry (zip-archive-entries archive))
|
|
(let ((entry-filename (zip-entry-file-name entry)))
|
|
(when prefix
|
|
(multiple-value-bind (new matchp)
|
|
(cl-ppcre:regex-replace prefix entry-filename "")
|
|
(if matchp
|
|
(setq entry-filename new)
|
|
(setq entry-filename nil))))
|
|
(cond
|
|
((null entry-filename)
|
|
;; Skip non-matched entries
|
|
t)
|
|
((zip-entry-directory-p entry)
|
|
(ensure-directories-exist
|
|
(merge-pathnames (make-pathname :name "dummy")
|
|
(merge-pathnames (sanitized-zip-entry-pathname entry-filename) directory))))
|
|
(t
|
|
(let ((destination (merge-pathnames (sanitized-zip-entry-pathname entry-filename) directory)))
|
|
(ensure-directories-exist destination)
|
|
(with-open-file (output destination :direction :output
|
|
:if-exists :supersede
|
|
:element-type '(unsigned-byte 8))
|
|
(unzip-zip-entry-from-stream-to-stream stream entry output))))))))))
|