Updated 2013-12-01 02:30:06 by AMG

fields implements a simple minded packing and unpacking of arrays and lists into [binary] strings, given a field spec.

The idea is that, while binary gives one facility with binary strings, and lets one implement binary packed data structures, it is unwieldy and error-prone - mainly because the format of each field and its name are not associated by the binary command.

This bit of code allows one to come up with a simple-minded record specification which associates fields' names and specification.

escargo 13 Jan 2006 - Note that this code uses {*} without using package require to specify Tcl 8.5 or later....
   # binary fields packing and unpacking
   # a field specification looks like this:
   # fieldname {type ?count? ?endian?} ...
   
   namespace eval fields {
       variable endianness ""
       variable cache
   }
   
   proc fields::2form {spec array {endian ""}} {
       variable cache
   
       variable endianness
       if {$endian == ""} {
           set endian $endianness
       }
   
       if {[info exists cache($endian,$array,$spec)]} {
           return $cache($endian,$array,$spec)
       }
   
       set form ""
       set vars {}
       foreach {name qual} $spec {
           foreach {type count fendian extra} $qual break
           set t [string index $type 0]
           
           if {$fendian == ""} {
               set fendian [string tolower [string index $endian 0]]
           } else {
               set fendian [string tolower [string index $fendian 0]]
           }
           
           # special forms skip n, back n, jump n
           if {$name == "skip" && [string is integer $type]} {
               set count $type
               set type "x"
           } elseif {$name == "back" && [string is integer $type]} {
               set count $type
               set type "X"
           } elseif {$name == "jump" && [string is integer $type]} {
               set count $type
               set type "@"
           }
           
           if {$fendian == "h" || $fendian == "b"} {
               set ty [string toupper $t]
           } elseif {$fendian == "l"} {
               set ty [string tolower $t]
           }
           
           switch [string tolower $t] {
               a {
                   # ascii - char string of $count
                   # Ascii - pad with " "
               }
               
               b {
                   # bits - low2high
                   # Bits - high2low
               }
               
               c {
                   # char - 8 bit integer values
                   set ty [string tolower $t]
               }
               
               h {
                   # hex low2high
                   # Hex high2low
               }
               
               i {
                   # integer - 32bits low2high
                   # Integer - 32bits high2low
               }
               
               s {
                   # short - 16bits low2high
                   # Short - 16bits high2low
               }
               
               w {
                   # wide-integer - 64bits low2high
                   # Wide-integer - 64bits high2low
               }
               
               f {
                   # float
                   set ty $t        ;# don't play with endianness
               }
   
               d {
                   # double
                   set ty $t        ;# don't play with endianness
               }
               
               @ {
                   # skip to absolute location
                   set name ""
               }
               
               x {
                   # x - move relative forward
                   # X - move relative back
                   set ty $t        ;# don't play with endianness
                   set name ""
               }
           }
   
           if {$name != ""} {
               append outvars "$array\($name\) "
               append invars "\$$array\($name\) "
           }
           
           append form $ty$count
       }
   
       set cache($endian,$array,$spec) [list $form $outvars $invars]
       return $cache($endian,$array,$spec)
   }
   
   # pack the fields contained in array into a binary string according to spec
   proc ::fields::pack {spec array {endian ""}} {
       upvar $array Record
       foreach {form out in} [::fields::2form $spec Record $endian] break
       #puts stderr "pack: binary format $form $in"
       return [eval binary format [list $form] {*}$in]
   }
   
   # pack the fields from $packed contained into array according to spec
   proc ::fields::unpack {packed spec array {endian ""}} {
       upvar $array Record
       foreach {form out in} [::fields::2form $spec Record $endian] break
       #puts stderr "unpack: binary scan $form $out"
       return [binary scan $packed [list $form] {*}$out]
   }
   
   # binary scan the fields from $packed according to spec
   proc ::fields::scan {spec packed {endian ""}} {
       ::fields::unpack $packed $spec Record $endian
       foreach {form out in} [::fields::2form $spec Record $endian] break
       set result {}
       foreach var $out {
           lappend result [set $var]
       }
       return $result
   }
   
   # binary format the args according to spec
   proc ::fields::format {spec endian args} {
       foreach {form out in} [::fields::2form $spec Record $endian] break
       set result {}
       foreach var $out arg $args {
           set $var $arg
       }
       return [::fields::pack $form Record $endian]
   }
   
   if {$argv0 == [info script]} {
       puts stderr "fields test(s)"
   
       # spec is a record specifier
       set spec {
           fred integer
           wilma short
           pebbles {hex 4}
           barney {ascii 10}
           betty double
       }
   
       # record is an instance of a record
       array set record {
           fred 123
           wilma 456
           pebbles feaf
           barney "woo"
           betty 12.345
           
       }
   
       # pack record according to spec
       set packed [::fields::pack $spec record bigendian]
   
       # unpack $packed into record1 according to spec
       ::fields::unpack $packed $spec record1 bigendian
   
       # compare record and record1
       foreach {field val} [array get record1] {
           if {$record($field) != $val} {
               puts "$field: $record($field) != $val"
           }
       }
   }