1b3ac18f |
(uiop:define-package :fwoar.bin-parser
(:use :cl)
|
034feafd |
(:mix :fw.lu :alexandria :serapeum)
|
6ba9a4b6 |
(:import-from :serapeum :op)
|
f2b3d488 |
(:export :le->int :be->int
:read-bytes :extract
:extract-let :byte-array-to-hex-string
:extract-high))
|
1b3ac18f |
(in-package :fwoar.bin-parser)
|
f2b3d488 |
;; stolen from ironclad
(defun byte-array-to-hex-string (vector &key (start 0) end (element-type 'base-char))
"Return a string containing the hexadecimal representation of the
subsequence of VECTOR between START and END. ELEMENT-TYPE controls
the element-type of the returned string."
(declare (type (vector (unsigned-byte 8)) vector)
(type fixnum start)
(type (or null fixnum) end)
(optimize (speed 3) (safety 1)))
(check-type vector (vector (unsigned-byte 8)))
(let* ((end (or end (length vector)))
(length (- end start))
(hexdigits #.(coerce "0123456789abcdef" 'simple-base-string)))
(loop with string = (ecase element-type
;; so that the compiler optimization can jump in
(base-char (make-string (* length 2)
:element-type 'base-char))
(character (make-string (* length 2)
:element-type 'character)))
for i from start below end
for j from 0 below (* length 2) by 2
do (let ((byte (aref vector i)))
(declare (optimize (safety 0)))
(setf (aref string j)
(aref hexdigits (ldb (byte 4 4) byte))
(aref string (1+ j))
(aref hexdigits (ldb (byte 4 0) byte))))
finally (return string))))
|
1b3ac18f |
(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
|
f2b3d488 |
(ash _2
(* count 8))))))
|
1b3ac18f |
bytes
:initial-value (list 0 0))))
|
f2b3d488 |
(defun be->int (bytes)
(cadr
(reduce (op (destructuring-bind (count val) _1
(list (1+ count)
(+ val
(ash _2
(* count 8))))))
(reverse bytes)
:initial-value (list 0 0))))
|
1b3ac18f |
(defun get-extractable-bytes (desc &optional (bindings ()))
(loop for ((name size . other) . rest) on (resolve-sizes desc bindings)
|
f2b3d488 |
until (symbolp size)
collect (list* name size other) into extractable
finally (return (values extractable
(append (when (and size (symbolp size))
(unsplice
(list* name size other)))
|
6ba9a4b6 |
rest)))))
|
1b3ac18f |
(defun resolve-sizes (desc extant-bindings)
(declare (optimize (debug 3)))
(loop with bindings = (copy-seq extant-bindings)
|
f2b3d488 |
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)))))
|
1b3ac18f |
(defun extract-bytes (desc bytes)
(loop
|
f2b3d488 |
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 extract-high (s)
(coerce (loop for next = (read-byte s)
collect next
until (< next 128))
'vector))
|
1b3ac18f |
(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)))
|
f2b3d488 |
(if (car remainder)
|
1b3ac18f |
(append next-segment
(extract remainder s (append next-segment bindings)))
next-segment))))
|
ddcfb5cb |
(defmacro extract-let ((&rest bindings) parser s &body body)
(labels ((collect-binding (binding-spec)
(destructuring-bind (name target) binding-spec
`(,name (cdr (assoc ,target it)))))
(collect-bindings ()
(mapcar #'collect-binding bindings)))
`(let* ((it (extract ,parser ,s))
,@(collect-bindings))
,@body)))
|