binary.tcl

# Implements the 'binary scan' and 'binary format' commands.
#
# (c) 2010 Steve Bennett <steveb@workware.net.au>
#
# See LICENCE in this directory for licensing.

package require pack
package require regexp

proc binary {cmd args} {
	tailcall "binary $cmd" {*}$args
}

proc "binary format" {formatString args} {
	set bitoffset 0
	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 "*"} {
				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]
			}
		} 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 {}]
			}
			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"
				} else {
					# Need to pad the list with zeros
					lappend value {*}[lrepeat $($n - $vn) 0]
				}
			} elseif {$vn > $n} {
				# Need to truncate the list
				set value [lrange $value 0 $n-1]
			}

			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 {[binary.floatinfo $t] ne ""} {
			# A floating point type
			lassign [binary.floatinfo $t] endian size
			set value [binary.nextarg args]

			set vn [llength $value]
			if {$n eq "*"} {
				set n $vn
			} elseif {$n eq ""} {
				set n 1
				set value [list $value]
			} elseif {$vn < $n} {
				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]
			}

			if {$endian eq "host"} {
				set endian $($::tcl_platform(byteOrder) eq "bigEndian" ? "be" : "le")
			}
			foreach v $value {
				set bitoffset [pack result $v -float$endian $size $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
				}
				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
}

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
	set bitoffset 0
	set count 0
	# 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 ""} {
					set n 1
				}
			}
			if {$n * $size > $rembytes * 8} {
				break
			}

			if {$type ne "int"} {
				set u u
			}
			if {$endian eq "host"} {
				set endian $($::tcl_platform(byteOrder) eq "bigEndian" ? "be" : "le")
			}

			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]
				}
				incr bitoffset $size
			}
			# Now skip to the end of the current byte
			if {$bitoffset % 8} {
				incr bitoffset $(8 - ($bitoffset % 8))
			}
		} elseif {[binary.floatinfo $t] ne ""} {
			# An integer type
			lassign [binary.floatinfo $t] endian size
			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 {$endian eq "host"} {
				set endian $($::tcl_platform(byteOrder) eq "bigEndian" ? "be" : "le")
			}

			set result {}
			loop i 0 $n {
				set v [unpack $value -float$endian $bitoffset $size]
				lappend result $v
				incr bitoffset $size
			}
		} 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
				continue
			}
			if {$n eq ""} {
				set n 1
			}
			if {$n * 8 > $bitoffset} {
				set bitoffset 0
				continue
			}
			incr bitoffset -$($n * 8)
			continue
		} elseif {$t eq "@"} {
			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
		} else {
			return -code error "bad field specifier \"$t\""
		}
		uplevel 1 [list set $var $result]
		incr count
	}
	return $count
}

# Pops the next arg from the front of the list and returns it.
# Throws an error if no more args
proc binary.nextarg {&arglist} {
	if {[llength $arglist] == 0} {
		return -level 2 -code error "not enough arguments for all format specifiers"
	}
	set arglist [lassign $arglist arg]
	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 ""
}

proc binary.floatinfo {type} {
	set info {
		r {le 32}
		R {be 32}
		f {host 32}
		q {le 64}
		Q {be 64}
		d {host 64}
	}
	if {[exists info($type)]} {
		return $info($type)
	}
	return ""
}