[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''

   * Comments
   * CompanyName
   * FileDescription
   * FileVersion
   * InternalName
   * LegalCopyright
   * LegalTrademarks
   * OriginalFilename
   * PrivateBuild
   * ProductName 
   * ProductVersion
   * SpecialBuild

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

http://msdn.microsoft.com/library/en-us/winui/winui/windowsuserinterface/resources/versioninformation/versioninformationreference/versioninformationstructures/stringfileinfo.asp

http://msdn.microsoft.com/library/en-us/winui/winui/windowsuserinterface/resources/versioninformation/versioninformationreference/versioninformationstructures/stringtable.asp

http://msdn.microsoft.com/library/en-us/winui/winui/windowsuserinterface/resources/versioninformation/versioninformationreference/versioninformationstructures/string.asp