Tcl Library Source Code

    variable indir_typemap
    $tree set $node rel 0 ;   # relative
    $tree set $node ind 0 ;   # indirect
    $tree set $node ir 0 ;    # indirect relative
    $tree set $node it {} ;   # indir_type
    $tree set $node ioi 0 ;   # indirect offset invert
    $tree set $node iir 0 ;   # indirect indirect relative 
    $tree set $node ioo + ;   # indirect_offset_op
    $tree set $node io 0 ;    # indirect offset
    advance w1 char
    if {$char eq {&}} {
	advance w1 char
	$tree set $node rel 1
    }

		if {[$tree keyexists $child ext_ext]} {
		    append result "${indent}ext [$tree get $child ext_ext]\n"
		}

		append result ";<\} "
	    }
	    append result "\n"
	}
    }
    return $result
}

proc ::fileutil::magic::cgen::GenerateOffset {tree node} {
    # Examples:

} {0 {}}

test fumagic.filetype-1.5 {test elf executable} {
    set f [makeElfFile]
    set res [catch {fileutil::magic::filetype $f} msg]
    removeElfFile
    list $res $msg
} {0 {{ELF 32-bit LSB executable, (SYSV)} {application x-executable} {}}}

test fumagic.filetype-1.6 {test simple text} {
    set f [makeTextFile]
    set res [catch {fileutil::magic::filetype $f} msg]
    removeTextFile
    list $res $msg
} {0 {}}

test fumagic.filetype-1.24 {ustring} {
    set f [makeXzFile]
    set res [catch {fileutil::magic::filetype $f} msg]
    removeXzFile
    list $res $msg
} {0 {{{XZ compressed data}} {application x-xz} {}}}

test fumagic.filetype-1.25 {
    tests negative relative offsets 
} {
    set f [makePdf2File]
    set res [catch {fileutil::magic::filetype $f} msg]
    removePdf2File
    list $res $msg
} {0 {{{PDF document, version 1.3}} {application pdf} {}}}

test fumagic.filetype-1.26 {
    Tests comparisons against the empty string when a file is malformed or
    missing data at specified offsets.
} {
    set f [makePeFile]
    set res [catch {fileutil::magic::filetype $f} msg]
    removePeFile
    list $res $msg
} {0 {{{MS-DOS executable}} {application x-dosexec} {}}}

test fumagic.filetype-1.27 {
    Tests indirect offsets, as well as the "default" test type. 
} {
    #set f [makePe2File]
    set f /home/yorick/Downloads/KeyFinderInstaller.exe
    set res [catch {fileutil::magic::filetype $f} msg]
    removePe2File
    list $res $msg
} {0 {{{PE32 executable} (GUI) {Intel 80386, for MS Windows}} {application x-dosexec} {}}}

testsuiteCleanup
return

abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
}

# ### ### ### ######### ######### #########
## Creates a series of commands for the creation of small data files
## for various file formats.

set filedata [dict create \
	Empty  {} \
	Bin    "\u0000" \
	Elf    [cat "\x7F" "ELF" "\x01\x01\x01\x00\x00" "\x00\x00\x00\x00\x00\x00\x00" "\x02\x00"] \
	Bzip   "BZh91AY&SY\x01\x01\x01\x00\x00" \
	Gzip   "\x1f\x8b\x01\x01\x01\x00\x00" \
	Jpeg   [cat "\xFF\xD8\xFF\xE0\x00\x10JFIF" "\x00\x01\x02\x01\x01\x2c\x01\x3c"] \
	Jpeg2   [cat "\xFF\xD8\xFF\xE0\x00\x10JFIF" "\x00\x01\x02\x01\x01\x2c\x01\x3c\x80\x70"] \
	Gif    "GIF89a\x2b\x00\x40\x00\xf7\xff\x00" \
	Png    "\x89PNG\x0D\x0A\x1A\x0A" \
	PngMalformed "\x89PNG\x00\x01\x02\x01\x01\x2c" \
	Tiff   "MM\x00\*\x00\x01\x02\x01\x01\x2c" \
	Pdf    "%PDF-1.2 \x00\x01\x02\x01\x01\x2c" \
	Pdf2   {%PDF-1.3 %âãÏÓ
25 0 obj <<  /Linearized 1  /O 29  /H [ 1948 443 ]  /L 64573  /E 41907  /N 3  /T 63955  >>  endobj                                                           xref 25 67  0000000016 00000 n
0000001687 00000 n
0000001800 00000 n
0000001870 00000 n
0000002391 00000 n
} \
	Igwd   "IGWD\x00\x01\x02\x01\x01\x2c" \
	Xz     \xFD7zXZ\x00 \
	Wsdl "wsdl\x03 \x07\x00\x00\x00\x05\x00\x00\x00hello\x0b\x00\x00\x00some source\x0c\x00\x00\x00and a targetxxxmore text" 
	]

	dict set filedata Pe "MZP\0\x02\0\0\0\x04\0\x0f\0ÿÿ\0\0¸\0\0\0\0\0\0\0@\0\x1a\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\x01\0\0º\x10\0\x0e\x1f´\x09Í!¸\x01LÍ!\x90\x90This program must be run under Win32 "
	dict set filedata Pe2 "[dict get $filedata Pe]
\$7\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0PE\0\0L\x01\x08\0Z¬\x98V\0\0\0\0\0\0\0\0à\0\x8f\x81\x0b\x01\x02\x19\0þ\0\0\0\x16\x01\0\0\0\0\0¼\x13\x01\0\0\x10\0\0\0 \x01\0\0\0@\0\0\x10\0\0\0\x02\0\0\x05\0\0\0\x06\0\0\0\x05\0\0\0\0\0\0\0\0À\x02\0\0\x04\0\05w\x0e\0\x02\0@\x81\0\0\x10\0\0@\0\0\0\0\x10\0\0\x10\0\0\0\0\0\0\x10\0\0\0\0\0\0\0\0\0\0\0\0\x90\x01\0Ð\x0d\0\0\0À\x01\0Hö\0\0\0\0\0\0\0\0\0\0PÈ\x0d\08/\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0°\x01\0\x18\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0ü\x92\x01\0\x0c\x02\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0.text\0\0\04ñ\0\0\0\x10\0\0\0ò\0\0\0\x04\0\0\0\0\0\0\0\0\0\0\0\0\0\0 \0\0`.itext\0\0D\x0b\0\0\0\x10\x01\0\0\x0c\0\0\0ö\0\0\0\0\0\0\0\0\0\0\0\0\0\0 \0\0`.data"

foreach {name data} $filedata { 
    proc make${name}File   {} [list makeBinaryFile $data $name]
    proc remove${name}File {} [list removeFile           $name]
}

foreach {name data} [dict create \
	BinData [join [apply {{} {
		for {set i 0} {$i < 256} {incr i} {
			append result [binary format c $i]
		}
		return [string repeat $result 5]
	}}] {}] \
	CSource "#include <stdio.h>\nint main(int argc, char *argv[]) {int a;}" \
	PS     "%!PS-ADOBO-123 EPSF-1.4" \
	EPS    "%!PS-ADOBO-123 EPSF-1.4" \
	Text   "simple text" \
	Script "#!/bin/tclsh" \
	Html   "<html></html>" \
	Xml    $xmlData \

    variable regexdefaultlen 4096

    # Runtime state.

    variable cursor 0      ; # The current offset
    variable fd     {}     ; # Channel to file under scrutiny
    variable found 0       ; # Whether the last test produced a match
    variable lfound {}     ; # For each level, whether a match was found
    variable level 0
    variable strbuf {}     ; # Input cache [*].
    variable cache         ; # Cache of fetched and decoded numeric
    array set cache {}	   ; # values.
    variable result {}     ; # Accumulated recognition result.
    variable extracted     ; # The value extracted for inspection
    variable  last         ; # Behind last fetch locations,
    array set last {}      ; # per nesting level.

    namespace export emit ext mime offset Nv N S Nvx Nx Sx L R I resultv U < >
}

# ### ### ### ######### ######### #########
## Public API, general use.

proc ::fileutil::magic::rt::> {} {
    variable level
    incr level
}

proc ::fileutil::magic::rt::< {} {
    variable level
    incr level -1
}

proc ::fileutil::magic::rt::classify {data} {
    set bin_rx {[\x00-\x08\x0b\x0e-\x1f]}
    if {[regexp $bin_rx $data] } {
        return binary

proc ::fileutil::magic::rt::file_start {name} {
    ::fileutil::magic::rt::Debug {puts stderr "File: $name"}
}


# return the emitted result
proc ::fileutil::magic::rt::result {{msg {}}} {
    variable lfound {}
    variable found
    variable result
    variable weight
    variable weighttotal
    if {$msg ne {}} {emit $msg}
    set res [list $found $weighttotal $result]
    set found 0

# ### ### ### ######### ######### #########
## Public API, for use by a recognizer.

# emit a description 
proc ::fileutil::magic::rt::emit msg {
    variable found
    variable lfound
    variable level
    variable maxpstring
    variable extracted
    variable result
    variable weight
    variable weighttotal
    set found 1
    dict set lfound $level 1
    incr weighttotal $weight

    #set map [list \
    #    \\b "" \
    #    %c [apply {extracted {
    #        if {[catch {format %c $extracted} result]} {
    #    	return {}

    }
}

proc ::fileutil::magic::rt::S {type offset testinvert mod mand comp val} {
    variable cursor
    variable extracted
    variable fd
    variable level
    variable lfound
    variable maxstring
    variable regexdefaultlen
    variable weight

    # $compinvert is currently ignored for strings

    set weight [string length $val]

	    if {[string first $val $extracted] >= 0} {
		set weight [string length $val]
		set c 1
	    } else {
		set c 0
	    }
	} default {
	    # explicit "default" type, which is intended only to be used with
	    # the "x" pattern
	    set c [expr {[dict exists $lfound $level] ? ![dict get $lfound $level] : 1}]
	} default {
	    # get the string and compare it
	    switch $type bestring16 - lestring16 {
		set extracted [GetString $offset $maxstring]
		set extracted [string range $extracted 0 1]
		switch $type bestring16 {
		    set extracted [binary scan $extracted Su]
		} lestring16 {

proc ::fileutil::magic::rt::Smatch {val op string mod} {
    variable weight
    if {$op eq {x}} {
	set weight 0
	return 1
    }

    if {![string length $string] && $op in {eq == < <=}} {
	if {$op in {eq == < <=}} {
	    # Nothing matches an empty $string.
	    return 0
	}
	return 1
    }

    if {$op eq {>} && [string length $val] > [string length $string]} {
	return 1
    }

    # To preserve the semantics, the w operation must occur prior to the W

}

proc ::fileutil::magic::rt::Nvx {type offset compinvert mod mand} {
    variable typemap
    variable extracted
    variable last
    variable weight
    variable level


    # unpack the type characteristics
    foreach {size scan} $typemap($type) break
    set last($level) [expr {$offset + $size}]

    set extracted [Nv $type $offset $compinvert $mod $mand]

    ::fileutil::magic::rt::Debug {puts stderr "NVx $type $offset $extracted $mod $mand"}
    return $extracted
}

# Numeric - get bytes of $type at $offset and $compare to $val
# qual might be a mask
proc ::fileutil::magic::rt::Nx {
    type offset testinvert compinvert mod mand comp val} {

    variable cursor
    variable typemap
    variable extracted
    variable last
    variable level
    variable weight


    set res [N $type $offset $testinvert $compinvert $mod $mand $comp $val]

    ::fileutil::magic::rt::Debug {
	puts stderr "Nx numeric $type: $val $comp $extracted / $qual - $c"
    }
    set last($level) $cursor
    return $res
}

proc ::fileutil::magic::rt::Sx {
    type offset testinvert mod mand comp val} {
    variable cursor
    variable extracted
    variable fd
    variable last
    variable level
    variable weight


    set res [S $type $offset $testinvert $mod $mand $comp $val]
    set last($level) $cursor
    return $res
}
proc ::fileutil::magic::rt::L {newlevel} {
    variable level $newlevel
    # Regenerate level information in the calling context.

    return
}

proc ::fileutil::magic::rt::I {offset it ioi ioo iir io} {
    # Handling of base locations specified indirectly through the
    # contents of the inspected file.
    variable typemap
    foreach {size scan} $typemap($it) break
    if {$iir} {
	# To do:  this can't be right.
	set io [Fetch [expr $offset + $io] $size $scan]
    }
    set data [Fetch $offset $size $scan]

    if {$ioi && [string is double -strict $data]} {
	set data [expr {~$data}]
    }
    if {$ioo ne {} && [string is double -strict $data]} {
	set data [expr $data $ioo $io]
    }
    if {![string is double -strict $data]} {
	set data -1
    }
    return $data
}

proc ::fileutil::magic::rt::R base {
    # Handling of base locations specified relative to the end of the
    # last field one level above.

    variable last   ; # Remembered locations.
    variable level  ; # The level to get data from.
    return [expr {$last([expr {$level-1}]) + $base}]
}


proc ::fileutil::magic::rt::U {file name} {

    upvar named named
    set script [use $named $file $name]
    tailcall ::try $script
}

# ### ### ### ######### ######### #########
## Internal. Retrieval of the data used in comparisons.

# fetch and cache a numeric value from the file
proc ::fileutil::magic::rt::Fetch {where what scan} {
    variable cache
    variable cursor
    variable extracted
    variable strbuf
    variable fd

    # Avoid [seek] errors
    if {$where < 0} {
	set where 0
    }
    # {to do} id3 length
    if {![info exists cache($where,$what,$scan)]} {
	::seek $fd $where
	set data [::read $fd $what]
	incr cursor [string length $data]
	set extracted [rtscan $data $scan]
	set cache($where,$what,$scan) [list $extracted $cursor]

	    Usage
	}
    }

    # Additional validation, and extraction of the non-option
    # arguments.

    if {[llength $argv] < 2} Usage

    set namespace  [lindex $argv 0]
    set magic [lrange $argv 1 end]

    # Final validation across the whole configuration.

    if {$namespace eq ""} {