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