CMcC 20040925
I've written a compiler from unix magic(5) files to pure tcl.
The idea is you generate a script which should perform precisely the same function as the unix file command (it gives you information about a file)
This code isn't complete, but handles most common cases. You'll find that a lot of the magic files out there are buggy, too.
magiccompile.tcl:
# file to parse the magic file from magic(5) into a tcl program
package require fileutil
source magiclib.tcl
namespace eval magic {}
# parse an individual line
proc magic::parseline {line {maxlevel 10000}} {
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"
}
set parse [regexp -expanded -inline {^(\S+)\s+(\S+)\s*((\S|(\B\s))*)\s*(.*)$} $unlevel]
if {$parse == {}} {
error "Can't parse: '$unlevel'"
}
set value ""
set command ""
foreach {junk offset type value junk1 junk2 command} $parse break
if {[string index $value end] eq "\\"} {
append value " "
}
if {[string index $command end] eq "\\"} {
append command " "
}
#set value [subst -nocommands -novariables $value]
#set command [subst -nocommands -novariables $command]
if {$value == ""} {
error "no value"
}
#puts "level:$level offset:$offset type:$type value:'$value' command:'$command'"
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
} else {
# parse line
if {[catch {parseline $line $maxlevel} parsed]} {
continue
}
# got a valid line
foreach {level offset type value message} $parsed break
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 {
set value ""
}
default {
set compare "=="
if {[string match {\\[<!>=]*} $value]} {
set value [string range $value 1 end]
}
}
}
set qual ""
switch -glob -- $type {
pstring* -
string* {
set type [split $type /]
set qual [lindex $type 1]
set type [lindex $type 0]
if {$type eq "pstring"} {
append qual "p"
set type "string"
}
set value [string map [list "\#" "\\\#"] $value]
if {($value eq "\\0") && ($compare eq ">")} {
set value ""
set compare x
} elseif {$compare eq "!="} {
set value !$value
set compare "=="
}
if {$type ne "string"} {
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* {
# break up the type
set type [split $type &]
set qual [lindex $type 1]
if {$qual ne ""} {
set qual &$qual
} else {
set type [split $type -]
set qual [lindex $type 1]
if {$qual ne ""} {
set qual -$qual
}
}
set type [lindex $type 0]
if {$compare ne "x"} {
set value [string trimright $value L] ;# redundant Long
if {[catch {set value [expr $value]} x eo]} {
puts stderr "Reject Value Error: ${file}:$linenum '$value' '$line' - $eo"
continue;
}
set value [format "0x%x" $value]
}
}
default {
puts stderr "Reject Unknown Type: ${file}:$linenum $type - $line"
continue
}
}
}
# collect some summaries
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'"
set message [string map [list "\#" "\\\#"] $message]
set record [list $type $qual $compare $offset $value $message]
if {$script == {}} {
set level 0
}
if {$level == 0} {
lappend script $record
} else {
# find the growing edge
set depth [lrepeat [expr $level] end]
while {[catch {
set insertion [lindex $script {expand}$depth]
}]} {
set depth [lreplace $depth end end]
}
#puts stderr "PRE: $depth - $script - $insertion"
lappend insertion $record
lset script {expand}$depth $insertion
#puts stderr "POST: $script"
}
}
#puts "Script: $script"
return $script
}
# generate code for the alternative tests
proc magic::run_else {type qual comp offset val message args} {
set result ""
if {[string match "(*)" $offset]} {
set offset "\[magic::offset $offset\]"
}
switch -glob -- $type {
*byte* -
*short* -
*long* -
*date* {
set type [list Numeric $type]
}
*string {
set type String
}
}
append result "if \{\[magic::$type $offset $comp [list $val] $qual\]\} \{" \n
append result "\tmagic::emit [list $message]" \n
if {[llength $args]} {
append result [run_c {expand}$args] \n
}
append result "\} else"
return $result
}
# generate code for the next level tests
proc magic::run_c {args} {
set result ""
foreach el $args {
append result [run_else {expand}$el]
}
if {[llength $args] != 0} {
append result " \{\}" \n
}
return $result
}
# generate code for each of a series of tests
proc magic::run_el {type qual comp offset val message args} {
set result ""
if {[string match "(*)" $offset]} {
set offset "\[magic::offset $offset\]"
}
switch -glob -- $type {
*byte* -
*short* -
*long* -
*date* {
set type [list numeric $type]
}
}
append result "if \{\[magic::$type $offset $comp [list $val] $qual\]\} \{" \n
append result "\tmagic::emit [list $message]" \n
append result [run_c {expand}$args]
append result "return \[magic::result\]" \n
append result "\}" \n
return $result
}
# generate code for a magic file's tests
proc magic::run {script} {
set result ""
foreach el $script {
append result [run_el {expand}$el]
}
return $result
}
# compile up magic files or directories of magic files
proc magic::compile {args} {
set tcl ""
foreach arg $args {
if {[file type $arg] == "directory"} {
foreach file [glob [file join $arg *]] {
set script1 [process $file]
append tcl "magic::file_start $file" \n
append tcl [run $script1] \n
}
} else {
set script1 [process $arg]
append tcl "magic::file_start $arg" \n
append tcl [run $script1] \n
}
}
return $tcl
}
proc magic::install {args} {
foreach arg $args {
proc magic::/[file tail $arg] {} [magic::compile $arg]
}
}
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 {expand}$argv]
magic::generate {expand}$argvmagiclib.tcl
namespace eval magic {}
set magic::debug 0
# open the file to be scanned
proc magic::open {file} {
variable fd
set fd [::open $file]
fconfigure $fd -translation binary
# clear the fetch cache
variable cache
unset cache
}
# mark the start of a magic file
proc magic::file_start {name} {
variable debug
if {$debug} {
puts stderr "File: $name"
}
}
# return the emitted result
proc magic::result {} {
variable result
return $result
}
# emit a message
proc magic::emit {msg} {
variable string
variable numeric
set msg [::string map [list \\b "" %s $string %d $numeric] $msg]
variable result
append result $msg
return 0
}
# handle complex offsets - TODO
proc magic::offset {where} {
variable debug
#if {$debug} {
puts stderr "OFFSET: $where"
#}
return 0
}
#
proc magic::fetch {where what} {
variable cache
if {![info exists cache($where,$what)]} {
variable fd
seek $fd $where
set cache($where,$what) [read $fd $what]
}
return $cache($where,$what)
}
# maps magic typenames to field characteristics
array set magic::typemap {
byte {1 -1 c}
ubyte {1 0xff c}
short {2 -1 S}
ushort {2 0xffff S}
beshort {2 -1 S}
leshort {2 -1 s}
ubeshort {2 0xffff S}
uleshort {2 0xffff s}
long {4 -1 I}
belong {4 -1 I}
lelong {4 -1 i}
ubelong {4 0xffffffff I}
ulelong {4 0xffffffff i}
}
proc magic::Numeric {type offset comp val {qual ""}} {
variable typemap
variable numeric
foreach {size mask scan} $typemap($type) break
set numeric [fetch $offset $size]
if {[::string bytelength $numeric] == 0} {
return 0
}
if {$comp == "x"} {
# anything matches - don't care
binary scan $numeric $scan numeric
return 1
}
set val [binary format $scan $val]
binary scan $numeric $scan numeric
binary scan $val $scan val
if {$qual != ""} {
set numeric [expr $numeric $qual]
}
set c [expr $val $comp $numeric]
variable debug
if {$debug} {
puts stderr "numeric $type: $val $comp $numeric / $qual - $c"
}
return $c
}
proc magic::String {offset comp val {qual ""}} {
variable fd
variable string
set val [subst -nocommands -novariables $val]
seek $fd $offset
if {$comp eq "x"} {
# anything matches - don't care
set string ""
while {([::string length $string] < 100)
&& ![::string is space [set c [read $fd 1]]]} {
append string $c
}
return 1
}
set string [read $fd [::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
}