new file mode 100644

@@ -0,0 +1,80 @@

+(uiop:define-package :fwoar.bin-parser

+    (:use :cl)

+    (:mix :fw.lu :alexandria :serapeum))

+

+(in-package :fwoar.bin-parser)

+

+(defun read-bytes (n s)

+  (with (seq (make-array n :element-type '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 (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)))

+

+(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))))

@@ -1,5 +1,16 @@

 ;;;; fwoar.lisputils.asd

 (in-package :asdf-user)

+

+(defsystem #:fwoar.lisputils/string-utils

+  :description "A binary parser"

+  :author "fiddlerwoaroof <fiddlerwoaroof@gmail.com"

+  :license "MIT"

+  :depends-on (#:should-test)

+  :components ((:file "string-utils/package")

+               (:file "string-utils/string-utils" :depends-on ("string-utils/package"))

+               #-lispworks

+               (:file "string-utils/test" :depends-on ("string-utils/string-utils"))))

+

 (asdf:defsystem #:fwoar.lisputils

   :description "Some utilities common to other libraries I'm writing"

   :author "fiddlerwoaroof <fiddlerwoaroof@gmail.com"

@@ -13,6 +24,7 @@

                #:serapeum

                #:cl-containers

                #:iterate

+               #:fwoar.lisputils/string-utils

                #-lispworks #:plump

                #:positional-lambda

                #-lispworks #:should-test)

@@ -24,13 +36,17 @@

                (:file "clos-helpers")

                (:file "counter")

                (:file "vector-utils")

-               (:file "string-utils/package")

-               (:file "string-utils/string-utils")

                #-lispworks

                (:file "non-lispworks")

                #-lispworks

-               (:file "string-utils/test")

-               #-lispworks

                (:file "patmatch")

                (:file "glambda")))

+(defsystem #:fwoar.lisputils/bin-parser

+  :description "A binary parser"

+  :author "fiddlerwoaroof <fiddlerwoaroof@gmail.com"

+  :license "MIT"

+  :depends-on (:fwoar.lisputils

+               :alexandria

+               :serapeum)

+  :components ((:file "bin-parser")))