diff options
Diffstat (limited to 'lisp/emacs-lisp/bindat.el')
| -rw-r--r-- | lisp/emacs-lisp/bindat.el | 883 |
1 files changed, 602 insertions, 281 deletions
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 0d9ba57d663..76c2e80fda8 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -26,7 +26,7 @@ ;; Packing and unpacking of (binary) data structures. ;; ;; The data formats used in binary files and network protocols are -;; often structed data which can be described by a C-style structure +;; often structured data which can be described by a C-style structure ;; such as the one shown below. Using the bindat package, decoding ;; and encoding binary data formats like these is made simple using a ;; structure specification which closely resembles the C style @@ -41,57 +41,61 @@ ;; Consider the following C structures: ;; ;; struct header { -;; unsigned long dest_ip; -;; unsigned long src_ip; -;; unsigned short dest_port; -;; unsigned short src_port; +;; uint32_t dest_ip; +;; uint32_t src_ip; +;; uint16_t dest_port; +;; uint16_t src_port; ;; }; ;; ;; struct data { -;; unsigned char type; -;; unsigned char opcode; -;; unsigned long length; /* In little endian order */ +;; uint8_t type; +;; uint8_t opcode; +;; uint32_t length; /* In little endian order */ ;; unsigned char id[8]; /* nul-terminated string */ ;; unsigned char data[/* (length + 3) & ~3 */]; ;; }; ;; ;; struct packet { ;; struct header header; -;; unsigned char items; +;; uint8_t items; ;; unsigned char filler[3]; ;; struct data item[/* items */]; ;; }; ;; -;; The corresponding Lisp bindat specification looks like this: +;; The corresponding Lisp bindat specification could look like this: +;; +;; (bindat-defmacro ip () '(vec 4 byte)) ;; ;; (setq header-bindat-spec -;; '((dest-ip ip) +;; (bindat-type +;; (dest-ip ip) ;; (src-ip ip) -;; (dest-port u16) -;; (src-port u16))) +;; (dest-port uint 16) +;; (src-port uint 16))) ;; ;; (setq data-bindat-spec -;; '((type u8) +;; (bindat-type +;; (type u8) ;; (opcode u8) -;; (length u16r) ;; little endian order +;; (length uintr 32) ;; little endian order ;; (id strz 8) -;; (data vec (length)) -;; (align 4))) +;; (data vec length) +;; (_ align 4))) ;; ;; (setq packet-bindat-spec -;; '((header struct header-bindat-spec) -;; (items u8) -;; (fill 3) -;; (item repeat (items) -;; (struct data-bindat-spec)))) -;; +;; (bindat-type +;; (header type header-bindat-spec) +;; (nitems u8) +;; (_ fill 3) +;; (items repeat nitems type data-bindat-spec))) ;; ;; A binary data representation may look like ;; [ 192 168 1 100 192 168 1 101 01 28 21 32 2 0 0 0 ;; 2 3 5 0 ?A ?B ?C ?D ?E ?F 0 0 1 2 3 4 5 0 0 0 ;; 1 4 7 0 ?B ?C ?D ?E ?F ?G 0 0 6 7 8 9 10 11 12 0 ] ;; -;; The corresponding decoded structure looks like +;; The corresponding decoded structure returned by `bindat-unpack' (or taken +;; by `bindat-pack') looks like: ;; ;; ((header ;; (dest-ip . [192 168 1 100]) @@ -111,92 +115,28 @@ ;; (type . 1)))) ;; ;; To access a specific value in this structure, use the function -;; bindat-get-field with the structure as first arg followed by a list +;; `bindat-get-field' with the structure as first arg followed by a list ;; of field names and array indexes, e.g. using the data above, ;; (bindat-get-field decoded-structure 'item 1 'id) ;; returns "BCDEFG". -;; Binary Data Structure Specification Format -;; ------------------------------------------ - -;; We recommend using names that end in `-bindat-spec'; such names -;; are recognized automatically as "risky" variables. - -;; The data specification is formatted as follows: - -;; SPEC ::= ( ITEM... ) - -;; ITEM ::= ( [FIELD] TYPE ) -;; | ( [FIELD] eval FORM ) -- eval FORM for side-effect only -;; | ( [FIELD] fill LEN ) -- skip LEN bytes -;; | ( [FIELD] align LEN ) -- skip to next multiple of LEN bytes -;; | ( [FIELD] struct SPEC_NAME ) -;; | ( [FIELD] union TAG_VAL (TAG SPEC)... [(t SPEC)] ) -;; | ( [FIELD] repeat COUNT ITEM... ) - -;; -- In (eval EXPR), the value of the last field is available in -;; the dynamically bound variable `last'. - -;; TYPE ::= ( eval EXPR ) -- interpret result as TYPE -;; | u8 | byte -- length 1 -;; | u16 | word | short -- length 2, network byte order -;; | u24 -- 3-byte value -;; | u32 | dword | long -- length 4, network byte order -;; | u16r | u24r | u32r -- little endian byte order. -;; | str LEN -- LEN byte string -;; | strz LEN -- LEN byte (zero-terminated) string -;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8) -;; | ip -- 4 byte vector -;; | bits LEN -- List with bits set in LEN bytes. -;; -;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13) -;; and 0x1c 0x28 to (3 5 10 11 12). - -;; FIELD ::= ( eval EXPR ) -- use result as NAME -;; | NAME - -;; LEN ::= ARG -;; | <omitted> | nil -- LEN = 1 - - -;; TAG_VAL ::= ARG - -;; TAG ::= LISP_CONSTANT -;; | ( eval EXPR ) -- return non-nil if tag match; -;; current TAG_VAL in `tag'. - -;; ARG ::= ( eval EXPR ) -- interpret result as ARG -;; | INTEGER_CONSTANT -;; | DEREF - -;; DEREF ::= ( [NAME | INTEGER]... ) -- Field NAME or Array index relative -;; to current structure spec. -;; -- see bindat-get-field - -;; A `union' specification -;; ([FIELD] union TAG_VAL (TAG SPEC) ... [(t SPEC)]) -;; is interpreted by evalling TAG_VAL and then comparing that to -;; each TAG using equal; if a match is found, the corresponding SPEC -;; is used. -;; If TAG is a form (eval EXPR), EXPR is evalled with `tag' bound to the -;; value of TAG_VAL; the corresponding SPEC is used if the result is non-nil. -;; Finally, if TAG is t, the corresponding SPEC is used unconditionally. -;; -;; An `eval' specification -;; ([FIELD] eval FORM) -;; is interpreted by evalling FORM for its side effects only. -;; If FIELD is specified, the value is bound to that field. -;; The FORM may access and update `bindat-raw' and `bindat-idx' (see `bindat-unpack'). - ;;; Code: ;; Helper functions for structure unpacking. -;; Relies on dynamic binding of BINDAT-RAW and BINDAT-IDX +;; Relies on dynamic binding of `bindat-raw' and `bindat-idx'. + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;For `named-let'. + +(cl-defstruct (bindat--type + (:predicate nil) + (:constructor bindat--make)) + le ue pe) (defvar bindat-raw) (defvar bindat-idx) -(defun bindat--unpack-u8 () +(defsubst bindat--unpack-u8 () (prog1 (aref bindat-raw bindat-idx) (setq bindat-idx (1+ bindat-idx)))) @@ -219,77 +159,79 @@ (defun bindat--unpack-u32r () (logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16))) +(defun bindat--unpack-str (len) + (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) + (setq bindat-idx (+ bindat-idx len)) + (if (stringp s) s + (apply #'unibyte-string s)))) + +(defun bindat--unpack-strz (len) + (let ((i 0) s) + (while (and (if len (< i len) t) (/= (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 + (apply #'unibyte-string s)))) + +(defun bindat--unpack-bits (len) + (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 (ash j -1))))) + bits)) + (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 (ash 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 - (apply #'unibyte-string 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 - (apply #'unibyte-string s)))) - ((eq type 'vec) - (let ((v (make-vector len 0)) (i 0) (vlen 1)) + (pcase type + ((or 'u8 'byte) (bindat--unpack-u8)) + ((or 'u16 'word 'short) (bindat--unpack-u16)) + ('u24 (bindat--unpack-u24)) + ((or 'u32 'dword 'long) (bindat--unpack-u32)) + ('u16r (bindat--unpack-u16r)) + ('u24r (bindat--unpack-u24r)) + ('u32r (bindat--unpack-u32r)) + ('bits (bindat--unpack-bits len)) + ('str (bindat--unpack-str len)) + ('strz (bindat--unpack-strz len)) + ('vec + (let ((v (make-vector len 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))) + (dotimes (i len) + (aset v i (bindat--unpack-item type vlen vectype))) v)) - (t nil))) + (_ nil))) + +(defsubst bindat--align (n len) + (* len (/ (+ n (1- len)) len))) ;Isn't there a simpler way? (defun bindat--unpack-group (spec) - (with-suppressed-warnings ((lexical last)) - (defvar last)) + ;; FIXME: Introduce a new primitive so we can mark `bindat-unpack' + ;; as obsolete (maybe that primitive should be a macro which takes + ;; a bindat type *expression* as argument). + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-ue spec)) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) (let (struct last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (dolist (item spec) + (let* ((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)) t))) (if (and type (consp type) (eq (car type) 'eval)) (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) @@ -299,29 +241,28 @@ len type type field field nil)) + (if (and (consp field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (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) + (pcase type + ('eval (if field (setq data (eval len t)) (eval len t))) - ((eq type 'fill) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('align + (setq bindat-idx (bindat--align bindat-idx len))) + ('struct (setq data (bindat--unpack-group (eval len t)))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (push (bindat--unpack-group (nthcdr tail item)) data) - (setq index (1+ index))) - (setq data (nreverse data)))) - ((eq type 'union) + ('repeat + (dotimes (_ len) + (push (bindat--unpack-group (nthcdr tail item)) data)) + (setq data (nreverse data))) + ('union (with-suppressed-warnings ((lexical tag)) (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) @@ -333,14 +274,15 @@ (and (consp cc) (eval cc t))) (setq data (bindat--unpack-group (cdr case)) cases nil))))) - (t + ((pred integerp) (debug t)) + (_ (setq data (bindat--unpack-item type len vectype) last data))) (if data (setq struct (if field (cons (cons field data) struct) (append data struct)))))) - struct)) + struct))) (defun bindat-unpack (spec raw &optional idx) "Return structured data according to SPEC for binary data in RAW. @@ -361,14 +303,12 @@ 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))))) + (elt struct (car field)) + (cdr (assq (car field) struct)))) (setq field (cdr field))) struct) - -;; Calculate bindat-raw length of structured data +;;;; Calculate bindat-raw length of structured data (defvar bindat--fixed-length-alist '((u8 . 1) (byte . 1) @@ -378,19 +318,17 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (ip . 4))) (defun bindat--length-group (struct spec) - (with-suppressed-warnings ((lexical last)) - (defvar last)) - (let (last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-le spec) struct) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) + (let ((struct struct) last) + (dolist (item spec) + (let* ((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)) t))) (if (and type (consp type) (eq (car type) 'eval)) (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) @@ -400,6 +338,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." len type type field field nil)) + (if (and (consp field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (if (and (consp len) (not (eq type 'eval))) (setq len (apply #'bindat-get-field struct len))) (if (not len) @@ -410,27 +350,24 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." type (nth 2 vectype)) (setq type (or vectype 'u8) vectype nil))) - (cond - ((eq type 'eval) + (pcase type + ('eval (if field (setq struct (cons (cons field (eval len t)) struct)) (eval len t))) - ((eq type 'fill) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('align + (setq bindat-idx (bindat--align bindat-idx len))) + ('struct (bindat--length-group (if field (bindat-get-field struct field) struct) (eval len t))) - ((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) + ('repeat + (dotimes (index len) + (bindat--length-group + (nth index (bindat-get-field struct field)) + (nthcdr tail item)))) + ('union (with-suppressed-warnings ((lexical tag)) (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) @@ -443,23 +380,23 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (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)))))))) + (setq bindat-idx (+ bindat-idx len))))))))) (defun bindat-length (spec struct) - "Calculate bindat-raw length for STRUCT according to bindat SPEC." + "Calculate `bindat-raw' length for STRUCT according to bindat SPEC." (let ((bindat-idx 0)) (bindat--length-group struct spec) bindat-idx)) -;; Pack structured data into bindat-raw +;;;; Pack structured data into bindat-raw -(defun bindat--pack-u8 (v) +(defsubst bindat--pack-u8 (v) (aset bindat-raw bindat-idx (logand v 255)) (setq bindat-idx (1+ bindat-idx))) @@ -476,6 +413,10 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u16 (ash v -16)) (bindat--pack-u16 v)) +(defun bindat--pack-u64 (v) + (bindat--pack-u32 (ash v -32)) + (bindat--pack-u32 v)) + (defun bindat--pack-u16r (v) (aset bindat-raw (1+ bindat-idx) (logand (ash v -8) 255)) (aset bindat-raw bindat-idx (logand v 255)) @@ -489,74 +430,74 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u16r v) (bindat--pack-u16r (ash v -16))) +(defun bindat--pack-u64r (v) + (bindat--pack-u32r v) + (bindat--pack-u32r (ash v -32))) + +(defun bindat--pack-str (len v) + (dotimes (i (min len (length v))) + (aset bindat-raw (+ bindat-idx i) (aref v i))) + (setq bindat-idx (+ bindat-idx len))) + +(defun bindat--pack-strz (v) + (let ((len (length v))) + (dotimes (i len) + (aset bindat-raw (+ bindat-idx i) (aref v i))) + (setq bindat-idx (+ bindat-idx len 1)))) + +(defun bindat--pack-bits (len v) + (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 (ash j -1)))) + (bindat--pack-u8 m)))) + (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 (ash 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)) + (pcase type + ((guard (null v)) (setq bindat-idx (+ bindat-idx len))) + ((or 'u8 'byte) (bindat--pack-u8 v)) + ((or 'u16 'word 'short) (bindat--pack-u16 v)) + ('u24 (bindat--pack-u24 v)) + ((or 'u32 'dword 'long) (bindat--pack-u32 v)) + ('u16r (bindat--pack-u16r v)) + ('u24r (bindat--pack-u24r v)) + ('u32r (bindat--pack-u32r v)) + ('bits (bindat--pack-bits len v)) + ((or 'str 'strz) (bindat--pack-str len v)) + ('vec + (let ((l (length v)) (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 + (dotimes (i l) + (bindat--pack-item (aref v i) type vlen vectype)))) + (_ (setq bindat-idx (+ bindat-idx len))))) (defun bindat--pack-group (struct spec) - (with-suppressed-warnings ((lexical last)) - (defvar last)) - (let (last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-pe spec) struct) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) + (let ((struct struct) last) + (dolist (item spec) + (let* ((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)) t))) (if (and type (consp type) (eq (car type) 'eval)) (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) @@ -566,31 +507,30 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." len type type field field nil)) + (if (and (consp field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (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) + (pcase type + ('eval (if field (setq struct (cons (cons field (eval len t)) struct)) (eval len t))) - ((eq type 'fill) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('align + (setq bindat-idx (bindat--align bindat-idx len))) + ('struct (bindat--pack-group (if field (bindat-get-field struct field) struct) (eval len t))) - ((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) + ('repeat + (dotimes (index len) + (bindat--pack-group + (nth index (bindat-get-field struct field)) + (nthcdr tail item)))) + ('union (with-suppressed-warnings ((lexical tag)) (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) @@ -603,10 +543,10 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (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 raw idx) "Return binary data packed according to SPEC for structured data STRUCT. @@ -622,21 +562,15 @@ Optional fourth arg IDX is the starting offset into RAW." (bindat--pack-group struct spec) (if raw nil bindat-raw))) - -;; Misc. format conversions +;;;; Misc. format conversions (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))) + (when len (setq vect (substring vect 0 len))) + (mapconcat (lambda (x) (format fmt x)) vect sep)) (defun bindat-vector-to-dec (vect &optional sep) "Format vector VECT in decimal format separated by dots. @@ -656,6 +590,393 @@ The port (if any) is omitted. IP can be a string, as well." (format "%d.%d.%d.%d" (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)))) +;;;; New approach based on macro-expansion + +;; Further improvements suggested by reading websocket.el: +;; - Support for bit-sized fields? +;; +;; - Add some way to verify redundant/checksum fields's contents without +;; having to provide a complete `:unpack-val' expression. +;; The `:pack-val' thingy can work nicely to compute checksum fields +;; based on previous fields's contents (without impacting or being impacted +;; by the unpacked representation), but if we want to verify +;; those checksums when unpacking, we have to use the :unpack-val +;; and build the whole object by hand instead of being able to focus +;; just on the checksum field. +;; Maybe this could be related to `unit' type fields where we might like +;; to make sure that the "value" we write into it is the same as the +;; value it holds (tho those checks don't happen at the same time (pack +;; vs unpack). +;; +;; - Support for packing/unpacking to/from something else than +;; a unibyte string, e.g. from a buffer. Problems to do that are: +;; - the `str' and `strz' types which use `substring' rather than reading +;; one byte at a time. +;; - the `align' and `fill' which just want to skip without reading/writing +;; - the `pack-uint' case, which would prefer writing the LSB first. +;; - the `align' case needs to now the current position in order to know +;; how far to advance +;; +;; - Don't write triple code when the type is only ever used at a single place +;; (e.g. to unpack). + +(defun bindat--unpack-uint (bitlen) + (let ((v 0) (bitsdone 0)) + (while (< bitsdone bitlen) + (setq v (logior (ash v 8) (bindat--unpack-u8))) + (setq bitsdone (+ bitsdone 8))) + v)) + +(defun bindat--unpack-uintr (bitlen) + (let ((v 0) (bitsdone 0)) + (while (< bitsdone bitlen) + (setq v (logior v (ash (bindat--unpack-u8) bitsdone))) + (setq bitsdone (+ bitsdone 8))) + v)) + +(defun bindat--pack-uint (bitlen v) + (let* ((len (/ bitlen 8)) + (shift (- (* 8 (1- len))))) + (dotimes (_ len) + (bindat--pack-u8 (logand 255 (ash v shift))) + (setq shift (+ 8 shift))))) + +(defun bindat--pack-uintr (bitlen v) + (let* ((len (/ bitlen 8))) + (dotimes (_ len) + (bindat--pack-u8 (logand v 255)) + (setq v (ash v -8))))) + +(defmacro bindat--pcase (&rest args) + "Like `pcase' but optimize the code under the assumption that it's exhaustive." + (declare (indent 1) (debug pcase)) + `(pcase ,@args (pcase--dontcare nil))) + +(cl-defgeneric bindat--type (op head &rest args) + "Return the code for the operation OP of the Bindat type (HEAD . ARGS). +OP can be one of: unpack', (pack VAL), or (length VAL) where VAL +is the name of a variable that will hold the value we need to pack.") + +(cl-defmethod bindat--type (op (_ (eql 'byte))) + (bindat--pcase op + ('unpack `(bindat--unpack-u8)) + (`(length . ,_) `(cl-incf bindat-idx 1)) + (`(pack . ,args) `(bindat--pack-u8 . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql 'uint)) n) + (if (eq n 8) (bindat--type op 'byte) + (bindat--pcase op + ('unpack `(bindat--unpack-uint ,n)) + (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8))) + (`(pack . ,args) `(bindat--pack-uint ,n . ,args))))) + +(cl-defmethod bindat--type (op (_ (eql 'uintr)) n) + (if (eq n 8) (bindat--type op 'byte) + (bindat--pcase op + ('unpack `(bindat--unpack-uintr ,n)) + (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8))) + (`(pack . ,args) `(bindat--pack-uintr ,n . ,args))))) + +(cl-defmethod bindat--type (op (_ (eql 'str)) len) + (bindat--pcase op + ('unpack `(bindat--unpack-str ,len)) + (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(pack . ,args) `(bindat--pack-str ,len . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql 'strz)) &optional len) + (bindat--pcase op + ('unpack `(bindat--unpack-strz ,len)) + (`(length ,val) + `(cl-incf bindat-idx ,(cond + ((null len) `(length ,val)) + ((numberp len) len) + (t `(or ,len (length ,val)))))) + (`(pack . ,args) + (macroexp-let2 nil len len + `(if ,len + ;; Same as non-zero terminated strings since we don't actually add + ;; the terminating zero anyway (because we rely on the fact that + ;; `bindat-raw' was presumably initialized with all-zeroes before + ;; we started). + (bindat--pack-str ,len . ,args) + (bindat--pack-strz . ,args)))))) + +(cl-defmethod bindat--type (op (_ (eql 'bits)) len) + (bindat--pcase op + ('unpack `(bindat--unpack-bits ,len)) + (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(pack . ,args) `(bindat--pack-bits ,len . ,args)))) + +(cl-defmethod bindat--type (_op (_ (eql 'fill)) len) + `(progn (cl-incf bindat-idx ,len) nil)) + +(cl-defmethod bindat--type (_op (_ (eql 'align)) len) + `(progn (cl-callf bindat--align bindat-idx ,len) nil)) + +(cl-defmethod bindat--type (op (_ (eql 'type)) exp) + (bindat--pcase op + ('unpack `(funcall (bindat--type-ue ,exp))) + (`(length . ,args) `(funcall (bindat--type-le ,exp) . ,args)) + (`(pack . ,args) `(funcall (bindat--type-pe ,exp) . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql 'vec)) count &rest type) + (unless type (setq type '(byte))) + (let ((fun (macroexpand-all (bindat--fun type) macroexpand-all-environment))) + (bindat--pcase op + ('unpack + `(let* ((bindat--len ,count) + (bindat--v (make-vector bindat--len 0))) + (dotimes (bindat--i bindat--len) + (aset bindat--v bindat--i (funcall ,fun))) + bindat--v)) + ((and `(length . ,_) + ;; FIXME: Improve the pattern match to recognize more complex + ;; "constant" functions? + (let `#'(lambda (,val) (setq bindat-idx (+ bindat-idx ,len))) fun) + (guard (not (macroexp--fgrep `((,val)) len)))) + ;; Optimize the case where the size of each element is constant. + `(cl-incf bindat-idx (* ,count ,len))) + ;; FIXME: It's tempting to use `(mapc (lambda (,val) ,exp) ,val)' + ;; which would be more efficient when `val' is a list, + ;; but that's only right if length of `val' is indeed `count'. + (`(,_ ,val) + `(dotimes (bindat--i ,count) + (funcall ,fun (elt ,val bindat--i))))))) + +(cl-defmethod bindat--type (op (_ (eql 'unit)) val) + (pcase op ('unpack val) (_ nil))) + +(cl-defmethod bindat--type (op (_ (eql 'struct)) &rest args) + (apply #'bindat--type op args)) + +(cl-defmethod bindat--type (op (_ (eql :pack-var)) var &rest fields) + (unless (consp (cdr fields)) + (error "`:pack-var VAR' needs to be followed by fields")) + (bindat--pcase op + ((or 'unpack (guard (null var))) + (apply #'bindat--type op fields)) + (`(,_ ,val) + `(let ((,var ,val)) ,(apply #'bindat--type op fields))))) + +(cl-defmethod bindat--type (op (field cons) &rest fields) + (named-let loop + ((fields (cons field fields)) + (labels ())) + (bindat--pcase fields + ('nil + (bindat--pcase op + ('unpack + (let ((exp ())) + (pcase-dolist (`(,label . ,labelvar) labels) + (setq exp + (if (eq label '_) + (if exp `(nconc ,labelvar ,exp) labelvar) + `(cons (cons ',label ,labelvar) ,exp)))) + exp)) + (_ nil))) + (`(:unpack-val ,exp) + ;; Make it so `:kwd nil' is the same as the absence of the keyword arg. + (if exp (pcase op ('unpack exp)) (loop nil labels))) + + (`((,label . ,type) . ,fields) + (let* ((get-field-val + (let ((tail (memq :pack-val type))) + ;; FIXME: This `TYPE.. :pack EXP' syntax doesn't work well + ;; when TYPE is a struct (a list of fields) or with extensions + ;; such as allowing TYPE to be `if ...'. + (if tail + (prog1 (cadr tail) + (setq type (butlast type (length tail))))))) + (fieldvar (make-symbol (format "field%d" (length fields)))) + (labelvar + (cond + ((eq label '_) fieldvar) + ((keywordp label) + (intern (substring (symbol-name label) 1))) + (t label))) + (field-fun (bindat--fun type)) + (rest-exp (loop fields `((,label . ,labelvar) . ,labels)))) + (bindat--pcase op + ('unpack + (let ((code + `(let ((,labelvar (funcall ,field-fun))) + ,rest-exp))) + (if (or (eq label '_) (not (assq label labels))) + code + (macroexp-warn-and-return + (format "Duplicate label: %S" label) + code)))) + (`(,_ ,val) + ;; `cdr-safe' is easier to optimize (can't signal an error). + `(let ((,fieldvar ,(or get-field-val + (if (eq label '_) val + `(cdr-safe (assq ',label ,val)))))) + (funcall ,field-fun ,fieldvar) + ,@(when rest-exp + `((let ,(unless (eq labelvar fieldvar) + `((,labelvar ,fieldvar))) + (ignore ,labelvar) + ,rest-exp)))))))) + (_ (error "Unrecognized format in bindat fields: %S" fields))))) + +(def-edebug-elem-spec 'bindat-struct + '([&rest (symbolp bindat-type &optional ":pack-val" def-form)] + &optional ":unpack-val" def-form)) + +(def-edebug-elem-spec 'bindat-type + '(&or ["uint" def-form] + ["uintr" def-form] + ["str" def-form] + ["strz" &optional def-form] + ["bits" def-form] + ["fill" def-form] + ["align" def-form] + ["vec" def-form bindat-type] + ["repeat" def-form bindat-type] + ["type" def-form] + ["struct" bindat-struct] + ["unit" def-form] + [":pack-var" symbolp bindat-type] + symbolp ;; u8, u16, etc... + bindat-struct)) + +(defmacro bindat-type (&rest type) + "Return the Bindat type value to pack&unpack TYPE. +TYPE is a Bindat type expression. It can take the following forms: + + uint BITLEN - Big-endian unsigned integer + uintr BITLEN - Little-endian unsigned integer + str LEN - Byte string + strz [LEN] - Zero-terminated byte-string + bits LEN - Bit vector (LEN is counted in bytes) + fill LEN - Just a filler + align LEN - Fill up to the next multiple of LEN bytes + vec COUNT TYPE - COUNT repetitions of TYPE + type EXP - Indirection; EXP should return a Bindat type value + unit EXP - 0-width type holding the value returned by EXP + struct FIELDS... - A composite type + +When the context makes it clear, the symbol `struct' can be omitted. +A composite type is a list of FIELDS where each FIELD is of the form + + (LABEL TYPE) + +where LABEL can be `_' if the field should not deserve a name. + +Composite types get normally packed/unpacked to/from alists, but this can be +controlled in the following way: +- If the list of fields ends with `:unpack-val EXP', then unpacking will + return the value of EXP (which has the previous fields in its scope). +- If a field's TYPE is followed by `:pack-val EXP', then the value placed + into this field will be that returned by EXP instead of looking up the alist. +- If the list of fields is preceded with `:pack-var VAR' then the object to + be packed is bound to VAR when evaluating the EXPs of `:pack-val'. + +All the above BITLEN, LEN, COUNT, and EXP are ELisp expressions evaluated +in the current lexical context extended with the previous fields. + +TYPE can additionally be one of the Bindat type macros defined with +`bindat-defmacro' (and listed below) or an ELisp expression which returns +a bindat type expression." + (declare (indent 0) (debug (bindat-type))) + `(progn + (defvar bindat-idx) + (bindat--make :ue ,(bindat--toplevel 'unpack type) + :le ,(bindat--toplevel 'length type) + :pe ,(bindat--toplevel 'pack type)))) + +(eval-and-compile + (defconst bindat--primitives '(byte uint uintr str strz bits fill align + struct type vec unit))) + +(eval-and-compile + (defvar bindat--macroenv + (mapcar (lambda (s) (cons s (lambda (&rest args) + (bindat--makefun (cons s args))))) + bindat--primitives))) + +(defmacro bindat-defmacro (name args &rest body) + "Define a new Bindat type as a macro." + (declare (indent 2) (doc-string 3) (debug (&define name sexp def-body))) + (let ((leaders ())) + (while (and (cdr body) + (or (stringp (car body)) + (memq (car-safe (car body)) '(:documentation declare)))) + (push (pop body) leaders)) + ;; FIXME: Add support for Edebug decls to those macros. + `(eval-and-compile ;; Yuck! But needed to define types where you use them! + (setf (alist-get ',name bindat--macroenv) + (lambda ,args ,@(nreverse leaders) + (bindat--fun ,(macroexp-progn body))))))) + +(put 'bindat-type 'function-documentation '(bindat--make-docstring)) +(defun bindat--make-docstring () + ;; Largely inspired from `pcase--make-docstring'. + (let* ((main (documentation (symbol-function 'bindat-type) 'raw)) + (ud (help-split-fundoc main 'bindat-type))) + (require 'help-fns) + (declare-function help-fns--signature "help-fns") + (with-temp-buffer + (insert (or (cdr ud) main)) + (pcase-dolist (`(,name . ,me) (reverse bindat--macroenv)) + (unless (memq name bindat--primitives) + (let ((doc (documentation me 'raw))) + (insert "\n\n-- ") + (setq doc (help-fns--signature name doc me + (indirect-function me) + nil)) + (insert "\n" (or doc "Not documented."))))) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) + +(bindat-defmacro u8 () "Unsigned 8bit integer." '(byte)) +(bindat-defmacro sint (bitlen r) + "Signed integer of size BITLEN. +Bigendian if R is nil and little endian if not." + (let ((bl (make-symbol "bitlen")) + (max (make-symbol "max")) + (wrap (make-symbol "wrap"))) + `(let* ((,bl ,bitlen) + (,max (ash 1 (1- ,bl))) + (,wrap (+ ,max ,max))) + (struct :pack-var v + (n if ,r (uintr ,bl) (uint ,bl) + :pack-val (if (< v 0) (+ v ,wrap) v)) + :unpack-val (if (>= n ,max) (- n ,wrap) n))))) + +(bindat-defmacro repeat (count &rest type) + "Like `vec', but unpacks to a list rather than a vector." + `(:pack-var v + (v vec ,count ,@type :pack-val v) + :unpack-val (append v nil))) + +(defvar bindat--op nil + "The operation we're currently building. +This is a simple symbol and can be one of: `unpack', `pack', or `length'. +This is used during macroexpansion of `bindat-type' so that the +macros know which code to generate. +FIXME: this is closely related and very similar to the `op' argument passed +to `bindat--type', yet it's annoyingly different.") + +(defun bindat--fun (type) + (if (or (keywordp (car type)) (consp (car type))) (cons 'struct type) + type)) + +(defun bindat--makefun (type) + (let* ((v (make-symbol "v")) + (args (pcase bindat--op ('unpack ()) (_ (list v))))) + (pcase (apply #'bindat--type + (pcase bindat--op ('unpack 'unpack) (op `(,op . ,args))) + type) + (`(funcall ,f . ,(pred (equal args))) f) ;η-reduce. + (exp `(lambda ,args ,exp))))) + +(defun bindat--toplevel (op type) + (let* ((bindat--op op) + (env `(,@bindat--macroenv + ,@macroexpand-all-environment))) + (macroexpand-all (bindat--fun type) env))) + (provide 'bindat) ;;; bindat.el ends here |