;;;; 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))))))))))