proc FindWindowsHeader {file sig} {
    set fh [open $file r]
    fconfigure $fh -encoding binary -eofchar {} -translation lf
    if {[read $fh 2] != "MZ"} {close $fh; error "not an DOS executable"}
    seek $fh 60 start
    seek $fh [getword $fh] start
    if {[read $fh 2] != $sig} {close $fh; error "windows header not found"}
    seek $fh -2 current
    return $fh
}

proc EnumNEResources {file} {
    set fh [FindWindowsHeader $file NE]
    seek $fh 36 current
    seek $fh [expr {[getword $fh] - 36}] current
    set base [tell $fh]

    set ret {}
    while {[set type [getNEResName $fh $base [getushort $fh]]] != 0} {
        set num [getushort $fh]
        seek $fh [expr {$num * 12 + 4}] current
        lappend ret $type $num
    }
    return $ret
}

proc getNEResource {file restype {resid {}}} {
    set fh [FindWindowsHeader $file NE]
    seek $fh 36 current
    seek $fh [expr {[getword $fh] - 38}] current
    set base [tell $fh]

    set shift [expr {int(pow(2, [getushort $fh]))}]
    while {[set type [getNEResName $fh $base [getushort $fh]]] != 0} {
        set num [getushort $fh]
        if {$type != $restype} {
            seek $fh [expr {$num * 12 + 4}] current
            continue
        }
        seek $fh 4 current
        set ret {}
        for {set i 0} {$i < $num} {incr i} {
            set offset [expr {[getushort $fh] * $shift}]
            set len [getushort $fh]
            seek $fh 2 current
            lappend ret[getNEResName $fh $base [getushort $fh]] $offset $len
            seek $fh 4 current
        }
        close $fh
        return $ret
    }
    return {}
}


proc getNEResName {fh base data} {
    if {$data == 0} {
        return 0
    } elseif {[getbit $data 0] == 0} {
        set cur [tell $fh]
        seek $fh [expr {$data + $base}] start
        set len [getchar $fh]
        set name [read $fh $len]
        seek $fh $cur start
        return $name
    } else {
        return [expr {$data & 0x7fff}]
    }
}

proc EnumPEResources {file} {
    set fh [FindWindowsHeader $file PE]
    binary scan [read $fh 24] x6sx12s sections headersize
    seek $fh $headersize current
    for {set i 0} {$i < $sections} {incr i} {
        binary scan [read $fh 40] a8x4ix4i type baserva base
        if {[string match .rsrc* $type]} {break}
    }
    if {![string match .rsrc* $type]} {close $fh; return {}}
    seek $fh [expr {$base + 12}] start

    set res {}
    set entries [expr {[getushort $fh] + [getushort $fh]}]
    for {set i 0} {$i < $entries} {incr i} {
        lappend res [getPEResName $fh $base [getulong $fh]]
        set offset [expr {[getulong $fh] & 0x7fffffff}]
        set cur [tell $fh]
        seek $fh [expr {$base + $offset + 12}] start
        lappend res [expr {[getushort $fh] + [getushort $fh]}]
        seek $fh $cur start
    }
    close $fh
    return $res
}

proc getPEResource {file restype {resid {}}} {
    set fh [FindWindowsHeader $file PE]
    binary scan [read $fh 24] x6sx12s sections headersize
    seek $fh $headersize current
    for {set i 0} {$i < $sections} {incr i} {
        binary scan [read $fh 40] a8x4ix4i type baserva base
        if {[string match .rsrc* $type]} {break}
    }
    if {![string match .rsrc* $type]} {close $fh; return {}}
    seek $fh [expr {$base + 12}] start

    set entries [expr {[getushort $fh] + [getushort $fh]}]
    for {set i 0} {$i < $entries} {incr i} {
        set name [getPEResName $fh $base [getulong $fh]]
        set offset [expr {[getulong $fh] & 0x7fffffff}]
        if {$name != $restype} {continue}

        set cur [tell $fh]
        seek $fh [expr {$base + $offset + 12}] start
        
        set entries2 [expr {[getushort $fh] + [getushort $fh]}]
        for {set i2 0} {$i2 < $entries2} {incr i2} {
            
            set name [getulong $fh]
            set offset [expr {[getulong $fh] & 0x7fffffff}]
            set name [getPEResName $fh $base $name]
            if {$resid != "" && $name != $resid} {continue}
            
            set cur2 [tell $fh]
            seek $fh [expr {$offset + $base + 12}] start
          
            set entries3 [expr {[getushort $fh] + [getushort $fh]}]
            for {set i3 0} {$i3 < $entries3} {incr i3} {
                binary scan [read $fh 4] H2H2 n1 n2
                set offset [expr {[getulong $fh] & 0x7fffffff}]
                set cur3 [tell $fh]
                        
                seek $fh [expr {$offset + $base}] start
                set rva [getulong $fh]
                set size [getulong $fh]
                lappend ret $name [expr {$rva - $baserva + $base}] $size
                        
                seek $fh $cur3 start
            }
            seek $fh $cur2 start
        }
        close $fh
        return $ret
    }
    return {}
}

proc getPEResName {fh start data} {
    if {($data & 0x80000000) != 0} {
        set cur [tell $fh]
        seek $fh [expr {($data & 0x7fffffff) + $start}] start
        set len [getushort $fh]
        set name [read $fh [expr {$len * 2}]]
        seek $fh $cur start
        return [encoding convertfrom unicode $name]
    } else {
        return $data
    }
}

proc getdword {fh} {
    binary scan [read $fh 4] i tmp
    return $tmp
}

proc getulong {fh} {
    binary scan [read $fh 4] i tmp
    return [format %u $tmp]
}

proc getushort {fh} {
    binary scan [read $fh 2] s tmp
    return [expr {$tmp & 0x0000FFFF}]
}

proc getword {fh} {
    binary scan [read $fh 2] s tmp
    return $tmp
}

proc getchar {fh} {
    binary scan [read $fh 1] c tmp
    return $tmp
}