(defvar bindat-raw)
(defvar bindat-idx)
(defun bindat--unpack-u8 ()
(prog1
(aref bindat-raw bindat-idx)
(setq bindat-idx (1+ bindat-idx))))
(defun bindat--unpack-u16 ()
(logior (lsh (bindat--unpack-u8) 8) (bindat--unpack-u8)))
(defun bindat--unpack-u24 ()
(logior (lsh (bindat--unpack-u16) 8) (bindat--unpack-u8)))
(defun bindat--unpack-u32 ()
(logior (lsh (bindat--unpack-u16) 16) (bindat--unpack-u16)))
(defun bindat--unpack-u16r ()
(logior (bindat--unpack-u8) (lsh (bindat--unpack-u8) 8)))
(defun bindat--unpack-u24r ()
(logior (bindat--unpack-u16r) (lsh (bindat--unpack-u8) 16)))
(defun bindat--unpack-u32r ()
(logior (bindat--unpack-u16r) (lsh (bindat--unpack-u16r) 16)))
(defun bindat--unpack-item (type len &optional vectype)
(if (eq type 'ip)
(setq type 'vec len 4))
(cond
((memq type '(u8 byte))
(bindat--unpack-u8))
((memq type '(u16 word short))
(bindat--unpack-u16))
((eq type 'u24)
(bindat--unpack-u24))
((memq type '(u32 dword long))
(bindat--unpack-u32))
((eq type 'u16r)
(bindat--unpack-u16r))
((eq type 'u24r)
(bindat--unpack-u24r))
((eq type 'u32r)
(bindat--unpack-u32r))
((eq type 'bits)
(let ((bits nil) (bnum (1- (* 8 len))) j m)
(while (>= bnum 0)
(if (= (setq m (bindat--unpack-u8)) 0)
(setq bnum (- bnum 8))
(setq j 128)
(while (> j 0)
(if (/= 0 (logand m j))
(setq bits (cons bnum bits)))
(setq bnum (1- bnum)
j (lsh j -1)))))
bits))
((eq type 'str)
(let ((s (substring bindat-raw bindat-idx (+ bindat-idx len))))
(setq bindat-idx (+ bindat-idx len))
(if (stringp s) s
(string-make-unibyte (concat s)))))
((eq type 'strz)
(let ((i 0) s)
(while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0))
(setq i (1+ i)))
(setq s (substring bindat-raw bindat-idx (+ bindat-idx i)))
(setq bindat-idx (+ bindat-idx len))
(if (stringp s) s
(string-make-unibyte (concat s)))))
((eq type 'vec)
(let ((v (make-vector len 0)) (i 0) (vlen 1))
(if (consp vectype)
(setq vlen (nth 1 vectype)
vectype (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil))
(while (< i len)
(aset v i (bindat--unpack-item type vlen vectype))
(setq i (1+ i)))
v))
(t nil)))
(defun bindat--unpack-group (spec)
(let (struct last)
(while spec
(let* ((item (car spec))
(field (car item))
(type (nth 1 item))
(len (nth 2 item))
(vectype (and (eq type 'vec) (nth 3 item)))
(tail 3)
data)
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)))))
(if (and type (consp type) (eq (car type) 'eval))
(setq type (eval (car (cdr type)))))
(if (and len (consp len) (eq (car len) 'eval))
(setq len (eval (car (cdr len)))))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
type field
field nil))
(if (and (consp len) (not (eq type 'eval)))
(setq len (apply 'bindat-get-field struct len)))
(if (not len)
(setq len 1))
(cond
((eq type 'eval)
(if field
(setq data (eval len))
(eval len)))
((eq type 'fill)
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
(setq data (bindat--unpack-group (eval len))))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
(setq data (cons (bindat--unpack-group (nthcdr tail item)) data))
(setq index (1+ index)))
(setq data (nreverse data))))
((eq type 'union)
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
(and (consp cc) (eval cc)))
(setq data (bindat--unpack-group (cdr case))
cases nil)))))
(t
(setq data (bindat--unpack-item type len vectype)
last data)))
(if data
(if field
(setq struct (cons (cons field data) struct))
(setq struct (append data struct))))))
struct))
(defun bindat-unpack (spec bindat-raw &optional bindat-idx)
"Return structured data according to SPEC for binary data in BINDAT-RAW.
BINDAT-RAW is a unibyte string or vector.
Optional third arg BINDAT-IDX specifies the starting offset in BINDAT-RAW."
(when (multibyte-string-p bindat-raw)
(error "String is multibyte"))
(unless bindat-idx (setq bindat-idx 0))
(bindat--unpack-group spec))
(defun bindat-get-field (struct &rest field)
"In structured data STRUCT, return value of field named FIELD.
If multiple field names are specified, use the field names to
lookup nested sub-structures in STRUCT, corresponding to the
C-language syntax STRUCT.FIELD1.FIELD2.FIELD3...
An integer value in the field list is taken as an array index,
e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(while (and struct field)
(setq struct (if (integerp (car field))
(nth (car field) struct)
(let ((val (assq (car field) struct)))
(if (consp val) (cdr val)))))
(setq field (cdr field)))
struct)
(defvar bindat--fixed-length-alist
'((u8 . 1) (byte . 1)
(u16 . 2) (u16r . 2) (word . 2) (short . 2)
(u24 . 3) (u24r . 3)
(u32 . 4) (u32r . 4) (dword . 4) (long . 4)
(ip . 4)))
(defun bindat--length-group (struct spec)
(let (last)
(while spec
(let* ((item (car spec))
(field (car item))
(type (nth 1 item))
(len (nth 2 item))
(vectype (and (eq type 'vec) (nth 3 item)))
(tail 3))
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)))))
(if (and type (consp type) (eq (car type) 'eval))
(setq type (eval (car (cdr type)))))
(if (and len (consp len) (eq (car len) 'eval))
(setq len (eval (car (cdr len)))))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
type field
field nil))
(if (and (consp len) (not (eq type 'eval)))
(setq len (apply 'bindat-get-field struct len)))
(if (not len)
(setq len 1))
(while (eq type 'vec)
(let ((vlen 1))
(if (consp vectype)
(setq len (* len (nth 1 vectype))
type (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil))))
(cond
((eq type 'eval)
(if field
(setq struct (cons (cons field (eval len)) struct))
(eval len)))
((eq type 'fill)
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
(bindat--length-group
(if field (bindat-get-field struct field) struct) (eval len)))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
(bindat--length-group
(nth index (bindat-get-field struct field))
(nthcdr tail item))
(setq index (1+ index)))))
((eq type 'union)
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
(and (consp cc) (eval cc)))
(progn
(bindat--length-group struct (cdr case))
(setq cases nil))))))
(t
(if (setq type (assq type bindat--fixed-length-alist))
(setq len (* len (cdr type))))
(if field
(setq last (bindat-get-field struct field)))
(setq bindat-idx (+ bindat-idx len))))))))
(defun bindat-length (spec struct)
"Calculate bindat-raw length for STRUCT according to bindat SPEC."
(let ((bindat-idx 0))
(bindat--length-group struct spec)
bindat-idx))
(defun bindat--pack-u8 (v)
(aset bindat-raw bindat-idx (logand v 255))
(setq bindat-idx (1+ bindat-idx)))
(defun bindat--pack-u16 (v)
(aset bindat-raw bindat-idx (logand (lsh v -8) 255))
(aset bindat-raw (1+ bindat-idx) (logand v 255))
(setq bindat-idx (+ bindat-idx 2)))
(defun bindat--pack-u24 (v)
(bindat--pack-u8 (lsh v -16))
(bindat--pack-u16 v))
(defun bindat--pack-u32 (v)
(bindat--pack-u16 (lsh v -16))
(bindat--pack-u16 v))
(defun bindat--pack-u16r (v)
(aset bindat-raw (1+ bindat-idx) (logand (lsh v -8) 255))
(aset bindat-raw bindat-idx (logand v 255))
(setq bindat-idx (+ bindat-idx 2)))
(defun bindat--pack-u24r (v)
(bindat--pack-u16r v)
(bindat--pack-u8 (lsh v -16)))
(defun bindat--pack-u32r (v)
(bindat--pack-u16r v)
(bindat--pack-u16r (lsh v -16)))
(defun bindat--pack-item (v type len &optional vectype)
(if (eq type 'ip)
(setq type 'vec len 4))
(cond
((null v)
(setq bindat-idx (+ bindat-idx len)))
((memq type '(u8 byte))
(bindat--pack-u8 v))
((memq type '(u16 word short))
(bindat--pack-u16 v))
((eq type 'u24)
(bindat--pack-u24 v))
((memq type '(u32 dword long))
(bindat--pack-u32 v))
((eq type 'u16r)
(bindat--pack-u16r v))
((eq type 'u24r)
(bindat--pack-u24r v))
((eq type 'u32r)
(bindat--pack-u32r v))
((eq type 'bits)
(let ((bnum (1- (* 8 len))) j m)
(while (>= bnum 0)
(setq m 0)
(if (null v)
(setq bnum (- bnum 8))
(setq j 128)
(while (> j 0)
(if (memq bnum v)
(setq m (logior m j)))
(setq bnum (1- bnum)
j (lsh j -1))))
(bindat--pack-u8 m))))
((memq type '(str strz))
(let ((l (length v)) (i 0))
(if (> l len) (setq l len))
(while (< i l)
(aset bindat-raw (+ bindat-idx i) (aref v i))
(setq i (1+ i)))
(setq bindat-idx (+ bindat-idx len))))
((eq type 'vec)
(let ((l (length v)) (i 0) (vlen 1))
(if (consp vectype)
(setq vlen (nth 1 vectype)
vectype (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil))
(if (> l len) (setq l len))
(while (< i l)
(bindat--pack-item (aref v i) type vlen vectype)
(setq i (1+ i)))))
(t
(setq bindat-idx (+ bindat-idx len)))))
(defun bindat--pack-group (struct spec)
(let (last)
(while spec
(let* ((item (car spec))
(field (car item))
(type (nth 1 item))
(len (nth 2 item))
(vectype (and (eq type 'vec) (nth 3 item)))
(tail 3))
(setq spec (cdr spec))
(if (and (consp field) (eq (car field) 'eval))
(setq field (eval (car (cdr field)))))
(if (and type (consp type) (eq (car type) 'eval))
(setq type (eval (car (cdr type)))))
(if (and len (consp len) (eq (car len) 'eval))
(setq len (eval (car (cdr len)))))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
type field
field nil))
(if (and (consp len) (not (eq type 'eval)))
(setq len (apply 'bindat-get-field struct len)))
(if (not len)
(setq len 1))
(cond
((eq type 'eval)
(if field
(setq struct (cons (cons field (eval len)) struct))
(eval len)))
((eq type 'fill)
(setq bindat-idx (+ bindat-idx len)))
((eq type 'align)
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
((eq type 'struct)
(bindat--pack-group
(if field (bindat-get-field struct field) struct) (eval len)))
((eq type 'repeat)
(let ((index 0) (count len))
(while (< index count)
(bindat--pack-group
(nth index (bindat-get-field struct field))
(nthcdr tail item))
(setq index (1+ index)))))
((eq type 'union)
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
(and (consp cc) (eval cc)))
(progn
(bindat--pack-group struct (cdr case))
(setq cases nil))))))
(t
(setq last (bindat-get-field struct field))
(bindat--pack-item last type len vectype)
))))))
(defun bindat-pack (spec struct &optional bindat-raw bindat-idx)
"Return binary data packed according to SPEC for structured data STRUCT.
Optional third arg BINDAT-RAW is a pre-allocated unibyte string or vector to
pack into.
Optional fourth arg BINDAT-IDX is the starting offset into BINDAT-RAW."
(when (multibyte-string-p bindat-raw)
(error "Pre-allocated string is multibyte"))
(let ((no-return bindat-raw))
(unless bindat-idx (setq bindat-idx 0))
(unless bindat-raw
(setq bindat-raw (make-vector (+ bindat-idx (bindat-length spec struct)) 0)))
(bindat--pack-group struct spec)
(if no-return nil (concat bindat-raw))))
(defun bindat-format-vector (vect fmt sep &optional len)
"Format vector VECT using element format FMT and separator SEP.
Result is a string with each element of VECT formatted using FMT and
separated by the string SEP. If optional fourth arg LEN is given, use
only that many elements from VECT."
(unless len
(setq len (length vect)))
(let ((i len) (fmt2 (concat sep fmt)) (s nil))
(while (> i 0)
(setq i (1- i)
s (cons (format (if (= i 0) fmt fmt2) (aref vect i)) s)))
(apply 'concat s)))
(defun bindat-vector-to-dec (vect &optional sep)
"Format vector VECT in decimal format separated by dots.
If optional second arg SEP is a string, use that as separator."
(bindat-format-vector vect "%d" (if (stringp sep) sep ".")))
(defun bindat-vector-to-hex (vect &optional sep)
"Format vector VECT in hex format separated by dots.
If optional second arg SEP is a string, use that as separator."
(bindat-format-vector vect "%02x" (if (stringp sep) sep ":")))
(defun bindat-ip-to-string (ip)
"Format vector IP as an ip address in dotted notation.
The port (if any) is omitted. IP can be a string, as well."
(if (vectorp ip)
(format-network-address ip t)
(format "%d.%d.%d.%d"
(aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3))))
(provide 'bindat)