Initial CL parser/generator implementation
This commit is contained in:
345
lib/zip-utilities.lisp
Normal file
345
lib/zip-utilities.lisp
Normal file
@ -0,0 +1,345 @@
|
||||
;;;; 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)
|
||||
|
||||
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
||||
|
||||
;;;; %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))))))))))
|
||||
Reference in New Issue
Block a user