AF 24-07-03
proc getdword {fh} {
binary scan [read $fh 4] i* tmp
return $tmp
}
proc getword {fh} {
binary scan [read $fh 2] s* tmp
return $tmp
}
proc getFixedInfo {file array} {
set fh [open $file r]
fconfigure $fh -encoding unicode -eofchar {}
set data [read $fh]
set s [string first "VS_VERSION_INFO" $data]
if {$s < 0} {close $fh; error "no version information found"}
unset data
fconfigure $fh -encoding binary
seek $fh [expr {($s * 2) - 6}] start
seek $fh [expr {[tell $fh] % 4}] current
binary scan [read $fh 6] sss len vlen type
seek $fh 34 current
if {[getdword $fh] != 4277077181} {close $fh; error "version information corrupt"}
upvar $array ret
array set ret {}
seek $fh 4 current
binary scan [read $fh 8] ssss b a d c
set ret(FileVer) $a.$b.$c.$d
binary scan [read $fh 8] ssss b a d c
set ret(ProductVer) $a.$b.$c.$d
seek $fh 4 current
#binary scan [read $fh 4] B32 flagmask
set ret(Flags) [getdword $fh]
set ret(OS) [getdword $fh]
set ret(FileType) [getdword $fh]
set ret(FileSubType) [getdword $fh]
binary scan [read $fh 8] w ret(Date)
close $fh
}
proc getFixedInfo2 {file array} {
set fh [open $file r]
fconfigure $fh -encoding binary -eofchar {}
set data [read $fh]
set s [string first "VS_VERSION_INFO" $data]
if {$s < 0} {close $fh; error "no version information found"}
unset data
seek $fh [expr {$s - 6}] start
seek $fh [expr {[tell $fh] % 4}] current
seek $fh 22 current
if {[getdword $fh] != 4277077181} {close $fh; error "version information corrupt"}
upvar $array ret
array set ret {}
seek $fh [expr {[tell $fh] % 4}] current
binary scan [read $fh 8] ssss d c b a
set ret(FileVer) $a.$b.$c.$d
binary scan [read $fh 8] ssss d c b a
set ret(ProductVer) $a.$b.$c.$d
seek $fh 8 current
set ret(Flags) [getdword $fh]
set ret(OS) [getdword $fh]
set ret(FileType) [getdword $fh]
set ret(FileSubType) [getdword $fh]
binary scan [read $fh 8] w ret(Date)
close $fh
}
proc getStringInfo {file array} {
upvar $array ret
array set ret {}
set fh [open $file r]
fconfigure $fh -translation lf -encoding unicode -eofchar {}
set data [read $fh]
close $fh
if {[set s [string first "StringFileInfo\000" $data]] < 0} {error "no string information found"}
incr s -3
if {![regexp {(.)\000(.)StringFileInfo\000(.)\000(.)(....)(....)\000} [string range $data $s end] --> len type len2 type2 lang code]} {
error "string information corrupt"
}
array set ret [list Language $lang CodePage $code]
set len [expr [scan $len %c] / 2]
set len2 [expr [scan $len2 %c] / 2]
set data [string range $data $s [expr {$s + $len}]]
set s 30
while {$s < $len2} {
scan [string range $data $s end] %c%c%c slen vlen type
if {$slen == 0} return
set slen [expr {$slen / 2}]
set name [string range $data [expr {$s + 3}] [expr {$s + $slen - $vlen - 1}]]
set value [string range $data [expr {$s + $slen - $vlen}] [expr {$s + $slen - 2}]]
set s [expr {$s + $slen + ($slen % 2)}]
set ret([string trimright $name \000]) $value
}
}
proc getStringInfo2 {file array} {
upvar $array ret
array set ret {}
set fh [open $file r]
fconfigure $fh -encoding binary -eofchar {}
set data [read $fh]
if {[set s [string first "StringFileInfo\000" $data]] < 0} {close $fh; error "no string information found"}
seek $fh [expr {$s + 17}] start
set len [getword $fh]
seek $fh 2 current
array set ret [list Lang [read $fh 4] CodePage [read $fh 4]]
seek $fh 2 current
seek $fh [expr {[tell $fh] % 4}] current
set end [expr {$s + $len}]
while {[tell $fh] < $end} {
set slen [getword $fh]
set vlen [getword $fh]
set name [read $fh [expr {$slen - $vlen - 4}]]
set value [read $fh [expr {$vlen + ($slen % 2)}]]
seek $fh [expr {[tell $fh] % 4}] current
set ret([string trimright $name \000]) [string trimright $value \000]
}
}
proc writeStringInfo {file array} {
upvar $array val
set fh [open $file r+]
fconfigure $fh -translation lf -encoding unicode -eofchar {}
set data [read $fh]
set s [string first "StringFileInfo\000" $data]
if {$s < 0} { close $fh; error "no stringfileinfo found" }
if {![info exists val(CodePage)]} { set val(CodePage) 04b0 }
if {![info exists val(Language)]} { set val(Language) 0409 }
incr s -3
set len [scan [string index $data $s] %c]
seek $fh [expr {$s * 2}] start
puts -nonewline $fh [format "%c\000\001StringFileInfo\000%c\000\001%s%s\000" $len [expr {$len - 36}] $val(Language) $val(CodePage)]
unset val(CodePage) val(Language)
set olen $len
set len [expr {($len / 2) - 30}]
foreach x [array names val] {
set vlen [expr {[string length $val($x)] + 1}]
set nlen [string length $x]
set npad [expr {$nlen % 2}]
set tlen [expr {$vlen + $nlen + $npad + 4}]
set tpad [expr {$tlen % 2}]
if {($tlen + $tpad) > $len} { set error "too long" ; break }
puts -nonewline $fh [format "%c%c\001%s\000%s%s\000%s" [expr {$tlen * 2}] $vlen $x [string repeat \000 $npad] $val($x) [string repeat \000 $tpad]]
set len [expr {$len - $tlen - $tpad}]
}
puts -nonewline $fh [string repeat \000 $len]
puts -nonewline $fh [string range $data [expr {$s + ($olen / 2)}] end]
close $fh
if {[info exists error]} { error $error }
}
proc readFixedInfo {file} {
if {[catch {getFixedInfo $file results} err]} {
puts "Error reading fixed file information: $err"
return
}
puts "File version: $results(FileVer)"
puts "Product version: $results(ProductVer)"
set flags {}
foreach x [lsort -integer -decreasing [array names ::ffi_flags]] {
if {$results(Flags) > $x} {
incr results(Flags) -$x
lappend flags $::ffi_flags($x)
}
}
if {$flags == ""} { set flags None }
puts "Flags: [join $flags ", "]"
set blah {}
if {$results(OS) == 0} {
puts "OS: Unknown"
} else {
foreach x [lsort -integer -decreasing [array names ::ffi_os]] {
if {$results(OS) >= $x} {
incr results(OS) -$x
lappend blah $x
}
}
switch -exact -- [llength $blah] {
0 { puts "OS: Unidentified" }
1 { puts "OS: $::ffi_os([lindex $blah 0])" }
default { puts "OS: $::ffi_os([lindex $blah 1]) on $::ffi_os([lindex $blah 0])" }
}
}
if {[info exists ::ffi_type($results(FileType))]} {
puts "File Type: $::ffi_type($results(FileType))"
} else {
puts "File Type: Unidentified"
}
if {$results(FileType) != 3 && $results(FileType) != 4} {
} elseif {[info exists ::ffi_${ft}_subtype($results(FileSubType))]} {
puts "File SubType: [set ::ffi_${ft}_subtype($results(FileSubType))]"
} else {
puts "File SubType: Unidentified"
}
if {$results(Date) == 0} {
puts "Date: None"
} else {
puts "Date: [clock format $results(Date) -gmt 1]"
}
}
proc readStringInfo {file} {
if {[catch {getStringInfo $file results} err]} {
puts "Error reading string file information: $err"
return
}
foreach x [array names results] {
puts "$x: $results($x)"
}
}
array set ffi_os {
1 "Windows 16bit"
2 "Presentation Manager 16bit"
3 "Presentation Manager 32bit"
4 "Windows 32bit"
65536 DOS
131072 "OS/2 16bit"
196608 "OS/2 32bit"
262144 "Windows NT"
}
array set ffi_flags {
1 Debug
2 Prerelease
4 Patched
8 "Private Build"
16 "Info Inferred"
32 "Special Build"
}
array set ffi_type {
0 Unknown
1 Application
2 DLL
3 Driver
4 Font
5 VXD
7 "Static Library"
}
array set ffi_3_subtype {
0 Unknown
1 Printer
2 Keyboard
3 Language
4 Display
5 Mouse
6 Network
7 System
8 Installable
9 Sound
10 Communications}
array set ffi_4_subtype {
0 Unknown
1 Raster
2 Vector
3 TrueType
}Usage:
the get* procs represent a programatic interface to the information. the read* procs output this information in a nice human readable format. the *2 procs exist because there are 2 slightly different types of files, the newer ones are unicode.
getFixedInfo returns array with the fixed file info
getFixedInfo2 returns array with the fixed file info
getStringInfo returns array with the string file info
'''getStringInfo2 returns array with the string file info
readFixedInfo prints the formatted/decoded fixed file info
readStringInfo prints the formatted/decoded string file info
writeStringInfo writes the info in an array to a files string file info
the output looks like this:
getFixedInfo tclkit.exe test parray test test(Date) = 0 test(FileSubType) = 0 test(FileType) = 2 test(FileVer) = 8.4.2.2 test(Flags) = 0 test(OS) = 4 test(ProductVer) = 8.4.2.2 getStringInfo tclkit.exe test parray test test(CodePage) = 04b0 test(CompanyName) = Equi4 Software test(FileDescription) = Tclkit, a standalone runtime for Tcl/Tk test(FileVersion) = 8.4.2 test(Language) = 0409 test(LegalCopyright) = Copyright © 1989-2003 by J.Ousterhout et al. test(OriginalFilename) = tclkit.exe test(ProductName) = Tclkit 8.4 for Windows test(ProductVersion) = 8.4.2 readFixedInfo tclkit.exe File version: 8.4.2.2 Product version: 8.4.2.2 Flags: None OS: Windows 32bit File Type: DLL Date: None
i support writing any stringinfo values to the file but here is a list of the ones normally used.
i REQUIRE CodePage and Language
you can only write to files that already have a stringfileinfo block and you are limited to the same or less total length so as not to corrupt the file.
some relevant links