| 1 | ;;; bindat.el --- binary data structure packing and unpacking. |
| 2 | |
| 3 | ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Kim F. Storm <storm@cua.dk> |
| 6 | ;; Assignment name: struct.el |
| 7 | ;; Keywords: comm data processes |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 14 | ;; any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 23 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 24 | ;; Boston, MA 02110-1301, USA. |
| 25 | |
| 26 | ;;; Commentary: |
| 27 | |
| 28 | ;; Packing and unpacking of (binary) data structures. |
| 29 | ;; |
| 30 | ;; The data formats used in binary files and network protocols are |
| 31 | ;; often structed data which can be described by a C-style structure |
| 32 | ;; such as the one shown below. Using the bindat package, decoding |
| 33 | ;; and encoding binary data formats like these is made simple using a |
| 34 | ;; structure specification which closely resembles the C style |
| 35 | ;; structure declarations. |
| 36 | ;; |
| 37 | ;; Encoded (binary) data is stored in a unibyte string or vector, |
| 38 | ;; while the decoded data is stored in an alist with (FIELD . VALUE) |
| 39 | ;; pairs. |
| 40 | |
| 41 | ;; Example: |
| 42 | |
| 43 | ;; Consider the following C structures: |
| 44 | ;; |
| 45 | ;; struct header { |
| 46 | ;; unsigned long dest_ip; |
| 47 | ;; unsigned long src_ip; |
| 48 | ;; unsigned short dest_port; |
| 49 | ;; unsigned short src_port; |
| 50 | ;; }; |
| 51 | ;; |
| 52 | ;; struct data { |
| 53 | ;; unsigned char type; |
| 54 | ;; unsigned char opcode; |
| 55 | ;; unsigned long length; /* In little endian order */ |
| 56 | ;; unsigned char id[8]; /* nul-terminated string */ |
| 57 | ;; unsigned char data[/* (length + 3) & ~3 */]; |
| 58 | ;; }; |
| 59 | ;; |
| 60 | ;; struct packet { |
| 61 | ;; struct header header; |
| 62 | ;; unsigned char items; |
| 63 | ;; unsigned char filler[3]; |
| 64 | ;; struct data item[/* items */]; |
| 65 | ;; }; |
| 66 | ;; |
| 67 | ;; The corresponding Lisp bindat specification looks like this: |
| 68 | ;; |
| 69 | ;; (setq header-bindat-spec |
| 70 | ;; '((dest-ip ip) |
| 71 | ;; (src-ip ip) |
| 72 | ;; (dest-port u16) |
| 73 | ;; (src-port u16))) |
| 74 | ;; |
| 75 | ;; (setq data-bindat-spec |
| 76 | ;; '((type u8) |
| 77 | ;; (opcode u8) |
| 78 | ;; (length u16r) ;; little endian order |
| 79 | ;; (id strz 8) |
| 80 | ;; (data vec (length)) |
| 81 | ;; (align 4))) |
| 82 | ;; |
| 83 | ;; (setq packet-bindat-spec |
| 84 | ;; '((header struct header-bindat-spec) |
| 85 | ;; (items u8) |
| 86 | ;; (fill 3) |
| 87 | ;; (item repeat (items) |
| 88 | ;; (struct data-bindat-spec)))) |
| 89 | ;; |
| 90 | ;; |
| 91 | ;; A binary data representation may look like |
| 92 | ;; [ 192 168 1 100 192 168 1 101 01 28 21 32 2 0 0 0 |
| 93 | ;; 2 3 5 0 ?A ?B ?C ?D ?E ?F 0 0 1 2 3 4 5 0 0 0 |
| 94 | ;; 1 4 7 0 ?B ?C ?D ?E ?F ?G 0 0 6 7 8 9 10 11 12 0 ] |
| 95 | ;; |
| 96 | ;; The corresponding decoded structure looks like |
| 97 | ;; |
| 98 | ;; ((header |
| 99 | ;; (dest-ip . [192 168 1 100]) |
| 100 | ;; (src-ip . [192 168 1 101]) |
| 101 | ;; (dest-port . 284) |
| 102 | ;; (src-port . 5408)) |
| 103 | ;; (items . 2) |
| 104 | ;; (item ((data . [1 2 3 4 5]) |
| 105 | ;; (id . "ABCDEF") |
| 106 | ;; (length . 5) |
| 107 | ;; (opcode . 3) |
| 108 | ;; (type . 2)) |
| 109 | ;; ((data . [6 7 8 9 10 11 12]) |
| 110 | ;; (id . "BCDEFG") |
| 111 | ;; (length . 7) |
| 112 | ;; (opcode . 4) |
| 113 | ;; (type . 1)))) |
| 114 | ;; |
| 115 | ;; To access a specific value in this structure, use the function |
| 116 | ;; bindat-get-field with the structure as first arg followed by a list |
| 117 | ;; of field names and array indexes, e.g. using the data above, |
| 118 | ;; (bindat-get-field decoded-structure 'item 1 'id) |
| 119 | ;; returns "BCDEFG". |
| 120 | |
| 121 | ;; Binary Data Structure Specification Format |
| 122 | ;; ------------------------------------------ |
| 123 | |
| 124 | ;; We recommend using names that end in `-bindat-spec'; such names |
| 125 | ;; are recognized automatically as "risky" variables. |
| 126 | |
| 127 | ;; The data specification is formatted as follows: |
| 128 | |
| 129 | ;; SPEC ::= ( ITEM... ) |
| 130 | |
| 131 | ;; ITEM ::= ( [FIELD] TYPE ) |
| 132 | ;; | ( [FIELD] eval FORM ) -- eval FORM for side-effect only |
| 133 | ;; | ( [FIELD] fill LEN ) -- skip LEN bytes |
| 134 | ;; | ( [FIELD] align LEN ) -- skip to next multiple of LEN bytes |
| 135 | ;; | ( [FIELD] struct SPEC_NAME ) |
| 136 | ;; | ( [FIELD] union TAG_VAL (TAG SPEC)... [(t SPEC)] ) |
| 137 | ;; | ( [FIELD] repeat COUNT ITEM... ) |
| 138 | |
| 139 | ;; -- In (eval EXPR), the value of the last field is available in |
| 140 | ;; the dynamically bound variable `last'. |
| 141 | |
| 142 | ;; TYPE ::= ( eval EXPR ) -- interpret result as TYPE |
| 143 | ;; | u8 | byte -- length 1 |
| 144 | ;; | u16 | word | short -- length 2, network byte order |
| 145 | ;; | u24 -- 3-byte value |
| 146 | ;; | u32 | dword | long -- length 4, network byte order |
| 147 | ;; | u16r | u24r | u32r -- little endian byte order. |
| 148 | ;; | str LEN -- LEN byte string |
| 149 | ;; | strz LEN -- LEN byte (zero-terminated) string |
| 150 | ;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8) |
| 151 | ;; | ip -- 4 byte vector |
| 152 | ;; | bits LEN -- List with bits set in LEN bytes. |
| 153 | ;; |
| 154 | ;; -- Note: 32 bit values may be limited by emacs' INTEGER |
| 155 | ;; implementation limits. |
| 156 | ;; |
| 157 | ;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13) |
| 158 | ;; and 0x1c 0x28 to (3 5 10 11 12). |
| 159 | |
| 160 | ;; FIELD ::= ( eval EXPR ) -- use result as NAME |
| 161 | ;; | NAME |
| 162 | |
| 163 | ;; LEN ::= ARG |
| 164 | ;; | <omitted> | nil -- LEN = 1 |
| 165 | |
| 166 | |
| 167 | ;; TAG_VAL ::= ARG |
| 168 | |
| 169 | ;; TAG ::= LISP_CONSTANT |
| 170 | ;; | ( eval EXPR ) -- return non-nil if tag match; |
| 171 | ;; current TAG_VAL in `tag'. |
| 172 | |
| 173 | ;; ARG ::= ( eval EXPR ) -- interpret result as ARG |
| 174 | ;; | INTEGER_CONSTANT |
| 175 | ;; | DEREF |
| 176 | |
| 177 | ;; DEREF ::= ( [NAME | INTEGER]... ) -- Field NAME or Array index relative |
| 178 | ;; to current structure spec. |
| 179 | ;; -- see bindat-get-field |
| 180 | |
| 181 | ;; A `union' specification |
| 182 | ;; ([FIELD] union TAG_VAL (TAG SPEC) ... [(t SPEC)]) |
| 183 | ;; is interpreted by evalling TAG_VAL and then comparing that to |
| 184 | ;; each TAG using equal; if a match is found, the corresponding SPEC |
| 185 | ;; is used. |
| 186 | ;; If TAG is a form (eval EXPR), EXPR is evalled with `tag' bound to the |
| 187 | ;; value of TAG_VAL; the corresponding SPEC is used if the result is non-nil. |
| 188 | ;; Finally, if TAG is t, the corresponding SPEC is used unconditionally. |
| 189 | ;; |
| 190 | ;; An `eval' specification |
| 191 | ;; ([FIELD] eval FORM) |
| 192 | ;; is interpreted by evalling FORM for its side effects only. |
| 193 | ;; If FIELD is specified, the value is bound to that field. |
| 194 | ;; The FORM may access and update `bindat-raw' and `bindat-idx' (see `bindat-unpack'). |
| 195 | |
| 196 | ;;; Code: |
| 197 | |
| 198 | ;; Helper functions for structure unpacking. |
| 199 | ;; Relies on dynamic binding of BINDAT-RAW and BINDAT-IDX |
| 200 | |
| 201 | (defvar bindat-raw) |
| 202 | (defvar bindat-idx) |
| 203 | |
| 204 | (defun bindat--unpack-u8 () |
| 205 | (prog1 |
| 206 | (aref bindat-raw bindat-idx) |
| 207 | (setq bindat-idx (1+ bindat-idx)))) |
| 208 | |
| 209 | (defun bindat--unpack-u16 () |
| 210 | (logior (lsh (bindat--unpack-u8) 8) (bindat--unpack-u8))) |
| 211 | |
| 212 | (defun bindat--unpack-u24 () |
| 213 | (logior (lsh (bindat--unpack-u16) 8) (bindat--unpack-u8))) |
| 214 | |
| 215 | (defun bindat--unpack-u32 () |
| 216 | (logior (lsh (bindat--unpack-u16) 16) (bindat--unpack-u16))) |
| 217 | |
| 218 | (defun bindat--unpack-u16r () |
| 219 | (logior (bindat--unpack-u8) (lsh (bindat--unpack-u8) 8))) |
| 220 | |
| 221 | (defun bindat--unpack-u24r () |
| 222 | (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u8) 16))) |
| 223 | |
| 224 | (defun bindat--unpack-u32r () |
| 225 | (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u16r) 16))) |
| 226 | |
| 227 | (defun bindat--unpack-item (type len &optional vectype) |
| 228 | (if (eq type 'ip) |
| 229 | (setq type 'vec len 4)) |
| 230 | (cond |
| 231 | ((memq type '(u8 byte)) |
| 232 | (bindat--unpack-u8)) |
| 233 | ((memq type '(u16 word short)) |
| 234 | (bindat--unpack-u16)) |
| 235 | ((eq type 'u24) |
| 236 | (bindat--unpack-u24)) |
| 237 | ((memq type '(u32 dword long)) |
| 238 | (bindat--unpack-u32)) |
| 239 | ((eq type 'u16r) |
| 240 | (bindat--unpack-u16r)) |
| 241 | ((eq type 'u24r) |
| 242 | (bindat--unpack-u24r)) |
| 243 | ((eq type 'u32r) |
| 244 | (bindat--unpack-u32r)) |
| 245 | ((eq type 'bits) |
| 246 | (let ((bits nil) (bnum (1- (* 8 len))) j m) |
| 247 | (while (>= bnum 0) |
| 248 | (if (= (setq m (bindat--unpack-u8)) 0) |
| 249 | (setq bnum (- bnum 8)) |
| 250 | (setq j 128) |
| 251 | (while (> j 0) |
| 252 | (if (/= 0 (logand m j)) |
| 253 | (setq bits (cons bnum bits))) |
| 254 | (setq bnum (1- bnum) |
| 255 | j (lsh j -1))))) |
| 256 | bits)) |
| 257 | ((eq type 'str) |
| 258 | (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) |
| 259 | (setq bindat-idx (+ bindat-idx len)) |
| 260 | (if (stringp s) s |
| 261 | (string-make-unibyte (concat s))))) |
| 262 | ((eq type 'strz) |
| 263 | (let ((i 0) s) |
| 264 | (while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0)) |
| 265 | (setq i (1+ i))) |
| 266 | (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) |
| 267 | (setq bindat-idx (+ bindat-idx len)) |
| 268 | (if (stringp s) s |
| 269 | (string-make-unibyte (concat s))))) |
| 270 | ((eq type 'vec) |
| 271 | (let ((v (make-vector len 0)) (i 0) (vlen 1)) |
| 272 | (if (consp vectype) |
| 273 | (setq vlen (nth 1 vectype) |
| 274 | vectype (nth 2 vectype)) |
| 275 | (setq type (or vectype 'u8) |
| 276 | vectype nil)) |
| 277 | (while (< i len) |
| 278 | (aset v i (bindat--unpack-item type vlen vectype)) |
| 279 | (setq i (1+ i))) |
| 280 | v)) |
| 281 | (t nil))) |
| 282 | |
| 283 | (defun bindat--unpack-group (spec) |
| 284 | (let (struct last) |
| 285 | (while spec |
| 286 | (let* ((item (car spec)) |
| 287 | (field (car item)) |
| 288 | (type (nth 1 item)) |
| 289 | (len (nth 2 item)) |
| 290 | (vectype (and (eq type 'vec) (nth 3 item))) |
| 291 | (tail 3) |
| 292 | data) |
| 293 | (setq spec (cdr spec)) |
| 294 | (if (and (consp field) (eq (car field) 'eval)) |
| 295 | (setq field (eval (car (cdr field))))) |
| 296 | (if (and type (consp type) (eq (car type) 'eval)) |
| 297 | (setq type (eval (car (cdr type))))) |
| 298 | (if (and len (consp len) (eq (car len) 'eval)) |
| 299 | (setq len (eval (car (cdr len))))) |
| 300 | (if (memq field '(eval fill align struct union)) |
| 301 | (setq tail 2 |
| 302 | len type |
| 303 | type field |
| 304 | field nil)) |
| 305 | (if (and (consp len) (not (eq type 'eval))) |
| 306 | (setq len (apply 'bindat-get-field struct len))) |
| 307 | (if (not len) |
| 308 | (setq len 1)) |
| 309 | (cond |
| 310 | ((eq type 'eval) |
| 311 | (if field |
| 312 | (setq data (eval len)) |
| 313 | (eval len))) |
| 314 | ((eq type 'fill) |
| 315 | (setq bindat-idx (+ bindat-idx len))) |
| 316 | ((eq type 'align) |
| 317 | (while (/= (% bindat-idx len) 0) |
| 318 | (setq bindat-idx (1+ bindat-idx)))) |
| 319 | ((eq type 'struct) |
| 320 | (setq data (bindat--unpack-group (eval len)))) |
| 321 | ((eq type 'repeat) |
| 322 | (let ((index 0) (count len)) |
| 323 | (while (< index count) |
| 324 | (setq data (cons (bindat--unpack-group (nthcdr tail item)) data)) |
| 325 | (setq index (1+ index))) |
| 326 | (setq data (nreverse data)))) |
| 327 | ((eq type 'union) |
| 328 | (let ((tag len) (cases (nthcdr tail item)) case cc) |
| 329 | (while cases |
| 330 | (setq case (car cases) |
| 331 | cases (cdr cases) |
| 332 | cc (car case)) |
| 333 | (if (or (equal cc tag) (equal cc t) |
| 334 | (and (consp cc) (eval cc))) |
| 335 | (setq data (bindat--unpack-group (cdr case)) |
| 336 | cases nil))))) |
| 337 | (t |
| 338 | (setq data (bindat--unpack-item type len vectype) |
| 339 | last data))) |
| 340 | (if data |
| 341 | (if field |
| 342 | (setq struct (cons (cons field data) struct)) |
| 343 | (setq struct (append data struct)))))) |
| 344 | struct)) |
| 345 | |
| 346 | (defun bindat-unpack (spec bindat-raw &optional bindat-idx) |
| 347 | "Return structured data according to SPEC for binary data in BINDAT-RAW. |
| 348 | BINDAT-RAW is a unibyte string or vector. |
| 349 | Optional third arg BINDAT-IDX specifies the starting offset in BINDAT-RAW." |
| 350 | (when (multibyte-string-p bindat-raw) |
| 351 | (error "String is multibyte")) |
| 352 | (unless bindat-idx (setq bindat-idx 0)) |
| 353 | (bindat--unpack-group spec)) |
| 354 | |
| 355 | (defun bindat-get-field (struct &rest field) |
| 356 | "In structured data STRUCT, return value of field named FIELD. |
| 357 | If multiple field names are specified, use the field names to |
| 358 | lookup nested sub-structures in STRUCT, corresponding to the |
| 359 | C-language syntax STRUCT.FIELD1.FIELD2.FIELD3... |
| 360 | An integer value in the field list is taken as an array index, |
| 361 | e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." |
| 362 | (while (and struct field) |
| 363 | (setq struct (if (integerp (car field)) |
| 364 | (nth (car field) struct) |
| 365 | (let ((val (assq (car field) struct))) |
| 366 | (if (consp val) (cdr val))))) |
| 367 | (setq field (cdr field))) |
| 368 | struct) |
| 369 | |
| 370 | |
| 371 | ;; Calculate bindat-raw length of structured data |
| 372 | |
| 373 | (defvar bindat--fixed-length-alist |
| 374 | '((u8 . 1) (byte . 1) |
| 375 | (u16 . 2) (u16r . 2) (word . 2) (short . 2) |
| 376 | (u24 . 3) (u24r . 3) |
| 377 | (u32 . 4) (u32r . 4) (dword . 4) (long . 4) |
| 378 | (ip . 4))) |
| 379 | |
| 380 | (defun bindat--length-group (struct spec) |
| 381 | (let (last) |
| 382 | (while spec |
| 383 | (let* ((item (car spec)) |
| 384 | (field (car item)) |
| 385 | (type (nth 1 item)) |
| 386 | (len (nth 2 item)) |
| 387 | (vectype (and (eq type 'vec) (nth 3 item))) |
| 388 | (tail 3)) |
| 389 | (setq spec (cdr spec)) |
| 390 | (if (and (consp field) (eq (car field) 'eval)) |
| 391 | (setq field (eval (car (cdr field))))) |
| 392 | (if (and type (consp type) (eq (car type) 'eval)) |
| 393 | (setq type (eval (car (cdr type))))) |
| 394 | (if (and len (consp len) (eq (car len) 'eval)) |
| 395 | (setq len (eval (car (cdr len))))) |
| 396 | (if (memq field '(eval fill align struct union)) |
| 397 | (setq tail 2 |
| 398 | len type |
| 399 | type field |
| 400 | field nil)) |
| 401 | (if (and (consp len) (not (eq type 'eval))) |
| 402 | (setq len (apply 'bindat-get-field struct len))) |
| 403 | (if (not len) |
| 404 | (setq len 1)) |
| 405 | (while (eq type 'vec) |
| 406 | (let ((vlen 1)) |
| 407 | (if (consp vectype) |
| 408 | (setq len (* len (nth 1 vectype)) |
| 409 | type (nth 2 vectype)) |
| 410 | (setq type (or vectype 'u8) |
| 411 | vectype nil)))) |
| 412 | (cond |
| 413 | ((eq type 'eval) |
| 414 | (if field |
| 415 | (setq struct (cons (cons field (eval len)) struct)) |
| 416 | (eval len))) |
| 417 | ((eq type 'fill) |
| 418 | (setq bindat-idx (+ bindat-idx len))) |
| 419 | ((eq type 'align) |
| 420 | (while (/= (% bindat-idx len) 0) |
| 421 | (setq bindat-idx (1+ bindat-idx)))) |
| 422 | ((eq type 'struct) |
| 423 | (bindat--length-group |
| 424 | (if field (bindat-get-field struct field) struct) (eval len))) |
| 425 | ((eq type 'repeat) |
| 426 | (let ((index 0) (count len)) |
| 427 | (while (< index count) |
| 428 | (bindat--length-group |
| 429 | (nth index (bindat-get-field struct field)) |
| 430 | (nthcdr tail item)) |
| 431 | (setq index (1+ index))))) |
| 432 | ((eq type 'union) |
| 433 | (let ((tag len) (cases (nthcdr tail item)) case cc) |
| 434 | (while cases |
| 435 | (setq case (car cases) |
| 436 | cases (cdr cases) |
| 437 | cc (car case)) |
| 438 | (if (or (equal cc tag) (equal cc t) |
| 439 | (and (consp cc) (eval cc))) |
| 440 | (progn |
| 441 | (bindat--length-group struct (cdr case)) |
| 442 | (setq cases nil)))))) |
| 443 | (t |
| 444 | (if (setq type (assq type bindat--fixed-length-alist)) |
| 445 | (setq len (* len (cdr type)))) |
| 446 | (if field |
| 447 | (setq last (bindat-get-field struct field))) |
| 448 | (setq bindat-idx (+ bindat-idx len)))))))) |
| 449 | |
| 450 | (defun bindat-length (spec struct) |
| 451 | "Calculate bindat-raw length for STRUCT according to bindat SPEC." |
| 452 | (let ((bindat-idx 0)) |
| 453 | (bindat--length-group struct spec) |
| 454 | bindat-idx)) |
| 455 | |
| 456 | |
| 457 | ;; Pack structured data into bindat-raw |
| 458 | |
| 459 | (defun bindat--pack-u8 (v) |
| 460 | (aset bindat-raw bindat-idx (logand v 255)) |
| 461 | (setq bindat-idx (1+ bindat-idx))) |
| 462 | |
| 463 | (defun bindat--pack-u16 (v) |
| 464 | (aset bindat-raw bindat-idx (logand (lsh v -8) 255)) |
| 465 | (aset bindat-raw (1+ bindat-idx) (logand v 255)) |
| 466 | (setq bindat-idx (+ bindat-idx 2))) |
| 467 | |
| 468 | (defun bindat--pack-u24 (v) |
| 469 | (bindat--pack-u8 (lsh v -16)) |
| 470 | (bindat--pack-u16 v)) |
| 471 | |
| 472 | (defun bindat--pack-u32 (v) |
| 473 | (bindat--pack-u16 (lsh v -16)) |
| 474 | (bindat--pack-u16 v)) |
| 475 | |
| 476 | (defun bindat--pack-u16r (v) |
| 477 | (aset bindat-raw (1+ bindat-idx) (logand (lsh v -8) 255)) |
| 478 | (aset bindat-raw bindat-idx (logand v 255)) |
| 479 | (setq bindat-idx (+ bindat-idx 2))) |
| 480 | |
| 481 | (defun bindat--pack-u24r (v) |
| 482 | (bindat--pack-u16r v) |
| 483 | (bindat--pack-u8 (lsh v -16))) |
| 484 | |
| 485 | (defun bindat--pack-u32r (v) |
| 486 | (bindat--pack-u16r v) |
| 487 | (bindat--pack-u16r (lsh v -16))) |
| 488 | |
| 489 | (defun bindat--pack-item (v type len &optional vectype) |
| 490 | (if (eq type 'ip) |
| 491 | (setq type 'vec len 4)) |
| 492 | (cond |
| 493 | ((null v) |
| 494 | (setq bindat-idx (+ bindat-idx len))) |
| 495 | ((memq type '(u8 byte)) |
| 496 | (bindat--pack-u8 v)) |
| 497 | ((memq type '(u16 word short)) |
| 498 | (bindat--pack-u16 v)) |
| 499 | ((eq type 'u24) |
| 500 | (bindat--pack-u24 v)) |
| 501 | ((memq type '(u32 dword long)) |
| 502 | (bindat--pack-u32 v)) |
| 503 | ((eq type 'u16r) |
| 504 | (bindat--pack-u16r v)) |
| 505 | ((eq type 'u24r) |
| 506 | (bindat--pack-u24r v)) |
| 507 | ((eq type 'u32r) |
| 508 | (bindat--pack-u32r v)) |
| 509 | ((eq type 'bits) |
| 510 | (let ((bnum (1- (* 8 len))) j m) |
| 511 | (while (>= bnum 0) |
| 512 | (setq m 0) |
| 513 | (if (null v) |
| 514 | (setq bnum (- bnum 8)) |
| 515 | (setq j 128) |
| 516 | (while (> j 0) |
| 517 | (if (memq bnum v) |
| 518 | (setq m (logior m j))) |
| 519 | (setq bnum (1- bnum) |
| 520 | j (lsh j -1)))) |
| 521 | (bindat--pack-u8 m)))) |
| 522 | ((memq type '(str strz)) |
| 523 | (let ((l (length v)) (i 0)) |
| 524 | (if (> l len) (setq l len)) |
| 525 | (while (< i l) |
| 526 | (aset bindat-raw (+ bindat-idx i) (aref v i)) |
| 527 | (setq i (1+ i))) |
| 528 | (setq bindat-idx (+ bindat-idx len)))) |
| 529 | ((eq type 'vec) |
| 530 | (let ((l (length v)) (i 0) (vlen 1)) |
| 531 | (if (consp vectype) |
| 532 | (setq vlen (nth 1 vectype) |
| 533 | vectype (nth 2 vectype)) |
| 534 | (setq type (or vectype 'u8) |
| 535 | vectype nil)) |
| 536 | (if (> l len) (setq l len)) |
| 537 | (while (< i l) |
| 538 | (bindat--pack-item (aref v i) type vlen vectype) |
| 539 | (setq i (1+ i))))) |
| 540 | (t |
| 541 | (setq bindat-idx (+ bindat-idx len))))) |
| 542 | |
| 543 | (defun bindat--pack-group (struct spec) |
| 544 | (let (last) |
| 545 | (while spec |
| 546 | (let* ((item (car spec)) |
| 547 | (field (car item)) |
| 548 | (type (nth 1 item)) |
| 549 | (len (nth 2 item)) |
| 550 | (vectype (and (eq type 'vec) (nth 3 item))) |
| 551 | (tail 3)) |
| 552 | (setq spec (cdr spec)) |
| 553 | (if (and (consp field) (eq (car field) 'eval)) |
| 554 | (setq field (eval (car (cdr field))))) |
| 555 | (if (and type (consp type) (eq (car type) 'eval)) |
| 556 | (setq type (eval (car (cdr type))))) |
| 557 | (if (and len (consp len) (eq (car len) 'eval)) |
| 558 | (setq len (eval (car (cdr len))))) |
| 559 | (if (memq field '(eval fill align struct union)) |
| 560 | (setq tail 2 |
| 561 | len type |
| 562 | type field |
| 563 | field nil)) |
| 564 | (if (and (consp len) (not (eq type 'eval))) |
| 565 | (setq len (apply 'bindat-get-field struct len))) |
| 566 | (if (not len) |
| 567 | (setq len 1)) |
| 568 | (cond |
| 569 | ((eq type 'eval) |
| 570 | (if field |
| 571 | (setq struct (cons (cons field (eval len)) struct)) |
| 572 | (eval len))) |
| 573 | ((eq type 'fill) |
| 574 | (setq bindat-idx (+ bindat-idx len))) |
| 575 | ((eq type 'align) |
| 576 | (while (/= (% bindat-idx len) 0) |
| 577 | (setq bindat-idx (1+ bindat-idx)))) |
| 578 | ((eq type 'struct) |
| 579 | (bindat--pack-group |
| 580 | (if field (bindat-get-field struct field) struct) (eval len))) |
| 581 | ((eq type 'repeat) |
| 582 | (let ((index 0) (count len)) |
| 583 | (while (< index count) |
| 584 | (bindat--pack-group |
| 585 | (nth index (bindat-get-field struct field)) |
| 586 | (nthcdr tail item)) |
| 587 | (setq index (1+ index))))) |
| 588 | ((eq type 'union) |
| 589 | (let ((tag len) (cases (nthcdr tail item)) case cc) |
| 590 | (while cases |
| 591 | (setq case (car cases) |
| 592 | cases (cdr cases) |
| 593 | cc (car case)) |
| 594 | (if (or (equal cc tag) (equal cc t) |
| 595 | (and (consp cc) (eval cc))) |
| 596 | (progn |
| 597 | (bindat--pack-group struct (cdr case)) |
| 598 | (setq cases nil)))))) |
| 599 | (t |
| 600 | (setq last (bindat-get-field struct field)) |
| 601 | (bindat--pack-item last type len vectype) |
| 602 | )))))) |
| 603 | |
| 604 | (defun bindat-pack (spec struct &optional bindat-raw bindat-idx) |
| 605 | "Return binary data packed according to SPEC for structured data STRUCT. |
| 606 | Optional third arg BINDAT-RAW is a pre-allocated unibyte string or vector to |
| 607 | pack into. |
| 608 | Optional fourth arg BINDAT-IDX is the starting offset into BINDAT-RAW." |
| 609 | (when (multibyte-string-p bindat-raw) |
| 610 | (error "Pre-allocated string is multibyte")) |
| 611 | (let ((no-return bindat-raw)) |
| 612 | (unless bindat-idx (setq bindat-idx 0)) |
| 613 | (unless bindat-raw |
| 614 | (setq bindat-raw (make-vector (+ bindat-idx (bindat-length spec struct)) 0))) |
| 615 | (bindat--pack-group struct spec) |
| 616 | (if no-return nil (concat bindat-raw)))) |
| 617 | |
| 618 | |
| 619 | ;; Misc. format conversions |
| 620 | |
| 621 | (defun bindat-format-vector (vect fmt sep &optional len) |
| 622 | "Format vector VECT using element format FMT and separator SEP. |
| 623 | Result is a string with each element of VECT formatted using FMT and |
| 624 | separated by the string SEP. If optional fourth arg LEN is given, use |
| 625 | only that many elements from VECT." |
| 626 | (unless len |
| 627 | (setq len (length vect))) |
| 628 | (let ((i len) (fmt2 (concat sep fmt)) (s nil)) |
| 629 | (while (> i 0) |
| 630 | (setq i (1- i) |
| 631 | s (cons (format (if (= i 0) fmt fmt2) (aref vect i)) s))) |
| 632 | (apply 'concat s))) |
| 633 | |
| 634 | (defun bindat-vector-to-dec (vect &optional sep) |
| 635 | "Format vector VECT in decimal format separated by dots. |
| 636 | If optional second arg SEP is a string, use that as separator." |
| 637 | (bindat-format-vector vect "%d" (if (stringp sep) sep "."))) |
| 638 | |
| 639 | (defun bindat-vector-to-hex (vect &optional sep) |
| 640 | "Format vector VECT in hex format separated by dots. |
| 641 | If optional second arg SEP is a string, use that as separator." |
| 642 | (bindat-format-vector vect "%02x" (if (stringp sep) sep ":"))) |
| 643 | |
| 644 | (defun bindat-ip-to-string (ip) |
| 645 | "Format vector IP as an ip address in dotted notation. |
| 646 | The port (if any) is omitted. IP can be a string, as well." |
| 647 | (if (vectorp ip) |
| 648 | (format-network-address ip t) |
| 649 | (format "%d.%d.%d.%d" |
| 650 | (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)))) |
| 651 | |
| 652 | (provide 'bindat) |
| 653 | |
| 654 | ;;; arch-tag: 5e6708c3-03e2-4ad7-9885-5041b779c3fb |
| 655 | ;;; bindat.el ends here |