zip memo

parse.lisp

(deftype octet () '(unsigned-byte 8))

(defun read-le-uint (size in)
  (loop FOR i FROM 0 BELOW size
        SUM (ash (read-byte in) (* i 8))))

(defun read-bytes (size in)
  (let ((ary (make-array size :element-type 'octet)))
    (read-sequence ary in)
    ary))

(defstruct local-file-header
  signature 
  version
  flags
  compression-method
  last-modified-time
  last-modified-date
  crc32
  compressed-size
  original-size
  filename
  extended-field)

(defstruct central-directory-file-header
  created-version
  required-version
  flags
  compression-method
  last-modified-time
  last-modified-date
  crc32
  compressed-size
  original-size
  start-disk-number
  internal-file-attr
  external-file-attr
  local-file-header-offset
  filename
  extended-field
  file-comment
  )

(defstruct central-directory-end
  dick-count
  start-central-disk-number
  central-directory-record-count
  total-central-directory-record-count
  central-directory-size
  central-directory-offset
  zip-file-comment)
  
(defun read-local-file-header (in)
  (let* ((version (read-le-uint 2 in))
         (flags (read-le-uint 2 in))
         (compression-method (read-le-uint 2 in))
         (last-modified-time (read-le-uint 2 in))
         (last-modified-date (read-le-uint 2 in))
         (crc32 (read-le-uint 4 in))
         (compressed-size (read-le-uint 4 in))
         (original-size (read-le-uint 4 in))
         (filename-length (read-le-uint 2 in))
         (extended-field-length (read-le-uint 2 in))
         (filename (read-bytes filename-length in))
         (extended-field (read-bytes extended-field-length in))
         )
    (make-local-file-header
     :signature (coerce #(80 75 3 4) 'octets)
     :version version
     :flags flags
     :compression-method compression-method
     :last-modified-time last-modified-time
     :last-modified-date last-modified-date
     :crc32 crc32
     :compressed-size compressed-size
     :original-size original-size
     :filename filename
     :extended-field extended-field)))

(defun read-central-directory-file-header (in)
  (let* ((created-version (read-le-uint 2 in))
         (required-version (read-le-uint 2 in))
         (flags (read-le-uint 2 in))
         (compression-method (read-le-uint 2 in))
         (last-modified-time (read-le-uint 2 in))
         (last-modified-date (read-le-uint 2 in))
         (crc32 (read-le-uint 4 in))
         (compressed-size (read-le-uint 4 in))
         (original-size (read-le-uint 4 in))
         (filename-length (read-le-uint 2 in))
         (extended-field-length (read-le-uint 2 in))
         (file-comment-length (read-le-uint 2 in))
         (start-disk-number (read-le-uint 2 in))
         (internal-file-attr (read-le-uint 2 in))
         (external-file-attr (read-le-uint 4 in))
         (local-file-header-offset (read-le-uint 4 in))
         (filename (read-bytes filename-length in))
         (extended-field (read-bytes extended-field-length in))
         (file-comment (read-bytes file-comment-length in)))
    
    (make-central-directory-file-header
     :created-version created-version
     :required-version required-version
     :flags flags
     :compression-method compression-method
     :last-modified-time last-modified-time
     :last-modified-date last-modified-date
     :crc32 crc32
     :compressed-size compressed-size
     :original-size original-size
     :start-disk-number start-disk-number
     :internal-file-attr internal-file-attr
     :external-file-attr external-file-attr
     :local-file-header-offset local-file-header-offset
     :filename filename
     :extended-field extended-field
     :file-comment file-comment)))
  
(defun read-central-directory-end (in)
  (let* ((dick-count (read-le-uint 2 in))
         (start-central-disk-number (read-le-uint 2 in))
         (central-directory-record-count (read-le-uint 2 in))
         (total-central-directory-record-count (read-le-uint 2 in))
         (central-directory-size (read-le-uint 4 in))
         (central-directory-offset (read-le-uint 4 in))
         (zip-file-comment-size (read-le-uint 2 in))
         (zip-file-comment (read-bytes zip-file-comment-size in)))
    (make-central-directory-end
     :dick-count dick-count
     :start-central-disk-number start-central-disk-number
     :central-directory-record-count central-directory-record-count
     :total-central-directory-record-count total-central-directory-record-count
     :central-directory-size central-directory-size
     :central-directory-offset central-directory-offset 
     :zip-file-comment zip-file-comment)))

(defun read-header (in)
  (let ((signature (read-bytes 4 in)))
    (cond ((equalp signature #(80 75 3 4))
           (read-local-file-header in))
          
          ((equalp signature #(80 75 1 2))
           (read-central-directory-file-header in))

          ((equalp signature #(80 75 5 6))
           (read-central-directory-end in))
          
          ((equalp signature #(0 0 0 0))
           nil) ; XXX: eos

          (t
           (error "unknown signature: ~a" signature)))))
  
(with-open-file (in "/path/to/file.zip"
                    :element-type 'octet)
  (loop FOR header = (read-header in)
        WHILE header
        DO
        (etypecase header
          (local-file-header (print header)
                             (read-bytes (local-file-header-compressed-size header) in))
          (central-directory-file-header (print header))
          (central-directory-end (print header))
          )))
  ))

zip.lisp

;; format
;;   - http://www.tvg.ne.jp/menyukko/cauldron/dtzipformat.html
;;   - http://ja.wikipedia.org/wiki/ZIP_%28%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%83%95%E3%82%A9%E3%83%BC%E3%83%9E%E3%83%83%E3%83%88%29

(require :common-utils) ; https://github.com/sile/common-utils
(use-package :common-utils)

(require :deflate) ; https://github.com/sile/yahoo_briefcase

(require :creole)

;; (require :flexi-streams)

(defstruct central-directory-file-header
  created-version
  required-version
  flags
  compression-method
  last-modified-time
  last-modified-date
  crc32
  compressed-size
  original-size
  start-disk-number
  internal-file-attr
  external-file-attr
  local-file-header-offset
  filename
  extended-field
  file-comment
  )

(defun collect-filepathes (path &aux (path (probe-file path)))
  (let ((dir? (and path
                   (null (pathname-name path))
                   (null (pathname-type path)))))
    (cond ((null path) 
           '())
        
          ((not dir?)
           (list path))

          (t
           (cons path (loop FOR subpath IN (directory (format nil "~a*.*" path))
                            APPEND (collect-filepathes subpath)))))))

(defun write-uint (out size n) ; little endian
  (loop FOR i FROM 0 BELOW size
        DO (write-byte (ldb (byte 8 (* i 8)) n) out))
  (values))

(defun write-uint1 (out n) (write-uint out 1 n))
(defun write-uint2 (out n) (write-uint out 2 n))
(defun write-uint4 (out n) (write-uint out 4 n))

(defun write-bytes (out bytes)
  (write-sequence bytes out)
  (values))

(defconstant +VERSION_RAW+ 10)
(defconstant +VERSION_DEFLATE+ 20)
(defconstant +VERSION_ZIP64+ 45)

(defconstant +METHOD_RAW+ 0)
(defconstant +METHOD_DEFLATE+ 8)

(defun write-local-file (out path data)
  (let* ((time 0)
         (date 0)
         (version +VERSION_RAW+)
         (method +METHOD_RAW+)
         (compressed-data data)
         (crc32 (deflate.crc32:crc compressed-data))
         (name (creole:string-to-octets (subseq (s path) (length *root-path*))
                                        :external-format :sjis))
         (extra-field #())
         (offset (file-position out)))

    (write-bytes out #(80 75 3 4))  ; signature of local-file-header
    (write-uint2 out version)       ; version 
    (write-uint2 out 0)             ; flags
    (write-uint2 out method)        ; compression method
    (write-uint2 out time)          ; last modified time 
    (write-uint2 out date)          ; last modified date
    (write-uint4 out crc32)         ; crc32
    (write-uint4 out (length compressed-data))
    (write-uint4 out (length data)) 
    (write-uint2 out (length name)) 
    (write-uint2 out (length extra-field))
    (write-bytes out name)
    (write-bytes out extra-field)

    (write-bytes out compressed-data)

    (make-central-directory-file-header 
     :created-version +VERSION_DEFLATE+
     :required-version version
     :flags 0
     :compression-method method
     :last-modified-time time
     :last-modified-date date
     :crc32 crc32
     :compressed-size (length compressed-data)
     :original-size (length data)
     :start-disk-number 0
     :internal-file-attr 0  ; binary data
     :external-file-attr 0  ; XXX:
     :local-file-header-offset offset
     :filename name
     :external-file-attr extra-field
     :file-comment #())))

(defun write-files (out filepathes)
  (loop FOR path IN filepathes
        FOR dir? = (and (null (pathname-name path))
                        (null (pathname-type path)))
        FOR data = (if dir? (coerce '() 'octets) (read-binary-file path))
        COLLECT
        (write-local-file out path data)))

(defun write-central-directory-header (out header)
  (with-slots (created-version required-version flags
               compression-method last-modified-time last-modified-date
               crc32 compressed-size original-size start-disk-number
               internal-file-attr external-file-attr local-file-header-offset
               filename extended-field file-comment) header

    (write-bytes out #(80 75 1 2))  ; signature 
    (write-uint2 out created-version)
    (write-uint2 out required-version)
    (write-uint2 out flags)
    (write-uint2 out compression-method)
    (write-uint2 out last-modified-time)
    (write-uint2 out last-modified-date)
    (write-uint4 out crc32)
    (write-uint4 out compressed-size)
    (write-uint4 out original-size)
    (write-uint2 out (length filename))
    (write-uint2 out (length extended-field))
    (write-uint2 out (length file-comment))
    (write-uint2 out start-disk-number)
    (write-uint2 out internal-file-attr)
    (write-uint4 out external-file-attr)
    (write-uint4 out local-file-header-offset)
    (write-bytes out filename)
    (write-bytes out extended-field)
    (write-bytes out file-comment)))

(defun write-end-of-central-directory (out offset total-size count)
  (write-bytes out #(80 75 5 6))  ; signature
  (write-uint2 out 0) ; number of this disk
  (write-uint2 out 0) ; 
  (write-uint2 out count) ; central directory count in this disk
  (write-uint2 out count) ; total central directory count
  (write-uint4 out total-size) ; size of the central directory
  (write-uint4 out offset)
  (write-uint4 out 0)    ; comment length
  (write-bytes out '())) ; comment
  
(defun write-central-directory-headers (out file-headers)
  (loop WITH offset = (file-position out)
        FOR header IN file-headers
        DO
        (write-central-directory-header out header)

        FINALLY
        (let ((total-size (- (file-position out) offset)))
          (write-end-of-central-directory out offset total-size (length file-headers)))))

(defvar *root-path*)
(defun make-zip-file (input-path zip-filename)
  (let* ((*root-path* (format nil "/~{~a~^/~}" (butlast (cdr (pathname-directory (probe-file input-path))))))
         (filepathes (collect-filepathes input-path)))
    (with-open-file (out zip-filename 
                         :direction :output
                         :if-exists :supersede
                         :element-type 'octet)
      (let ((file-headers 
             (write-files out filepathes)))
        (write-central-directory-headers out file-headers))))
  t)