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
}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.
output:
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 values to the file but here is a list of the ones normally used.
Comments CompanyName FileDescription FileVersion InternalName LegalCopyright LegalTrademarks OriginalFilename PrivateBuild ProductName ProductVersion SpecialBuild
in addition i use 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