1 # Implements the 'binary scan' and 'binary format' commands.
3 # (c) 2010 Steve Bennett <steveb@workware.net.au>
5 # See LICENCE in this directory for licensing.
10 proc binary {cmd args
} {
11 tailcall
"binary $cmd" {*}$args
14 proc "binary format" {formatString args
} {
17 # This RE is too unreliable...
18 foreach {conv t u n
} [regexp -all -inline {([^
[:space
:]])(u
)?
([*0-9]*)} $formatString] {
22 set value
[binary::nextarg args
]
23 set sn
[string bytelength
$value]
29 # Need to pad the string with spaces or nulls
30 append value
[string repeat
[dict get
{A
" " a
\x00} $t] $($n - $sn)]
36 set bitoffset
[pack result
$value -str $(8 * $n) $bitoffset]
41 return -code error {cannot use
"*" in
format string with
"x"}
47 set bitoffset
[pack result
0 -intbe 8 $bitoffset]
52 return -code error {missing count
for "@" field specifier
}
55 set bitoffset
$(8 * [string bytelength
$result])
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)
69 incr bitoffset
$($n * -8)
76 if {![info exists
::binary::scalarinfo($t)]} {
77 return -code error "bad field specifier \"$t\""
80 # A scalar (integer or float) type
81 lassign
$::binary::scalarinfo($t) type convtype size prefix
82 set value
[binary::nextarg args
]
84 if {$type in
{bin hex
}} {
85 set value
[split $value {}]
87 set vn
[llength $value]
92 set value
[list $value]
94 if {$type in
{bin hex
}} {
95 # Need to pad the list with zeros
96 lappend value
{*}[lrepeat
$($n - $vn) 0]
98 return -code error "number of elements in list does not match count"
100 } elseif
{$vn > $n} {
101 # Need to truncate the list
102 set value
[lrange $value 0 $n-1]
105 set convtype
-$::binary::convtype($convtype)
108 set bitoffset
[pack result
$prefix$v $convtype $size $bitoffset]
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]
120 proc "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
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 {
133 } elseif
{$n eq
""} {
136 if {$n > $rembytes} {
140 set var
[binary::nextarg varName
]
142 set result
[unpack
$value -str $bitoffset $($n * 8)]
143 incr bitoffset
$([string bytelength
$result] * 8)
145 set result
[string trimright
$result]
152 } elseif
{$n eq
""} {
155 if {$n > $rembytes} {
158 incr bitoffset
$($n * 8)
170 if {$n * 8 > $bitoffset} {
174 incr bitoffset
-$($n * 8)
179 return -code error {missing count
for "@" field specifier
}
181 if {$n eq
"*" ||
$n > $rembytes + $bitoffset / 8} {
182 incr bitoffset
$($rembytes * 8)
186 set bitoffset
$($n * 8)
191 if {![info exists
::binary::scalarinfo($t)]} {
192 return -code error "bad field specifier \"$t\""
194 # A scalar (integer or float) type
195 lassign
$::binary::scalarinfo($t) type convtype size prefix
196 set var
[binary::nextarg varName
]
199 set n
$($rembytes * 8 / $size)
205 if {$n * $size > $rembytes * 8} {
209 if {$type in
{hex bin
}} {
212 set convtype
-$u$::binary::convtype($convtype)
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]
224 # Now skip to the end of the current byte
225 if {$bitoffset % 8} {
226 incr bitoffset
$(8 - ($bitoffset % 8))
230 uplevel 1 [list set $var $result]
236 # Pops the next arg from the front of the list and returns it.
237 # Throws an error if no more args
238 proc binary::nextarg {&arglist
} {
239 if {[llength $arglist] == 0} {
240 return -level 2 -code error "not enough arguments for all format specifiers"
242 set arglist
[lassign
$arglist arg
]
246 set binary::scalarinfo {
268 set binary::convtype {
274 if {$::tcl_platform(byteOrder
) eq
"bigEndian"} {
275 array set binary::convtype {host intbe fhost floatbe
}
277 array set binary::convtype {host intle fhost floatle
}