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 foreach {conv t u n
} [regexp -all -inline {([a-zA-Z
@])(u
)?
([*0-9]*)} $formatString] {
19 set value
[binary.nextarg args
]
20 set sn
[string bytelength
$value]
26 # Need to pad the string with spaces or nulls
27 append value
[string repeat
[dict get
{A
" " a
\x00} $t] $($n - $sn)]
33 set bitoffset
[pack result
$value -str $(8 * $n) $bitoffset]
35 } elseif
{[binary.intinfo
$t] ne
""} {
37 lassign
[binary.intinfo
$t] type endian size prefix
38 set value
[binary.nextarg args
]
41 set value
[split $value {}]
43 set vn
[llength $value]
48 set value
[list $value]
51 return -code error "number of elements in list does not match count"
53 # Need to pad the list with zeros
54 lappend value
{*}[lrepeat
$($n - $vn) 0]
57 # Need to truncate the list
58 set value
[lrange $value 0 $n-1]
61 if {$endian eq
"host"} {
62 set endian
$($::tcl_platform(byteOrder
) eq
"bigEndian" ?
"be" : "le")
65 set bitoffset
[pack result
$prefix$v -int$endian $size $bitoffset]
67 # Now pad out with zeros to the end of the current byte
69 set bitoffset
[pack result
0 -int$endian $(8 - $bitoffset % 8) $bitoffset]
71 } elseif
{$t eq
"x"} {
73 return -code error {cannot use
"*" in
format string with
"x"}
79 set bitoffset
[pack result
0 -intbe 8 $bitoffset]
81 } elseif
{$t eq
"@"} {
83 return -code error {missing count
for "@" field specifier
}
86 set bitoffset
$(8 * [string bytelength
$result])
88 # May need to pad it out
89 set max
[string bytelength
$result]
94 set bitoffset
$(8 * $n)
96 } elseif
{$t eq
"X"} {
102 incr bitoffset
$($n * -8)
104 if {$bitoffset < 0} {
108 return -code error "bad field specifier \"$t\""
114 proc "binary scan" {value formatString
{args varName
}} {
115 # Pops the next arg from the front of the list and returns it.
116 # Throws an error if no more args
119 foreach {conv t u n
} [regexp -all -inline {([a-zA-Z
@])(u
)?
([*0-9]*)} $formatString] {
120 set rembytes
$([string bytelength
$value] - $bitoffset / 8)
124 } elseif
{$n eq
""} {
127 if {$n > $rembytes} {
131 set var
[binary.nextarg varName
]
133 set result
[unpack
$value -str $bitoffset $($n * 8)]
134 incr bitoffset
$([string bytelength
$result] * 8)
136 set result
[string trimright
$result]
138 } elseif
{[binary.intinfo
$t] ne
""} {
140 lassign
[binary.intinfo
$t] type endian size prefix
141 set var
[binary.nextarg varName
]
144 set n
$($rembytes * 8 / $size)
150 if {$n * $size > $rembytes * 8} {
154 if {$type ne
"int"} {
157 if {$endian eq
"host"} {
158 set endian
$($::tcl_platform(byteOrder
) eq
"bigEndian" ?
"be" : "le")
163 set v
[unpack
$value -${u
}int
$endian $bitoffset $size]
164 if {$type eq
"int"} {
167 append result
[lindex {0 1 2 3 4 5 6 7 8 9 a b c d e f
} $v]
171 # Now skip to the end of the current byte
172 if {$bitoffset % 8} {
173 incr bitoffset
$(8 - ($bitoffset % 8))
175 } elseif
{$t eq
"x"} {
179 } elseif
{$n eq
""} {
182 if {$n > $rembytes} {
185 incr bitoffset
$($n * 8)
187 } elseif
{$t eq
"X"} {
196 if {$n * 8 > $bitoffset} {
200 incr bitoffset
-$($n * 8)
202 } elseif
{$t eq
"@"} {
204 return -code error {missing count
for "@" field specifier
}
206 if {$n eq
"*" ||
$n > $rembytes + $bitoffset / 8} {
207 incr bitoffset
$($rembytes * 8)
211 set bitoffset
$($n * 8)
215 return -code error "bad field specifier \"$t\""
217 uplevel 1 [list set $var $result]
223 # Pops the next arg from the front of the list and returns it.
224 # Throws an error if no more args
225 proc binary.nextarg
{&arglist
} {
226 if {[llength $arglist] == 0} {
227 return -level 2 -code error "not enough arguments for all format specifiers"
229 set arglist
[lassign
$arglist arg
]
233 proc binary.intinfo
{type
} {
250 if {[exists
info($type)]} {