@@ -1,100 +1,35 @@

 (uiop:define-package :fwoar.zipfile

-  (:mix :cl :fwoar.lisputils)

+    (:mix :cl :fwoar.lisputils :fwoar.bin-parser)

   (:export ))

 (in-package :fwoar.zipfile)

-(defun read-bytes (n s)

-  (with (seq (make-array n :element-type 'serapeum:octet))

-    (values seq

-            (read-sequence seq s))))

-

-(defun calculate-sizes (desc)

-  (reduce #'+ desc

-          :key #'cadr

-          :initial-value 0))

-

-(defun le->int (bytes)

-  (cadr

-   (reduce (op (destructuring-bind (count val) _1

-                 (list (1+ count)

-                       (+ val

-                          (ash _2

-                               (* count 8))))))

-           bytes

-           :initial-value (list 0 0))))

-

-(defun get-extractable-bytes (desc &optional (bindings ()))

-  (loop for ((name size . other) . rest) on (resolve-sizes desc bindings)

-     until (symbolp size)

-     collect (list* name size other) into extractable

-     finally (return (values extractable

-                             (append (serapeum:unsplice

-                                      (when (symbolp size)

-                                        (list* name size other)))

-                                     rest))))) 

-

-(defun resolve-sizes (desc extant-bindings)

-  (declare (optimize (debug 3)))

-  (loop with bindings = (copy-seq extant-bindings)

-     for (name size . rest) in desc

-     for resolved = (when (symbolp size)

-                      (cdr (assoc size bindings)))

-     when resolved do (push (cons name resolved)

-                            bindings)

-     if resolved collect (list* name resolved rest) into new-desc

-     else collect (list* name size rest) into new-desc

-     finally (return (values new-desc

-                             (remove-duplicates (append (mapcar (op (apply #'cons (subseq _ 0 2)))

-                                                                new-desc)

-                                                        bindings)

-                                                :key 'car

-                                                :from-end t)))))

-

-(defun extract-bytes (desc bytes)

-  (loop

-     with cur-idx = 0

-     for (name size . rest) in desc

-     for next-seq = (subseq bytes cur-idx

-                            (+ cur-idx size))

-     collect (cons name (if rest

-                            (funcall (car rest) next-seq)

-                            next-seq))

-     do (incf cur-idx size)))

-

-(defun parse-struct (desc s)

-  (let* ((struct-size (calculate-sizes desc))

-         (bytes (read-bytes struct-size s)))

-    (extract-bytes desc bytes)))

+(defmacro defun* (name (&rest args) &body body)

+  (let ((defs (cdr (assoc :where body))))

+    `(defun ,name ,args

+       (flet (,@defs)

+         ,@(loop for form in body until (and (consp form) (eql :where (car form)))

+                collect form)))))

 (defun make-zipfile-stream (fn)

   (open fn :element-type '(unsigned-byte 8)))

-

-(defun extract (raw-desc s &optional bindings)

-  (multiple-value-bind (desc remainder) (get-extractable-bytes raw-desc bindings)

-    (let ((next-segment (parse-struct desc s)))

-      (if remainder

-          (append next-segment

-                  (extract remainder s (append next-segment bindings)))

-          next-segment))))

-

 (defparameter *zip-local-file-header*

   '((signature 4)

     (version 2)

     (flags 2)

-    (compression 2 le->int)

+    (compression 2 fwoar.bin-parser:le->int)

     (mod-time 2)

     (mod-date 2)

     (crc-32 4)

-    (compressed-size 4 le->int)

-    (uncompressed-size 4 le->int)

-    (file-name-length 2 le->int)

-    (extra-field-length 2 le->int)

+    (compressed-size 4 fwoar.bin-parser:le->int)

+    (uncompressed-size 4 fwoar.bin-parser:le->int)

+    (file-name-length 2 fwoar.bin-parser:le->int)

+    (extra-field-length 2 fwoar.bin-parser:le->int)

     (file-name file-name-length babel:octets-to-string)

     (extra-field extra-field-length)))

 (defun decode-file-data (metadata s)

-  (let ((crc-32 (le->int (cdr (assoc 'crc-32 metadata))))

+  (let ((crc-32 (fwoar.bin-parser:le->int (cdr (assoc 'crc-32 metadata))))

         (compressed-size (cdr (assoc 'compressed-size metadata)))

         (uncompressed-size (cdr (assoc 'uncompressed-size metadata))))

     (when (= 0 (+ crc-32 compressed-size uncompressed-size))