1# Implements the 'binary scan' and 'binary format' commands.
2#
3# (c) 2010 Steve Bennett <steveb@workware.net.au>
4#
5# See LICENCE in this directory for licensing.
6
7package require pack
8package require regexp
9
10proc binary {cmd args} {
11	tailcall "binary $cmd" {*}$args
12}
13
14proc "binary format" {formatString args} {
15	set bitoffset 0
16	set result {}
17	# This RE is too unreliable...
18	foreach {conv t u n} [regexp -all -inline {([^[:space:]])(u)?([*0-9]*)} $formatString] {
19		switch -exact -- $t {
20			a -
21			A {
22				set value [binary::nextarg args]
23				set sn [string bytelength $value]
24				if {$n ne "*"} {
25					if {$n eq ""} {
26						set n 1
27					}
28					if {$n > $sn} {
29						# Need to pad the string with spaces or nulls
30						append value [string repeat [dict get {A " " a \x00} $t] $($n - $sn)]
31					}
32				} else {
33					set n $sn
34				}
35				if {$n} {
36					set bitoffset [pack result $value -str $(8 * $n) $bitoffset]
37				}
38			}
39			x {
40				if {$n eq "*"} {
41					return -code error {cannot use "*" in format string with "x"}
42				}
43				if {$n eq ""} {
44					set n 1
45				}
46				loop i 0 $n {
47					set bitoffset [pack result 0 -intbe 8 $bitoffset]
48				}
49			}
50			@ {
51				if {$n eq ""} {
52					return -code error {missing count for "@" field specifier}
53				}
54				if {$n eq "*"} {
55					set bitoffset $(8 * [string bytelength $result])
56				} else {
57					# May need to pad it out
58					set max [string bytelength $result]
59					append result [string repeat \x00 $($n - $max)]
60					set bitoffset $(8 * $n)
61				}
62			}
63			X {
64				if {$n eq "*"} {
65					set bitoffset 0
66				} elseif {$n eq ""} {
67					incr bitoffset -8
68				} else {
69					incr bitoffset $($n * -8)
70				}
71				if {$bitoffset < 0} {
72					set bitoffset 0
73				}
74			}
75			default {
76				if {![info exists ::binary::scalarinfo($t)]} {
77					return -code error "bad field specifier \"$t\""
78				}
79
80				# A scalar (integer or float) type
81				lassign $::binary::scalarinfo($t) type convtype size prefix
82				set value [binary::nextarg args]
83
84				if {$type in {bin hex}} {
85					set value [split $value {}]
86				}
87				set vn [llength $value]
88				if {$n eq "*"} {
89					set n $vn
90				} elseif {$n eq ""} {
91					set n 1
92					set value [list $value]
93				} elseif {$vn < $n} {
94					if {$type in {bin hex}} {
95						# Need to pad the list with zeros
96						lappend value {*}[lrepeat $($n - $vn) 0]
97					} else {
98						return -code error "number of elements in list does not match count"
99					}
100				} elseif {$vn > $n} {
101					# Need to truncate the list
102					set value [lrange $value 0 $n-1]
103				}
104
105				set convtype -$::binary::convtype($convtype)
106
107				foreach v $value {
108					set bitoffset [pack result $prefix$v $convtype $size $bitoffset]
109				}
110				# Now pad out with zeros to the end of the current byte
111				if {$bitoffset % 8} {
112					set bitoffset [pack result 0 $convtype $(8 - $bitoffset % 8) $bitoffset]
113				}
114			}
115		}
116	}
117	return $result
118}
119
120proc "binary scan" {value formatString {args varName}} {
121	# Pops the next arg from the front of the list and returns it.
122	# Throws an error if no more args
123	set bitoffset 0
124	set count 0
125	# This RE is too unreliable...
126	foreach {conv t u n} [regexp -all -inline {([^[:space:]])(u)?([*0-9]*)} $formatString] {
127		set rembytes $([string bytelength $value] - $bitoffset / 8)
128		switch -exact -- $t {
129			a -
130			A {
131				if {$n eq "*"} {
132					set n $rembytes
133				} elseif {$n eq ""} {
134					set n 1
135				}
136				if {$n > $rembytes} {
137					break
138				}
139
140				set var [binary::nextarg varName]
141
142				set result [unpack $value -str $bitoffset $($n * 8)]
143				incr bitoffset $([string bytelength $result] * 8)
144				if {$t eq "A"} {
145					set result [string trimright $result]
146				}
147			}
148			x {
149				# Skip bytes
150				if {$n eq "*"} {
151					set n $rembytes
152				} elseif {$n eq ""} {
153					set n 1
154				}
155				if {$n > $rembytes} {
156					set n $rembytes
157				}
158				incr bitoffset $($n * 8)
159				continue
160			}
161			X {
162				# Back up bytes
163				if {$n eq "*"} {
164					set bitoffset 0
165					continue
166				}
167				if {$n eq ""} {
168					set n 1
169				}
170				if {$n * 8 > $bitoffset} {
171					set bitoffset 0
172					continue
173				}
174				incr bitoffset -$($n * 8)
175				continue
176			}
177			@ {
178				if {$n eq ""} {
179					return -code error {missing count for "@" field specifier}
180				}
181				if {$n eq "*" || $n > $rembytes + $bitoffset / 8} {
182					incr bitoffset $($rembytes * 8)
183				} elseif {$n < 0} {
184					set bitoffset 0
185				} else {
186					set bitoffset $($n * 8)
187				}
188				continue
189			}
190			default {
191				if {![info exists ::binary::scalarinfo($t)]} {
192					return -code error "bad field specifier \"$t\""
193				}
194				# A scalar (integer or float) type
195				lassign $::binary::scalarinfo($t) type convtype size prefix
196				set var [binary::nextarg varName]
197
198				if {$n eq "*"} {
199					set n $($rembytes * 8 / $size)
200				} else {
201					if {$n eq ""} {
202						set n 1
203					}
204				}
205				if {$n * $size > $rembytes * 8} {
206					break
207				}
208
209				if {$type in {hex bin}} {
210					set u u
211				}
212				set convtype -$u$::binary::convtype($convtype)
213
214				set result {}
215				loop i 0 $n {
216					set v [unpack $value $convtype $bitoffset $size]
217					if {$type in {bin hex}} {
218						append result [lindex {0 1 2 3 4 5 6 7 8 9 a b c d e f} $v]
219					} else {
220						lappend result $v
221					}
222					incr bitoffset $size
223				}
224				# Now skip to the end of the current byte
225				if {$bitoffset % 8} {
226					incr bitoffset $(8 - ($bitoffset % 8))
227				}
228			}
229		}
230		uplevel 1 [list set $var $result]
231		incr count
232	}
233	return $count
234}
235
236# Pops the next arg from the front of the list and returns it.
237# Throws an error if no more args
238proc binary::nextarg {&arglist} {
239	if {[llength $arglist] == 0} {
240		return -level 2 -code error "not enough arguments for all format specifiers"
241	}
242	set arglist [lassign $arglist arg]
243	return $arg
244}
245
246set binary::scalarinfo {
247	c {int be 8}
248	s {int le 16}
249	t {int host 16}
250	S {int be 16}
251	i {int le 32}
252	I {int be 32}
253	n {int host 32}
254	w {int le 64}
255	W {int be 64}
256	m {int host 64}
257	h {hex le 4 0x}
258	H {hex be 4 0x}
259	b {bin le 1}
260	B {bin be 1}
261	r {float fle 32}
262	R {float fbe 32}
263	f {float fhost 32}
264	q {float fle 64}
265	Q {float fbe 64}
266	d {float fhost 64}
267}
268set binary::convtype {
269	be intbe
270	le intle
271	fbe floatbe
272	fle floatle
273}
274if {$::tcl_platform(byteOrder) eq "bigEndian"} {
275	array set binary::convtype {host intbe fhost floatbe}
276} else {
277	array set binary::convtype {host intle fhost floatle}
278}
279