# Commands related to resource manipulation # # Copyright (c) 2003-2012 Ashok P. Nadkarni # All rights reserved. # # See the file LICENSE for license package require twapi_nls # Retrieve version info for a file proc twapi::get_file_version_resource {path args} { array set opts [parseargs args { all datetime signature structversion fileversion productversion flags fileos filetype foundlangid foundcodepage langid.arg codepage.arg }] set ver [Twapi_GetFileVersionInfo $path] trap { array set verinfo [Twapi_VerQueryValue_FIXEDFILEINFO $ver] set result [list ] if {$opts(all) || $opts(signature)} { lappend result -signature [format 0x%x $verinfo(dwSignature)] } if {$opts(all) || $opts(structversion)} { lappend result -structversion "[expr {0xffff & ($verinfo(dwStrucVersion) >> 16)}].[expr {0xffff & $verinfo(dwStrucVersion)}]" } if {$opts(all) || $opts(fileversion)} { lappend result -fileversion "[expr {0xffff & ($verinfo(dwFileVersionMS) >> 16)}].[expr {0xffff & $verinfo(dwFileVersionMS)}].[expr {0xffff & ($verinfo(dwFileVersionLS) >> 16)}].[expr {0xffff & $verinfo(dwFileVersionLS)}]" } if {$opts(all) || $opts(productversion)} { lappend result -productversion "[expr {0xffff & ($verinfo(dwProductVersionMS) >> 16)}].[expr {0xffff & $verinfo(dwProductVersionMS)}].[expr {0xffff & ($verinfo(dwProductVersionLS) >> 16)}].[expr {0xffff & $verinfo(dwProductVersionLS)}]" } if {$opts(all) || $opts(flags)} { set flags [expr {$verinfo(dwFileFlags) & $verinfo(dwFileFlagsMask)}] lappend result -flags \ [_make_symbolic_bitmask \ [expr {$verinfo(dwFileFlags) & $verinfo(dwFileFlagsMask)}] \ { debug 1 prerelease 2 patched 4 privatebuild 8 infoinferred 16 specialbuild 32 } \ ] } if {$opts(all) || $opts(fileos)} { switch -exact -- [format %08x $verinfo(dwFileOS)] { 00010000 {set os dos} 00020000 {set os os216} 00030000 {set os os232} 00040000 {set os nt} 00050000 {set os wince} 00000001 {set os windows16} 00000002 {set os pm16} 00000003 {set os pm32} 00000004 {set os windows32} 00010001 {set os dos_windows16} 00010004 {set os dos_windows32} 00020002 {set os os216_pm16} 00030003 {set os os232_pm32} 00040004 {set os nt_windows32} default {set os $verinfo(dwFileOS)} } lappend result -fileos $os } if {$opts(all) || $opts(filetype)} { switch -exact -- [expr {0+$verinfo(dwFileType)}] { 1 {set type application} 2 {set type dll} 3 { set type "driver." switch -exact -- [expr {0+$verinfo(dwFileSubtype)}] { 1 {append type printer} 2 {append type keyboard} 3 {append type language} 4 {append type display} 5 {append type mouse} 6 {append type network} 7 {append type system} 8 {append type installable} 9 {append type sound} 10 {append type comm} 11 {append type inputmethod} 12 {append type versionedprinter} default {append type $verinfo(dwFileSubtype)} } } 4 { set type "font." switch -exact -- [expr {0+$verinfo(dwFileSubtype)}] { 1 {append type raster} 2 {append type vector} 3 {append type truetype} default {append type $verinfo(dwFileSubtype)} } } 5 { set type "vxd.$verinfo(dwFileSubtype)" } 7 {set type staticlib} default { set type "$verinfo(dwFileType).$verinfo(dwFileSubtype)" } } lappend result -filetype $type } if {$opts(all) || $opts(datetime)} { lappend result -datetime [expr {($verinfo(dwFileDateMS) << 32) + $verinfo(dwFileDateLS)}] } # Any remaining arguments are treated as string names if {[llength $args] || $opts(foundlangid) || $opts(foundcodepage) || $opts(all)} { # Find list of langid's and codepages and do closest match set langid [expr {[info exists opts(langid)] ? $opts(langid) : [get_user_ui_langid]}] set primary_langid [extract_primary_langid $langid] set sub_langid [extract_sublanguage_langid $langid] set cp [expr {[info exists opts(codepage)] ? $opts(codepage) : 0}] # Find a match in the following order: # 0 Exact match for both langid and codepage # 1 Exact match for langid # 2 Primary langid matches (sublang does not) and exact codepage # 3 Primary langid matches (sublang does not) # 4 Language neutral # 5 English # 6 First langcp in list or "00000000" set match(7) "00000000"; # In case list is empty foreach langcp [Twapi_VerQueryValue_TRANSLATIONS $ver] { set verlangid 0x[string range $langcp 0 3] set vercp 0x[string range $langcp 4 7] if {$verlangid == $langid && $vercp == $cp} { set match(0) $langcp break; # No need to look further } if {[info exists match(1)]} continue if {$verlangid == $langid} { set match(1) $langcp continue; # Continue to look for match(0) } if {[info exists match(2)]} continue set verprimary [extract_primary_langid $verlangid] if {$verprimary == $primary_langid && $vercp == $cp} { set match(2) $langcp continue; # Continue to look for match(1) or better } if {[info exists match(3)]} continue if {$verprimary == $primary_langid} { set match(3) $langcp continue; # Continue to look for match(2) or better } if {[info exists match(4)]} continue if {$verprimary == 0} { set match(4) $langcp; # LANG_NEUTRAL continue; # Continue to look for match(3) or better } if {[info exists match(5)]} continue if {$verprimary == 9} { set match(5) $langcp; # English continue; # Continue to look for match(4) or better } if {![info exists match(6)]} { set match(6) $langcp } } # Figure out what is the best match we have for {set i 0} {$i <= 7} {incr i} { if {[info exists match($i)]} { break } } if {$opts(foundlangid) || $opts(all)} { set langid 0x[string range $match($i) 0 3] lappend result -foundlangid [list $langid [VerLanguageName $langid]] } if {$opts(foundcodepage) || $opts(all)} { lappend result -foundcodepage 0x[string range $match($i) 4 7] } foreach sname $args { lappend result $sname [Twapi_VerQueryValue_STRING $ver $match($i) $sname] } } } finally { Twapi_FreeFileVersionInfo $ver } return $result } proc twapi::begin_resource_update {path args} { array set opts [parseargs args { deleteall } -maxleftover 0] return [BeginUpdateResource $path $opts(deleteall)] } # Note this is not an alias because we want to control arguments # to UpdateResource (which can take more args that specified here) proc twapi::delete_resource {hmod restype resname langid} { UpdateResource $hmod $restype $resname $langid } # Note this is not an alias because we want to make sure $bindata is specified # as an argument else it will have the effect of deleting a resource proc twapi::update_resource {hmod restype resname langid bindata} { UpdateResource $hmod $restype $resname $langid $bindata } proc twapi::end_resource_update {hmod args} { array set opts [parseargs args { discard } -maxleftover 0] return [EndUpdateResource $hmod $opts(discard)] } proc twapi::read_resource {hmod restype resname langid} { return [Twapi_LoadResource $hmod [FindResourceEx $hmod $restype $resname $langid]] } proc twapi::read_resource_string {hmod resname langid} { # As an aside, note that we do not use a LoadString call # because it does not allow for specification of a langid # For a reference to how strings are stored, see # http://blogs.msdn.com/b/oldnewthing/archive/2004/01/30/65013.aspx # or http://support.microsoft.com/kb/196774 if {![string is integer -strict $resname]} { error "String resources must have an integer id" } lassign [resource_stringid_to_stringblockid $resname] block_id index_within_block return [lindex \ [resource_stringblock_to_strings \ [read_resource $hmod 6 $block_id $langid] ] \ $index_within_block] } # Give a list of strings, formats it as a string block. Number of strings # must not be greater than 16. If less than 16 strings, remaining are # treated as empty. proc twapi::strings_to_resource_stringblock {strings} { if {[llength $strings] > 16} { error "Cannot have more than 16 strings in a resource string block." } for {set i 0} {$i < 16} {incr i} { set s [lindex $strings $i] set n [string length $s] append bin [binary format sa* $n [encoding convertto unicode $s]] } return $bin } proc twapi::resource_stringid_to_stringblockid {id} { # Strings are stored in blocks of 16, with block id's beginning at 1, not 0 return [list [expr {($id / 16) + 1}] [expr {$id & 15}]] } proc twapi::extract_resources {hmod {withdata 0}} { set result [dict create] foreach type [enumerate_resource_types $hmod] { set typedict [dict create] foreach name [enumerate_resource_names $hmod $type] { set namedict [dict create] foreach lang [enumerate_resource_languages $hmod $type $name] { if {$withdata} { dict set namedict $lang [read_resource $hmod $type $name $lang] } else { dict set namedict $lang {} } } dict set typedict $name $namedict } dict set result $type $typedict } return $result } # TBD - test proc twapi::write_bmp_file {filename bmp} { # Assumes $bmp is clipboard content in format 8 (CF_DIB) # First parse the bitmap data to collect header information binary scan $bmp "iiissiiiiii" size width height planes bitcount compression sizeimage xpelspermeter ypelspermeter clrused clrimportant # We only handle BITMAPINFOHEADER right now (size must be 40) if {$size != 40} { error "Unsupported bitmap format. Header size=$size" } # We need to figure out the offset to the actual bitmap data # from the start of the file header. For this we need to know the # size of the color table which directly follows the BITMAPINFOHEADER if {$bitcount == 0} { error "Unsupported format: implicit JPEG or PNG" } elseif {$bitcount == 1} { set color_table_size 2 } elseif {$bitcount == 4} { # TBD - Not sure if this is the size or the max size set color_table_size 16 } elseif {$bitcount == 8} { # TBD - Not sure if this is the size or the max size set color_table_size 256 } elseif {$bitcount == 16 || $bitcount == 32} { if {$compression == 0} { # BI_RGB set color_table_size $clrused } elseif {$compression == 3} { # BI_BITFIELDS set color_table_size 3 } else { error "Unsupported compression type '$compression' for bitcount value $bitcount" } } elseif {$bitcount == 24} { set color_table_size $clrused } else { error "Unsupported value '$bitcount' in bitmap bitcount field" } set filehdr_size 14; # sizeof(BITMAPFILEHEADER) set bitmap_file_offset [expr {$filehdr_size+$size+($color_table_size*4)}] set filehdr [binary format "a2 i x2 x2 i" "BM" [expr {$filehdr_size + [string length $bmp]}] $bitmap_file_offset] set fd [open $filename w] fconfigure $fd -translation binary puts -nonewline $fd $filehdr puts -nonewline $fd $bmp close $fd } proc twapi::_load_image {flags type hmod path args} { # The flags arg is generally 0x10 (load from file), or 0 (module) # or'ed with 0x8000 (shared). The latter can be overridden by # the -shared option but should not be except when loading from module. array set opts [parseargs args { {createdibsection.bool 0 0x2000} {defaultsize.bool 0 0x40} height.int {loadtransparent.bool 0 0x20} {monochrome.bool 0 0x1} {shared.bool 0 0x8000} {vgacolor.bool 0 0x80} width.int } -maxleftover 0 -nulldefault] set flags [expr {$flags | $opts(defaultsize) | $opts(loadtransparent) | $opts(monochrome) | $opts(shared) | $opts(vgacolor)}] set h [LoadImage $hmod $path $type $opts(width) $opts(height) $flags] # Cast as _SHARED if required to offer some protection against # being freed using DestroyIcon etc. set type [lindex {HGDIOBJ HICON HCURSOR} $type] if {$flags & 0x8000} { append type _SHARED } return [cast_handle $h $type] } proc twapi::_load_image_from_system {type id args} { variable _oem_image_syms if {![string is integer -strict $id]} { if {![info exists _oem_image_syms]} { # Bitmap symbols (type 0) dict set _oem_image_syms 0 { CLOSE 32754 UPARROW 32753 DNARROW 32752 RGARROW 32751 LFARROW 32750 REDUCE 32749 ZOOM 32748 RESTORE 32747 REDUCED 32746 ZOOMD 32745 RESTORED 32744 UPARROWD 32743 DNARROWD 32742 RGARROWD 32741 LFARROWD 32740 MNARROW 32739 COMBO 32738 UPARROWI 32737 DNARROWI 32736 RGARROWI 32735 LFARROWI 32734 SIZE 32766 BTSIZE 32761 CHECK 32760 CHECKBOXES 32759 BTNCORNERS 32758 } # Icon symbols (type 1) dict set _oem_image_syms 1 { SAMPLE 32512 HAND 32513 QUES 32514 BANG 32515 NOTE 32516 WINLOGO 32517 WARNING 32515 ERROR 32513 INFORMATION 32516 SHIELD 32518 } # Cursor symbols (type 2) dict set _oem_image_syms 2 { NORMAL 32512 IBEAM 32513 WAIT 32514 CROSS 32515 UP 32516 SIZENWSE 32642 SIZENESW 32643 SIZEWE 32644 SIZENS 32645 SIZEALL 32646 NO 32648 HAND 32649 APPSTARTING 32650 } } } set id [dict get $_oem_image_syms $type [string toupper $id]] # Built-in system images must always be loaded shared (0x8000) return [_load_image 0x8000 $type NULL $id {*}$args] } # 0x10 -> LR_LOADFROMFILE. Also 0x8000 not set (meaning unshared) interp alias {} twapi::load_bitmap_from_file {} twapi::_load_image 0x10 0 NULL interp alias {} twapi::load_icon_from_file {} twapi::_load_image 0x10 1 NULL interp alias {} twapi::load_cursor_from_file {} twapi::_load_image 0x10 2 NULL interp alias {} twapi::load_bitmap_from_module {} twapi::_load_image 0 0 interp alias {} twapi::load_icon_from_module {} twapi::_load_image 0 1 interp alias {} twapi::load_cursor_from_module {} twapi::_load_image 0 2 interp alias {} twapi::load_bitmap_from_system {} twapi::_load_image_from_system 0 interp alias {} twapi::load_icon_from_system {} twapi::_load_image_from_system 1 interp alias {} twapi::load_cursor_from_system {} twapi::_load_image_from_system 2 interp alias {} twapi::free_icon {} twapi::DestroyIcon interp alias {} twapi::free_bitmap {} twapi::DeleteObject interp alias {} twapi::free_cursor {} twapi::DestroyCursor