cgen.tcl

Go to the documentation of this file.

/*  cgen.tcl --*/
/* */
/*  Generator core for compiler of magic(5) files into recognizers*/
/*  based on the 'rtcore'.*/
/* */
/*  Copyright (c) 2004-2005 Colin McCormack <coldstore@users.sourceforge.net>*/
/*  Copyright (c) 2005      Andreas Kupries <andreas_kupries@users.sourceforge.net>*/
/* */
/*  See the file "license.terms" for information on usage and redistribution*/
/*  of this file, and for a DISCLAIMER OF ALL WARRANTIES.*/
/*  */
/*  RCS: @(#) $Id: cgen.tcl,v 1.7 2007/06/23 03:39:34 andreas_kupries Exp $*/

/* */
/* */
/*  "mime type recognition in pure tcl"*/
/*  http://wiki.tcl.tk/12526*/
/* */
/*  Tcl code harvested on:  10 Feb 2005, 04:06 GMT*/
/*  Wiki page last updated: ???*/
/* */
/* */

/*  ### ### ### ######### ######### #########*/
/*  Requirements*/

package require Tcl 8.4
package require fileutil::magic::rt ; /*  Runtime core, for Access to the typemap*/
package require struct::list        ; /*  Our data structures.*/
package require struct::tree        ; /* */

package provide fileutil::magic::cgen 1.0

/*  ### ### ### ######### ######### #########*/
/*  Implementation*/

namespace ::fileutil::magic::cgen {
    /*  Import the runtime typemap into our scope.*/
    variable ::fileutil::magic::rt::typemap

    /*  The tree most operations use for their work.*/
    variable tree {}

    /*  Generator data structure.*/
    variable regions

    /*  Type mapping for indirect offsets.*/
    /*  empty -> long/Q, because this uses native byteorder.*/

    array  otmap =  {
        .b c    .B c
        .s s    .S S
        .l i    .L I
    {} Q
    }

    /*  Export the API*/
    namespace export 2tree treedump treegen
}


/*  Optimisations:*/

/*  reorder tests according to expected or observed frequency this*/
/*  conflicts with reduction in strength optimisations.*/

/*  Rewriting within a level will require pulling apart the list of*/
/*  tests at that level and reordering them.  There is an inconsistency*/
/*  between handling at 0-level and deeper level - this has to be*/
/*  removed or justified.*/

/*  Hypothetically, every test at the same level should be mutually*/
/*  exclusive, but this is not given, and should be detected.  If true,*/
/*  this allows reduction in strength to switch on Numeric tests*/

/*  reduce Numeric tests at the same level to switches*/
/* */
/*  - first pass through clauses at same level to categorise as*/
/*    variant values over same test (type and offset).*/

/*  work out some way to cache String comparisons*/

/*  Reduce seek/reads for String comparisons at same level:*/
/* */
/*  - first pass through clauses at same level to determine string ranges.*/
/* */
/*  - String tests at same level over overlapping ranges can be*/
/*    written as sub-string comparisons over the maximum range*/
/*    this saves re-reading the same string from file.*/
/* */
/*  - common prefix strings will have to be guarded against, by*/
/*    sorting string values, then sorting the tests in reverse length order.*/


ret  ::fileutil::magic::cgen::path (type tree) {
    # Annotates the tree. In each node we store the path from the root
    # to this node, as list of nodes, with the current node the last
    # element. The root node is never stored in the path.

    $tree set root path {}
    foreach child [$tree children root] {
    $tree walk $child -type dfs node {
        set path [$tree get [$tree parent $node] path]
        lappend path [$tree index $node]
        $tree set $node path $path
    }
    }
    return
}

ret  ::fileutil::magic::cgen::tree_el (type tree , type parent , type file , type line , type type , type qual , type comp , type offset , type val , type message , type args) {

    # Recursively creates and annotates a node for the specified
    # tests, and its sub-tests (args).

    set     node [$tree insert $parent end]
    set     path [$tree get    $parent path]
    lappend path [$tree index  $node]
    $tree set $node path $path

    # generate a proc call type for the type, Numeric or String
    variable ::fileutil::magic::rt::typemap

    switch -glob -- $type {
    *byte* -
    *short* -
    *long* -
    *date* {
        set otype N
        set type [lindex $typemap($type) 1]
    }
    *string {
        set otype S
    }
    default {
        puts stderr "Unknown type: '$type'"
    }
    }

    # Stores the type determined above, and the arguments into
    # attributes of the new node.

    foreach key {line type qual comp offset val message file otype} {
    if {[catch {
        $tree set $node $key [set $key]
    } result]} {
        upvar ::errorInfo eo
        puts "Tree: $eo - $file $line $type"
    }
    }

    # now add children
    foreach el $args {
    eval [linsert $el 0 tree_el $tree $node $file]
    # 8.5 # tree_el $tree $node $file {*}$el
    }
    return $node
}

ret  ::fileutil::magic::cgen::2tree (type script) {

    # Converts a recognizer which is in a simple script form into a
    # tree.

    variable tree
    set tree [::struct::tree]

    $tree set root path ""
    $tree set root otype Root
    $tree set root type root
    $tree set root message "unknown"

    # generate a test for each match
    set file "unknown"
    foreach el $script {
    #puts "EL: $el"
    if {[lindex $el 0] eq "file"} {
        set file [lindex $el 1]
    } else {
        set node [eval [linsert $el 0 tree_el $tree root $file]]
        # 8.5 # set more [tree_el $tree root $file {*}$el]
        append result $node
    }
    }
    optNum $tree root
    #optStr $tree root
    puts stderr "Script contains [llength [$tree children root]] discriminators"
    path $tree

    # Decoding the offsets, determination if we have to handle
    # relative offsets, and where. The less, the better.
    Offsets $tree

    return $tree
}

ret  ::fileutil::magic::cgen::isStr (type tree , type node) {
    return [expr {"S" eq [$tree get $node otype]}]
}

ret  ::fileutil::magic::cgen::sortRegion (type r1 , type r2) {
    set cmp 0
    if {[catch {
    if {[string match (*) $r1] || [string match (*) $r2]} {
        set cmp [string compare $r1 $r2]
    } else {
        set cmp [expr {[lindex $r1 0] - [lindex $r2 0]}]
        if {!$cmp} {
        set cmp 0
        set cmp [expr {[lindex $r1 1] - [lindex $r2 1]}]
        }
    }
    } result]} {
    set cmp [string compare $r1 $r2]
    }
    return $cmp
}

ret  ::fileutil::magic::cgen::optStr (type tree , type node) {
    variable regions
    catch {unset regions}
    array set regions {}

    optStr1 $tree $node

    puts stderr "Regions [array statistics regions]"
    foreach region [lsort \
        -index   0 \
        -command ::fileutil::magic::cgen::sortRegion \
        [array name regions]] {
    puts "$region - $regions($region)"
    }
}

ret  ::fileutil::magic::cgen::optStr1 (type tree , type node) {
    variable regions

    # traverse each numeric element of this node's children,
    # categorising them

    set kids [$tree children $node]
    foreach child $kids {
    optStr1 $tree $child
    }

    set strings [$tree children $node filter ::fileutil::magic::cgen::isStr]
    #puts stderr "optstr: $node: $strings"

    foreach el $strings {
    #if {[$tree get $el otype] eq "String"} {puts "[$tree getall $el] - [string length [$tree get $el val]]"}
    if {[$tree get $el comp] eq "x"} {
        continue
    }

    set offset [$tree get $el offset]
    set len    [string length [$tree get $el val]]
    lappend regions([list $offset $len]) $el
    }
}

ret  ::fileutil::magic::cgen::isNum (type tree , type node) {
    return [expr {"N" eq [$tree get $node otype]}]
}

ret  ::fileutil::magic::cgen::switchNSort (type tree , type n1 , type n2) {
    return [expr {[$tree get $n1 val] - [$tree get $n1 val]}]
}

ret  ::fileutil::magic::cgen::optNum (type tree , type node) {
    array set offsets {}

    # traverse each numeric element of this node's children,
    # categorising them

    set kids [$tree children $node]
    foreach child $kids {
    optNum $tree $child
    }

    set numerics [$tree children $node filter ::fileutil::magic::cgen::isNum]
    #puts stderr "optNum: $node: $numerics"
    if {[llength $numerics] < 2} {
    return
    }

    foreach el $numerics {
    if {[$tree get $el comp] ne "=="} {
        continue
    }
    lappend offsets([$tree get $el type],[$tree get $el offset],[$tree get $el qual]) $el
    }

    #puts "Offset: stderr [array get offsets]"
    foreach {match nodes} [array get offsets] {
    if {[llength $nodes] < 2} {
        continue
    }

    catch {unset matcher}
    foreach n $nodes {
        set nv [expr [$tree get $n val]]
        if {[info exists matcher($nv)]} {
        puts stderr "*====================================="
        puts stderr "* Node         <[$tree getall $n]>"
        puts stderr "* clashes with <[$tree getall $matcher($nv)]>"
        puts stderr "*====================================="
        } else {
        set matcher($nv) $n
        }
    }

    foreach {type offset qual} [split $match ,] break
    set switch [$tree insert $node [$tree index [lindex $nodes 0]]]
    $tree set $switch otype   Switch
    $tree set $switch message $match
    $tree set $switch offset  $offset
    $tree set $switch type    $type
    $tree set $switch qual    $qual

    set nodes [lsort -command [list ::fileutil::magic::cgen::switchNSort $tree] $nodes]

    eval [linsert $nodes 0 $tree move $switch end]
    # 8.5 # $tree move $switch end {*}$nodes
    set     path [$tree get [$tree parent $switch] path]
    lappend path [$tree index $switch]
    $tree set $switch path $path
    }
}

ret  ::fileutil::magic::cgen::Offsets (type tree) {

    # Indicator if a node has to save field location information for
    # relative addressing. The 'kill' attribute is an accumulated
    # 'save' over the whole subtree. It will be used to determine when
    # level information was destroyed by subnodes and has to be
    # regenerated at the current level.

    $tree walk root -type dfs node {
    $tree set $node save 0
    $tree set $node kill 0
    }

    # We walk from the leafs up to the root, synthesizing the data
    # needed, as we go.
    $tree walk root -type dfs -order post node {
    if {$node eq "root"} continue
    DecodeOffset $tree $node [$tree get $node offset]

    # If the current node's parent is a switch, and the node has
    # to save, then the switch has to save. Because the current
    # node is not relevant during code generation anymore, the
    # switch is.

    if {[$tree get $node save]} {
        # We save, therefore we kill.
        $tree set $node kill 1
        if {[$tree get [$tree parent $node] otype] eq "Switch"} {
        $tree set [$tree parent $node] save 1
        }
    } else {
        # We don't save i.e. kill, but we may inherit it from
        # children which kill.

        foreach c [$tree children $node] {
        if {[$tree get $c kill]} {
            $tree set $node kill 1
            break
        }
        }
    }
    }
}

ret  ::fileutil::magic::cgen::DecodeOffset (type tree , type node , type offset) {
    if {[string match "(*)" $offset]} {
    # Indirection offset. (Decoding is non-trivial, therefore
    # packed into a proc).

    set ind 1 ; # Indirect location
    foreach {rel base itype idelta} [DecodeIndirectOffset $offset] break

    } elseif {[string match "&*" $offset]} {
    # Direct relative offset. (Decoding is trivial)

    set ind    0       ; # Direct location
    set rel    1       ; # Relative
    set base   [string range $offset 1 end] ; # Base Delta
    set itype  {}      ; # No data for indirect
    set idelta {}      ; # s.a.

    } else {
    set ind    0       ; # Direct location
    set rel    0       ; # Absolute
    set base   $offset ; # Here!
    set itype  {}      ; # No data for indirect
    set idelta {}      ; # s.a.
    }

    # Store the expanded data back into the tree.

    foreach v {ind rel base itype idelta} {
    $tree set $node $v [set $v]
    }

    # For nodes with adressing relative to last field above the latter
    # has to save this information.

    if {$rel} {
    $tree set [$tree parent $node] save 1
    }
    return
}

ret  ::fileutil::magic::cgen::DecodeIndirectOffset (type offset) {
    variable otmap ; # Offset typemap.

    # Offset parser.
    # Syntax:
    #   ( ?&? number ?.[bslBSL]? ?[+-]? ?number? )

    set n {(([0-9]+)|(0x[0-9A-Fa-f]+))}
    set o "\\((&?)(${n})((\\.\[bslBSL])?)(\[+-]?)(${n}?)\\)"
    #         |   | ||| ||               |       | |||
    #         1   2 345 67               8       9 012
    #         ^   ^     ^                ^       ^
    #         rel base  type             sign    index
    #
    #                            1   2    3 4 5 6    7 8    9   0 1 2
    set ok [regexp $o $offset -> rel base _ _ _ type _ sign idx _ _ _]

    if {!$ok} {
        return -code error "Bad offset \"$offset\""
    }

    # rel is in {"", &}, map to 0|1
    if {$rel eq ""} {set rel 0} else {set rel 1}

    # base is a number, enforce decimal. Not optional.
    set base [expr $base]

    # Type is in .b .s .l .B .S .L, and "". Map to a regular magic
    # type code.
    set type $otmap($type)

    # sign is in {+,-,""}. Map to -|"" (Becomes sign of index)
    if {$sign eq "+"} {set sign ""}

    # Index is optional number. Enforce decimal, empty is zero. Add in
    # the sign as well for a proper signed index.

    if {$idx eq ""} {set idx 0}
    set idx $sign[expr $idx]

    return [list $rel $base $type $idx]
}

ret  ::fileutil::magic::cgen::treedump (type tree) {
    set result ""
    $tree walk root -type dfs node {
    set path  [$tree get $node path]
    set depth [llength $path]

    append result [string repeat "  " $depth] [list $path] ": " [$tree get $node type]:

    if {[$tree keyexists $node offset]} {
        append result " ,O|[$tree get $node offset]|"

        set x {}
        foreach v {ind rel base itype idelta} {lappend x [$tree get $node $v]}
        append result "=<[join $x !]>"
    }
    if {[$tree keyexists $node qual]} {
        set q [$tree get $node qual]
        if {$q ne ""} {
        append result " ,q/$q/"
        }
    }

    if {[$tree keyexists $node comp]} {
        append result " " C([$tree get $node comp])
    }
    if {[$tree keyexists $node val]} {
        append result " " V([$tree get $node val])
    }

    if {[$tree keyexists $node otype]} {
        append result " " [$tree get $node otype]/[$tree get $node save]
    }

    if {$depth == 1} {
        set msg [$tree get $node message]
        set n $node
        while {($n != {}) && ($msg == "")} {
        set n [lindex [$tree children $n] 0]
        if {$n != {}} {
            set msg [$tree get $n message]
        }
        }
        append result " " ( $msg )
        if {[$tree keyexists $node file]} {
        append result " - " [$tree get $node file]
        }
    }

    #append result " <" [$tree getall $node] >
    append result \n
    }
    return $result
}

ret  ::fileutil::magic::cgen::treegen (type tree , type node) {
    return "[treegen1 $tree $node]\nresult\n"
}

ret  ::fileutil::magic::cgen::treegen1 (type tree , type node) {
    variable ::fileutil::magic::rt::typemap

    set result ""
    foreach k {otype type offset comp val qual message save path} {
    if {[$tree keyexists $node $k]} {
        set $k [$tree get $node $k]
    }
    }

    set level [llength $path]

    # Generate code for each node per its type.

    switch $otype {
    N -
    S {
        if {$save} {
        # We have to save field data for relative adressing under this
        # leaf.
        if {$otype eq "N"} {
            set type [list Nx $level $type]
        } elseif {$otype eq "S"} {
            set type [list Sx $level]
        }
        } else {
        # Regular fetching of information.
        if {$otype eq "N"} {
            set type [list N $type]
        } elseif {$otype eq "S"} {
            set type S
        }
        }

        set offset [GenerateOffset $tree $node]

        if {$qual eq ""} {
        append result "if \{\[$type $offset $comp [list $val]\]\} \{"
        } else {
        append result "if \{\[$type $offset $comp [list $val] $qual\]\} \{"
        }

        if {[$tree isleaf $node]} {
        if {$message ne ""} {
            append result "emit [list $message]"
        } else {
            append result "emit [$tree get $node path]"
        }
        } else {
        # If we saved data the child branches may destroy
        # level information. We regenerate it if needed.

        if {$message ne ""} {
            append result "emit [list $message]\n"
        }

        set killed 0
        foreach child [$tree children $node] {
            if {$save && $killed && [$tree get $child rel]} {
            # This location already does not regenerate if
            # the killing subnode was last. We also do not
            # need to regenerate if the current subnode
            # does not use relative adressing.
            append result "L $level;"
            set killed 0
            }
            append result [treegen1 $tree $child]
            set killed [expr {$killed || [$tree get $child kill]}]
        }
        #append result "\nreturn \$result"
        }

        append result "\}\n"
    }
    Root {
        foreach child [$tree children $node] {
        append result [treegen1 $tree $child]
        }
    }
    Switch {
        set offset [GenerateOffset $tree $node]

        if {$save} {
        set fetch "Nvx $level"
        } else {
        set fetch Nv
        }

        append fetch " " $type " " $offset
        if {$qual ne ""} {
        append fetch " " $qual
        }
        append result "switch -- \[$fetch\] "

        set scan [lindex $typemap($type) 1]

        set ckilled 0
        foreach child [$tree children $node] {
        binary scan [binary format $scan [$tree get $child val]] $scan val
        append result "$val \{"

        if {$save && $ckilled} {
            # This location already does not regenerate if
            # the killing subnode was last. We also do not
            # need to regenerate if the current subnode
            # does not use relative adressing.
            append result "L $level;"
            set ckilled 0
        }

        if {[$tree isleaf $child]} {
            append result "emit [list [$tree get $child message]]"
        } else {
            set killed 0
            append result "emit [list [$tree get $child message]]\n"
            foreach grandchild [$tree children $child] {
            if {$save && $killed && [$tree get $grandchild rel]} {
                # This location already does not regenerate if
                # the killing subnode was last. We also do not
                # need to regenerate if the current subnode
                # does not use relative adressing.
                append result "L $level;"
                set killed 0
            }
            append result [treegen1 $tree $grandchild]
            set killed [expr {$killed || [$tree get $grandchild kill]}]
            }
        }

        set ckilled [expr {$ckilled || [$tree get $child kill]}]
        append result "\} "
        }
        append result "\n"
    }
    }
    return $result
}

proc ::fileutil::magic::cgen::GenerateOffset {tree node} {
    # Examples:
    # direct absolute:     45      -> 45
    # direct relative:    &45      -> [R 45]
    # indirect absolute:  (45.s+1) -> [I 45 s 1]
    # indirect relative: (&45.s+1) -> [I [R 45] s 1]

    foreach v {ind rel base itype idelta} {
    set $v [$tree get $node $v]
    }

    if {$rel} {set base "\[R $base\]"}
    if {$ind} {set base "\[I $base $itype $idelta\]"}
    return $base
}

# ### ### ### ######### ######### #########
## Ready for use.
# EOF