lisp/emacs-lisp/bindat.el

   1 ;;; bindat.el --- binary data structure packing and unpacking.
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 3, 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