diff options
author | Steve Bennett <steveb@workware.net.au> | 2013-08-11 09:51:01 +1000 |
---|---|---|
committer | Steve Bennett <steveb@workware.net.au> | 2013-08-19 21:15:55 +1000 |
commit | b4cf237e6535cd1e33a83a0635896956853fd32b (patch) | |
tree | 1f6f7612f54fbb1c2c5618d9e3645f6c4ecf8c3f /binary.tcl | |
parent | 74b38b366e17e5075e3a44994c6b2fb95d2f2a03 (diff) | |
download | jimtcl-b4cf237e6535cd1e33a83a0635896956853fd32b.zip jimtcl-b4cf237e6535cd1e33a83a0635896956853fd32b.tar.gz jimtcl-b4cf237e6535cd1e33a83a0635896956853fd32b.tar.bz2 |
Rework binary.tcl in preparation for float support
Signed-off-by: Steve Bennett <steveb@workware.net.au>
Diffstat (limited to 'binary.tcl')
-rw-r--r-- | binary.tcl | 382 |
1 files changed, 198 insertions, 184 deletions
@@ -16,97 +16,102 @@ proc "binary format" {formatString args} { set result {} # This RE is too unreliable... foreach {conv t u n} [regexp -all -inline {([^[:space:]])(u)?([*0-9]*)} $formatString] { - if {$t in {a A}} { - set value [binary.nextarg args] - set sn [string bytelength $value] - if {$n ne "*"} { + switch -exact -- $t { + a - + A { + set value [binary::nextarg args] + set sn [string bytelength $value] + if {$n ne "*"} { + if {$n eq ""} { + set n 1 + } + if {$n > $sn} { + # Need to pad the string with spaces or nulls + append value [string repeat [dict get {A " " a \x00} $t] $($n - $sn)] + } + } else { + set n $sn + } + if {$n} { + set bitoffset [pack result $value -str $(8 * $n) $bitoffset] + } + } + x { + if {$n eq "*"} { + return -code error {cannot use "*" in format string with "x"} + } if {$n eq ""} { set n 1 } - if {$n > $sn} { - # Need to pad the string with spaces or nulls - append value [string repeat [dict get {A " " a \x00} $t] $($n - $sn)] + loop i 0 $n { + set bitoffset [pack result 0 -intbe 8 $bitoffset] } - } else { - set n $sn } - if {$n} { - set bitoffset [pack result $value -str $(8 * $n) $bitoffset] - } - } elseif {[binary.intinfo $t] ne ""} { - # An integer type - lassign [binary.intinfo $t] type endian size prefix - set value [binary.nextarg args] - - if {$type ne "int"} { - set value [split $value {}] + @ { + if {$n eq ""} { + return -code error {missing count for "@" field specifier} + } + if {$n eq "*"} { + set bitoffset $(8 * [string bytelength $result]) + } else { + # May need to pad it out + set max [string bytelength $result] + append result [string repeat \x00 $($n - $max)] + set bitoffset $(8 * $n) + } } - set vn [llength $value] - if {$n eq "*"} { - set n $vn - } elseif {$n eq ""} { - set n 1 - set value [list $value] - } elseif {$vn < $n} { - if {$type eq "int"} { - return -code error "number of elements in list does not match count" + X { + if {$n eq "*"} { + set bitoffset 0 + } elseif {$n eq ""} { + incr bitoffset -8 } else { - # Need to pad the list with zeros - lappend value {*}[lrepeat $($n - $vn) 0] + incr bitoffset $($n * -8) + } + if {$bitoffset < 0} { + set bitoffset 0 } - } elseif {$vn > $n} { - # Need to truncate the list - set value [lrange $value 0 $n-1] } + default { + if {![info exists ::binary::scalarinfo($t)} { + return -code error "bad field specifier \"$t\"" + } - if {$endian eq "host"} { - set endian $($::tcl_platform(byteOrder) eq "bigEndian" ? "be" : "le") - } - foreach v $value { - set bitoffset [pack result $prefix$v -int$endian $size $bitoffset] - } - # Now pad out with zeros to the end of the current byte - if {$bitoffset % 8} { - set bitoffset [pack result 0 -int$endian $(8 - $bitoffset % 8) $bitoffset] - } - } elseif {$t eq "x"} { - if {$n eq "*"} { - return -code error {cannot use "*" in format string with "x"} - } - if {$n eq ""} { - set n 1 - } - loop i 0 $n { - set bitoffset [pack result 0 -intbe 8 $bitoffset] - } - } elseif {$t eq "@"} { - if {$n eq ""} { - return -code error {missing count for "@" field specifier} - } - if {$n eq "*"} { - set bitoffset $(8 * [string bytelength $result]) - } else { - # May need to pad it out - set max [string bytelength $result] - while {$n > $max} { - append result \x00 - incr max + # A scalar type + lassign $::binary::scalarinfo($t) type convtype size prefix + set value [binary::nextarg args] + + if {$type in {bin hex}} { + set value [split $value {}] + } + set vn [llength $value] + if {$n eq "*"} { + set n $vn + } elseif {$n eq ""} { + set n 1 + set value [list $value] + } elseif {$vn < $n} { + if {$type in {bin hex}} { + # Need to pad the list with zeros + lappend value {*}[lrepeat $($n - $vn) 0] + } else { + return -code error "number of elements in list does not match count" + } + } elseif {$vn > $n} { + # Need to truncate the list + set value [lrange $value 0 $n-1] + } + + set convtype -$::binary::convtype($convtype) + + foreach v $value { + set bitoffset [pack result $prefix$v $convtype $size $bitoffset] + } + # Now pad out with zeros to the end of the current byte + if {$bitoffset % 8} { + set bitoffset [pack result 0 $convtype $(8 - $bitoffset % 8) $bitoffset] } - set bitoffset $(8 * $n) - } - } elseif {$t eq "X"} { - if {$n eq "*"} { - set bitoffset 0 - } elseif {$n eq ""} { - incr bitoffset -8 - } else { - incr bitoffset $($n * -8) - } - if {$bitoffset < 0} { - set bitoffset 0 } - } else { - return -code error "bad field specifier \"$t\"" } } return $result @@ -120,101 +125,107 @@ proc "binary scan" {value formatString {args varName}} { # This RE is too unreliable... foreach {conv t u n} [regexp -all -inline {([^[:space:]])(u)?([*0-9]*)} $formatString] { set rembytes $([string bytelength $value] - $bitoffset / 8) - if {$t in {a A}} { - if {$n eq "*"} { - set n $rembytes - } elseif {$n eq ""} { - set n 1 - } - if {$n > $rembytes} { - break - } - - set var [binary.nextarg varName] - - set result [unpack $value -str $bitoffset $($n * 8)] - incr bitoffset $([string bytelength $result] * 8) - if {$t eq "A"} { - set result [string trimright $result] - } - } elseif {[binary.intinfo $t] ne ""} { - # An integer type - lassign [binary.intinfo $t] type endian size prefix - set var [binary.nextarg varName] - - if {$n eq "*"} { - set n $($rembytes * 8 / $size) - } else { - if {$n eq ""} { + switch -exact -- $t { + a - + A { + if {$n eq "*"} { + set n $rembytes + } elseif {$n eq ""} { set n 1 } - } - if {$n * $size > $rembytes * 8} { - break - } + if {$n > $rembytes} { + break + } - if {$type ne "int"} { - set u u - } - if {$endian eq "host"} { - set endian $($::tcl_platform(byteOrder) eq "bigEndian" ? "be" : "le") - } + set var [binary::nextarg varName] - set result {} - loop i 0 $n { - set v [unpack $value -${u}int$endian $bitoffset $size] - if {$type eq "int"} { - lappend result $v - } else { - append result [lindex {0 1 2 3 4 5 6 7 8 9 a b c d e f} $v] + set result [unpack $value -str $bitoffset $($n * 8)] + incr bitoffset $([string bytelength $result] * 8) + if {$t eq "A"} { + set result [string trimright $result] } - incr bitoffset $size } - # Now skip to the end of the current byte - if {$bitoffset % 8} { - incr bitoffset $(8 - ($bitoffset % 8)) - } - } elseif {$t eq "x"} { - # Skip bytes - if {$n eq "*"} { - set n $rembytes - } elseif {$n eq ""} { - set n 1 - } - if {$n > $rembytes} { - set n $rembytes - } - incr bitoffset $($n * 8) - continue - } elseif {$t eq "X"} { - # Back up bytes - if {$n eq "*"} { - set bitoffset 0 + x { + # Skip bytes + if {$n eq "*"} { + set n $rembytes + } elseif {$n eq ""} { + set n 1 + } + if {$n > $rembytes} { + set n $rembytes + } + incr bitoffset $($n * 8) continue } - if {$n eq ""} { - set n 1 - } - if {$n * 8 > $bitoffset} { - set bitoffset 0 + X { + # Back up bytes + if {$n eq "*"} { + set bitoffset 0 + continue + } + if {$n eq ""} { + set n 1 + } + if {$n * 8 > $bitoffset} { + set bitoffset 0 + continue + } + incr bitoffset -$($n * 8) continue } - incr bitoffset -$($n * 8) - continue - } elseif {$t eq "@"} { - if {$n eq ""} { - return -code error {missing count for "@" field specifier} + @ { + if {$n eq ""} { + return -code error {missing count for "@" field specifier} + } + if {$n eq "*" || $n > $rembytes + $bitoffset / 8} { + incr bitoffset $($rembytes * 8) + } elseif {$n < 0} { + set bitoffset 0 + } else { + set bitoffset $($n * 8) + } + continue } - if {$n eq "*" || $n > $rembytes + $bitoffset / 8} { - incr bitoffset $($rembytes * 8) - } elseif {$n < 0} { - set bitoffset 0 - } else { - set bitoffset $($n * 8) + default { + if {![info exists ::binary::scalarinfo($t)} { + return -code error "bad field specifier \"$t\"" + } + # A scalar float type + lassign $::binary::scalarinfo($t) type convtype size prefix + set var [binary::nextarg varName] + + if {$n eq "*"} { + set n $($rembytes * 8 / $size) + } else { + if {$n eq ""} { + set n 1 + } + } + if {$n * $size > $rembytes * 8} { + break + } + + if {$type in {hex bin}} { + set u u + } + set convtype -$u$::binary::convtype($convtype) + + set result {} + loop i 0 $n { + set v [unpack $value $convtype $bitoffset $size] + if {$type in {bin hex}} { + append result [lindex {0 1 2 3 4 5 6 7 8 9 a b c d e f} $v] + } else { + lappend result $v + } + incr bitoffset $size + } + # Now skip to the end of the current byte + if {$bitoffset % 8} { + incr bitoffset $(8 - ($bitoffset % 8)) + } } - continue - } else { - return -code error "bad field specifier \"$t\"" } uplevel 1 [list set $var $result] incr count @@ -224,7 +235,7 @@ proc "binary scan" {value formatString {args varName}} { # Pops the next arg from the front of the list and returns it. # Throws an error if no more args -proc binary.nextarg {&arglist} { +proc binary::nextarg {&arglist} { if {[llength $arglist] == 0} { return -level 2 -code error "not enough arguments for all format specifiers" } @@ -232,25 +243,28 @@ proc binary.nextarg {&arglist} { return $arg } -proc binary.intinfo {type} { - set info { - c {int be 8} - s {int le 16} - t {int host 16} - S {int be 16} - i {int le 32} - I {int be 32} - n {int host 32} - w {int le 64} - W {int be 64} - m {int host 64} - h {hex le 4 0x} - H {hex be 4 0x} - b {bin le 1} - B {bin be 1} - } - if {[exists info($type)]} { - return $info($type) - } - return "" +set binary::scalarinfo { + c {int be 8} + s {int le 16} + t {int host 16} + S {int be 16} + i {int le 32} + I {int be 32} + n {int host 32} + w {int le 64} + W {int be 64} + m {int host 64} + h {hex le 4 0x} + H {hex be 4 0x} + b {bin le 1} + B {bin be 1} +} +set binary::convtype { + be intbe + le intle +} +if {$::tcl_platform(byteOrder) eq "bigEndian"} { + array set binary::convtype {host intbe} +} else { + array set binary::convtype {host intle} } |