# file to compile the magic file from magic(5) into a tcl program
    package require fileutil
    
    source magiclib.tcl
    source magictree.tcl
    
    namespace eval magic {}
    set magic::debug 0
    
    # parse an individual line
    proc magic::parseline {line {maxlevel 10000}} {
    
        # calculate the line's level
        set unlevel [string trimleft $line >]
        set level [expr [string length $line] - [string length $unlevel]]
        if {$level > $maxlevel} {
            return -code continue "Skip - too high a level"
        }
    
        # regexp parse line into (offset, type, value, command)
        set parse [regexp -expanded -inline {^(\S+)\s+(\S+)\s*((\S|(\B\s))*)\s*(.*)$} $unlevel]
        if {$parse == {}} {
            error "Can't parse: '$unlevel'"
        }
    
        # unpack parsed line
        set value ""
        set command ""
        foreach {junk offset type value junk1 junk2 command} $parse break
    
        # handle trailing spaces
        if {[string index $value end] eq "\\"} {
            append value " "
        }
        if {[string index $command end] eq "\\"} {
            append command " "
        }
    
        if {$value == ""} {
            error "no value"        ;# badly formatted line
        }
    
        variable debug
        if {$debug > 1} {
            puts "level:$level offset:$offset type:$type value:'$value' command:'$command'"
        }
    
        # return the line's fields
        return [list $level $offset $type $value $command]
    }
    
    # process a magic file
    proc magic::process {file {maxlevel 10000}} {
        variable level        ;# level of line
        variable linenum        ;# line number
    
        set level 0
        set script {}
    
        set linenum 0
        ::fileutil::foreachLine line $file {
            incr linenum
            set line [string trim $line " "]
            if {[string index $line 0] eq "#"} {
                continue        ;# skip comments
            } elseif {$line == ""} {
                continue        ;# skip blank lines
            } else {
                # parse line
                if {[catch {parseline $line $maxlevel} parsed]} {
                    continue        ;# skip erroring lines
                }
    
                # got a valid line
                foreach {level offset type value message} $parsed break
    
                # strip comparator out of value field,
                # (they are combined)
                set compare [string index $value 0]
                switch -glob --  $value {
                    [<>]=* {
                        set compare [string range $value 0 1]
                        set value [string range $value 2 end]
                    }
    
                    <* -
                    >* -
                    &* -
                    ^* {
                        set value [string range $value 1 end]
                    }
    
                    =* {
                        set compare "=="
                        set value [string range $value 1 end]
                    }
    
                    !* {
                        set compare "!="
                        set value [string range $value 1 end]
                    }
    
                    x {
                        # this is the 'don't care' match
                        # used for collecting values
                        set value ""
                    }
    
                    default {
                        # the default comparator is equals
                        set compare "=="
                        if {[string match {\\[<!>=]*} $value]} {
                            set value [string range $value 1 end]
                        }
                    }
                }
    
                # process type field
                set qual ""
                switch -glob -- $type {
                    pstring* -
                    string* {
                        # String or Pascal string type
    
                        # extract string match qualifiers
                        set type [split $type /]
                        set qual [lindex $type 1]
                        set type [lindex $type 0]
    
                        # convert pstring to string + qualifier
                        if {$type eq "pstring"} {
                            append qual "p"
                            set type "string"
                        }
    
                        # protect hashes in output script value
                        set value [string map [list "\#" "\\#" \" \\\" \{ \\\{ \} \\\}] $value]
    
                        if {($value eq "\\0") && ($compare eq ">")} {
                            # record 'any string' match
                            set value ""
                            set compare x
                        } elseif {$compare eq "!="} {
                            # string doesn't allow !match
                            set value !$value
                            set compare "=="
                        }
    
                        if {$type ne "string"} {
                            # don't let any odd string types sneak in
                            puts stderr "Reject String: ${file}:$linenum $type - $line"
                            continue
                        }
                    }
    
                    regex {
                        # I am *not* going to handle regex
                        puts stderr "Reject Regex: ${file}:$linenum $type - $line"
                        continue
                    }
    
                    *byte* -
                    *short* -
                    *long* -
                    *date* {
                        # Numeric types
    
                        # extract numeric match &qualifiers
                        set type [split $type &]
                        set qual [lindex $type 1]
    
                        if {$qual ne ""} {
                            # this is an &-qualifier
                            set qual &$qual
                        } else {
                            # extract -qualifier from type
                            set type [split $type -]
                            set qual [lindex $type 1]
                            if {$qual ne ""} {
                                set qual -$qual
                            }
                        }
                        set type [lindex $type 0]
    
                        # perform value adjustments
                        if {$compare ne "x"} {
                            # trim redundant Long value qualifier
                            set value [string trimright $value L]
    
                            if {[catch {set value [expr $value]} x eo]} {
                                # check that value is representable in tcl
                                puts stderr "Reject Value Error: ${file}:$linenum '$value' '$line' - $eo"
                                continue;
                            }
    
                            # coerce numeric value into hex
                            set value [format "0x%x" $value]
                        }
                    }
    
                    default {
                        # this is not a type we can handle
                        puts stderr "Reject Unknown Type: ${file}:$linenum $type - $line"
                        continue
                    }
                }
            }
    
            # collect some summaries
            variable debug
            if {$debug} {
                variable types
                set types($type) $type
                variable quals
                set quals($qual) $qual
            }
    
            #puts "$linenum level:$level offset:$offset type:$type qual:$qual compare:$compare value:'$value' message:'$message'"
    
            # protect hashes in output script message
            set message [string map [list "\#" "\\\#" \" \\\" \} \\\} ( \\( ) \\)] $message]
    
            if {![string match "(*)" $offset]} {
                catch {set offset [expr $offset]}
            }
    
            # record is the complete match command,
            # encoded for tcl code generation
            set record [list $linenum $type $qual $compare $offset $value $message]
            if {$script == {}} {
                # the original script has level 0,
                # regardless of what the script says
                set level 0
            }
            
            if {$level == 0} {
                # add a new 0-level record
                lappend script $record
            } else {
                # find the growing edge of the script
                set depth [lrepeat [expr $level] end]
                while {[catch {
                    # get the insertion point
                    set insertion [lindex $script {*}$depth]
                }]} {
                    # handle scripts which jump levels,
                    # reduce depth to current-depth+1
                    set depth [lreplace $depth end end]
                }
    
                # add the record at the insertion point
                lappend insertion $record
    
                # re-insert the record into its correct position
                lset script {*}$depth $insertion
            }
        }
        #puts "Script: $script"
        return $script
    }
    
    proc magic::install {args} {
        foreach arg $args {
            proc magic::/[file tail $arg] {} [magic::compile $arg]
        }
    }
    
    # compile up magic files or directories of magic files
    proc magic::compile {args} {
        set tcl ""
        set script {}
        foreach arg $args {
            if {[file type $arg] == "directory"} {
                foreach file [glob [file join $arg *]] {
                    set script1 [process $file]
                    lappend script [list file $file] {*}$script1
                    #append tcl "magic::file_start $file" \n
                    #append tcl [run $script1] \n
                }
            } else {
                set file $arg
                set script1 [process $file]
                lappend script [list file $file] {*}$script1
                #append tcl "magic::file_start $file" \n
                #append tcl [run $script1] \n
            }
        }
    
        #puts stderr $script
        puts "\# $args"
        set t [2tree $script]
        set tcl [treegen $t root]
        puts [treedump $t]
        #set tcl [run $script]
    
        return $tcl
    }
    
    proc magic::generate {args} {
        foreach arg $args {
            set out [::open [file tail $arg].tcl w]
    
            puts $out "proc magic::/[file tail $arg] {} \{"
            puts $out [magic::compile $arg]
            puts $out "return {}"
            puts $out \}
    
            ::close $out
        }
    }
    
    #puts [magic::compile {*}$argv]
    #puts stderr "typemap: [array get magic::typemap]"
    magic::generate {*}$argv
    
    #set script [magic::compile {} /usr/share/misc/file/magic]
    #puts "\# types:[array names magic::types]"
    #puts "\# quals:[array names magic::quals]"
    #puts "Script: $script"
    
    return

-----
magiclib.tcl:
    # TODO:
    
    # Required Functionality:
    
    # implement full offset language
    # implement pstring (pascal string, blerk)
    # implement regex form (blerk!)
    # implement string qualifiers
    
    # 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.
    
    namespace eval magic {}
    
    set magic::debug 0
    set magic::optimise 1
    
    # open the file to be scanned
    proc magic::open {file} {
        variable fd
        set fd [::open $file]
        fconfigure $fd -translation binary
    
        # fill the string cache
        # the vast majority of magic strings are in the first 4k of the file.
        variable strbuf
        set strbuf [read $fd 4096]
    
        # clear the fetch cache
        variable cache
        catch {unset cache}
    
        variable result
        set result ""
    
        variable string
        set string ""
    
        variable numeric
        set numeric -9999
    
        return $fd
    }
    
    proc magic::close {file} {
        variable fd
        ::close $fd
    }
    
    # mark the start of a magic file in debugging
    proc magic::file_start {name} {
        variable debug
        if {$debug} {
            puts stderr "File: $name"
        }
    }
    
    # return the emitted result
    proc magic::result {{msg ""}} {
        variable result
        if {$msg != ""} {
            emit $msg
        }
        return -code return $result
    }
    
    # emit a message
    proc magic::emit {msg} {
        variable string
        variable numeric
        set msg [::string map [list \\b "" %s $string %ld $numeric %d $numeric] $msg]
    
        variable result
        append result " " $msg
        set result [string trim $result " "]
    }
    
    # handle complex offsets - TODO
    proc magic::offset {where} {
        variable debug
        #if {$debug} {
            puts stderr "OFFSET: $where"
        #}
        return 0
    }
    
    # fetch and cache a value from the file
    proc magic::fetch {where what scan} {
        variable cache
        variable numeric
    
        if {![info exists cache($where,$what,$scan)]} {
            variable fd
            seek $fd $where
            binary scan [read $fd $what] $scan numeric
            set cache($where,$what,$scan) $numeric
        } else {
            set numeric $cache($where,$what,$scan)
        }
        return $numeric
    }
    
    # maps magic typenames to field characteristics: size, binary scan format
    array set magic::typemap {
        byte {1 c}
        ubyte {1 c}
        short {2 S}
        ushort {2 S}
        beshort {2 S}
        leshort {2 s}
        ubeshort {2 S}
        uleshort {2 s}
        long {4 I}
        belong {4 I}
        lelong {4 i}
        ubelong {4 I}
        ulelong {4 i}
        date {2 S}
        bedate {2 S}
        ledate {2 s}
        ldate {4 I}
        beldate {4 I}
        leldate {4 i}
    }
    
    # generate short form names
    foreach {n v} [array get magic::typemap] {
        foreach {len scan} $v {
            #puts stderr "Adding $scan - [list $len $scan]"
            set magic::typemap($scan) [list $len $scan]
            break
        }
    }
    
    proc magic::Nv {type offset {qual ""}} {
        variable typemap
        variable numeric
    
        # unpack the type characteristics
        foreach {size scan} $typemap($type) break
    
        # fetch the numeric field
        set numeric [fetch $offset $size $scan]
    
        if {$qual != ""} {
            # there's a mask to be applied
            set numeric [expr $numeric $qual]
        }
    
        variable debug
        if {$debug} {
            puts stderr "NV $type $offset $qual: $numeric"
        }
    
        return $numeric
    }
    
    # Numeric - get bytes of $type at $offset and $compare to $val
    # qual might be a mask
    proc magic::N {type offset comp val {qual ""}} {
        variable typemap
        variable numeric
    
        # unpack the type characteristics
        foreach {size scan} $typemap($type) break
    
        # fetch the numeric field
        set numeric [fetch $offset $size $scan]
    
        if {$comp == "x"} {
            # anything matches - don't care
            return 1
        }
    
        # get value in binary form, then back to numeric
        # this avoids problems with sign, as both values are
        # [binary scan]-converted identically
        binary scan [binary format $scan $val] $scan val
    
        if {$qual != ""} {
            # there's a mask to be applied
            set numeric [expr $numeric $qual]
        }
    
        set c [expr $val $comp $numeric]        ;# perform comparison
    
        variable debug
        if {$debug} {
            puts stderr "numeric $type: $val $comp $numeric / $qual - $c"
        }
    
        return $c
    }
    
    proc magic::getString {offset len} {
        # cache the first 1k of the file
        variable string
        set end [expr {$offset + $len - 1}]
        if {$end < 4096} {
            # in the string cache
            variable strbuf
            set string [string range $strbuf $offset $end]
        } else {
            # an unusual one
            variable fd
            seek $fd $offset        ;# move to the offset
            set string [read $fd $len]
        }
        return $string
    }
    
    proc magic::S {offset comp val {qual ""}} {
        variable fd
        variable string
    
        # convert any backslashes
        set val [subst -nocommands -novariables $val]
    
        if {$comp eq "x"} {
            # match anything - don't care, just get the value
            set string ""
    
            seek $fd $offset        ;# move to the offset
            while {([::string length $string] < 100)
                   && [::string is print [set c [read $fd 1]]]} {
                if {[string is space $c]} {
                    break
                }
                append string $c
            }
    
            return 1
        }
    
        # get the string and compare it
        set string [getString $offset [::string length $val]]
        set cmp [::string compare $val $string]
        set c  [expr $cmp $comp 0]
    
        variable debug
        if {$debug} {
            puts "String '$val' $comp '$string' - $c"
            if {$c} {
                puts "offset $offset - $string"
            }
        }
    
        return $c
    }
----
magictree.tcl
    package require struct::list
    package require struct::tree
    
    namespace eval magic {}
    
    proc magic::path {tree} {
        $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
            }
        }
    }
    
    proc magic::tree_el {tree parent file line type qual comp offset val message 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 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'"
            }
        }
    
        foreach key {line type qual comp offset val message file otype} {
            if {[catch {
                $tree set $node $key [set $key]
            } result eo]} {
                puts "Tree: $eo - $file $line $type"
            }
        }
    
        # now add children
        foreach el $args {
            tree_el $tree $node $file {*}$el
        }
        return $node
    }
    
    proc magic::2tree {script} {
        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 {
                append result [tree_el $tree root $file {*}$el]
            }
        }
        optNum $tree root
        #optStr $tree root
        puts stderr "Script contains [llength [$tree children root]] discriminators"
        path $tree
        return $tree
    }
    
    proc magic::isStr {tree node} {
        return [expr {"S" eq [$tree get $node otype]}]
    }
    
    proc magic::sortRegion {r1 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 eo]} {
            set cmp [string compare $r1 $r2]
        }
        return $cmp
    }
    
    proc magic::optStr {tree node} {
        variable regions
        catch {unset regions}
        array set regions {}
        optStr1 $tree $node
        puts stderr "Regions [array statistics regions]"
        foreach region [lsort -index 0 -command magic::sortRegion [array name regions]] {
            puts "$region - $regions($region)"
        }
    }
    
    proc magic::optStr1 {tree node} {
        # 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 magic::isStr]
        #puts stderr "optstr: $node: $strings"
    
        variable regions
        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
        }
    }
    
    proc magic::isNum {tree node} {
        return [expr {"N" eq [$tree get $node otype]}]
    }
    
    proc magic::switchNSort {tree n1 n2} {
        return [expr {[$tree get $n1 val] - [$tree get $n1 val]}]
    }
    
    proc magic::optNum {tree node} {
        # 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 magic::isNum]
        #puts stderr "optNum: $node: $numerics"
        if {[llength $numerics] < 2} {
            return
        }
    
        array set offsets {}
        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 "Node <[$tree getall $n]> clashes with <[$tree getall $matcher($nv)]>"
                } 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 magic::switchNSort $tree] $nodes]
    
            $tree move $switch end {*}$nodes
            set path [$tree get [$tree parent $switch] path]
            lappend path [$tree index $switch]
            $tree set $switch path $path
        }
    }
    
    proc magic::treedump {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 ,[$tree get $node offset]
            }
            if {[$tree keyexists $node qual]} {
                set q [$tree get $node qual]
                if {$q ne ""} {
                    append result ,$q
                }
            }
    
            if {[$tree keyexists $node comp]} {
                append result  [$tree get $node comp]
            }
            if {[$tree keyexists $node val]} {
                append result  [$tree get $node val]
            }
    
            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
    }
    
    proc magic::treegen {tree node} {
        return "[treegen1 $tree $node]\nresult\n"
    }
    
    proc magic::treegen1 {tree node} {
        set result ""
        foreach k {otype type offset comp val qual message} {
            if {[$tree keyexists $node $k]} {
                set $k [$tree get $node $k]
            }
        }
    
        if {$otype eq "N"} {
            set type [list N $type]
        } elseif {$otype eq "S"} {
            set type S
        }
    
        switch $otype {
            N -
            S {
                # this is a complex offset - call the offset interpreter
                if {[string match "(*)" $offset]} {
                    set offset "\[offset $offset\]"
                }
    
                append result "if \{\[$type $offset $comp [list $val] $qual\]\} \{"
    
                if {[$tree isleaf $node]} {
                    if {$message != ""} {
                        append result "emit [list $message]"
                    } else {
                        append result "emit [$tree get $node path]"
                    }
                } else {
                    if {$message != ""} {
                        append result "emit [list $message]\n"
                    }
                    foreach child [$tree children $node] {
                        append result [treegen1 $tree $child]
                    }
                    #append result "\nreturn \$result"
                }
    
                append result "\}\n"
            }
    
            Root {
                foreach child [$tree children $node] {
                    append result [treegen1 $tree $child]
                }
            }
    
            Switch {
                # this is a complex offset - call the offset interpreter
                if {[string match "(*)" $offset]} {
                    set offset "\[offset $offset\]"
                }
    
                append result "switch -- \[Nv $type $offset $qual\] "
    
                variable typemap
                set scan [lindex $typemap($type) 1]
                foreach child [$tree children $node] {
                    binary scan [binary format $scan [$tree get $child val]] $scan val
                    append result "$val \{"
    
                    if {[$tree isleaf $child]} {
                        append result "emit [list [$tree get $child message]]"
                    } else {
                        append result "emit [list [$tree get $child message]]\n"
                        foreach grandchild [$tree children $child] {
                            append result [treegen1 $tree $grandchild]
                        }
                    }
                    append result "\} "
                }
                append result "\n"
            }
        }
        return $result
    }
    
    return