idnconf.tcl

package of develop dns

# $Id: idnconf.tcl,v 1.1.1.1 2003/06/04 00:27:42 marka Exp $
#
# idnconf.tcl - configure idn wrapper
#

#############################################################################
#  Copyright (c) 2000,2002 Japan Network Information Center.
#  All rights reserved.
#   
#  By using this file, you agree to the terms and conditions set forth bellow.
#  
#  			LICENSE TERMS AND CONDITIONS 
#  
#  The following License Terms and Conditions apply, unless a different
#  license is obtained from Japan Network Information Center ("JPNIC"),
#  a Japanese association, Kokusai-Kougyou-Kanda Bldg 6F, 2-3-4 Uchi-Kanda,
#  Chiyoda-ku, Tokyo 101-0047, Japan.
#  
#  1. Use, Modification and Redistribution (including distribution of any
#     modified or derived work) in source and/or binary forms is permitted
#     under this License Terms and Conditions.
#  
#  2. Redistribution of source code must retain the copyright notices as they
#     appear in each source code file, this License Terms and Conditions.
#  
#  3. Redistribution in binary form must reproduce the Copyright Notice,
#     this License Terms and Conditions, in the documentation and/or other
#     materials provided with the distribution.  For the purposes of binary
#     distribution the "Copyright Notice" refers to the following language:
#     "Copyright (c) 2000-2002 Japan Network Information Center.  All rights reserved."
#  
#  4. The name of JPNIC may not be used to endorse or promote products
#     derived from this Software without specific prior written approval of
#     JPNIC.
#  
#  5. Disclaimer/Limitation of Liability: THIS SOFTWARE IS PROVIDED BY JPNIC
#     "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
#     LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
#     PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL JPNIC BE LIABLE
#     FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
#     CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
#     SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
#     BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
#     WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
#     OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
#     ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
#############################################################################

global  configFile configBack
global  registryKey registryEnc registryDef
global  filesCpy filesRen filesDel

# idnkit version
set version	"1.0"

set configFile  "idnconf.lst"   ;# list of wrapped program
set configBack  "idnconf.bak"   ;# backup of previous data

set serverKey		"HKEY_LOCAL_MACHINE\\Software\\JPNIC\\IDN"
set serverLogLevel	LogLevel
set serverLogLevelDef	-1
set serverLogLevelNone	-1
set serverLogFile	LogFile
set serverLogFileDef	{C:\idn_wrapper.log}
set serverConfFile	ConfFile

set perprogKey		"HKEY_LOCAL_MACHINE\\Software\\JPNIC\\IDN\\PerProg\\"
set perprogEnc		Encoding
set perprogDef		Default

set logFileNameDef	idn_wrapper.log
set confFileNameDef	idn.conf

set filesCpy11 { "wsock32.dll" }
set filesCpy20 { "wsock32.dll" "ws2_32.dll" }
set filesDel11 { "wsock32.dll" }
set filesDel20 { "wsock32.dll" "ws2_32.dll" }

set local_dll		0

########################################################################
#
# OS version check
#

proc get_os_version {} {
    global os_version tcl_platform

    if {[llength [info globals os_version]] > 0} {
	return $os_version
    }

    switch -- $tcl_platform(os) {
	"Windows 95" {
	    switch -- $tcl_platform(osVersion) {
		4.0 {
		    set os_version {Windows 95}
		}
		4.10 {
		    set os_version {Windows 98}
		}
		4.90 {
		    set os_version {Windows Me}
		}
	    }
	}
	"Windows NT" {
	    switch -- $tcl_platform(osVersion) {
		3.51 -
		4.0 {
		    set os_version {Windows NT}
		}
		5.0 {
		    set os_version {Windows 2000}
		}
		default {
		    # XP or .NET
		    set os_version {Windows XP}
		}
	    }
	}
	"Win32s" {
	    error "idn wrapper does not support Windows 3.1"
	}
	default {
	    set os_version "Unknown"
	}
    }
    set os_version
}

proc support_dll_redirection {} {
    global dll_redirection

    if {[llength [info globals dll_redirection]] > 0} {
	return $dll_redirection
    }

    switch -- [get_os_version] {
	{Windows 95} -
	{Windows NT} {
	    # cannot force local DLL reference by .local file.
	    set dll_redirection 0
	}
	default {
	    set dll_redirection 1
	}
    }
    set dll_redirection
}

########################################################################
#
# handling pathname
#

proc getExeName { prg } {
    set elem [file split $prg]
    set leng [expr {[llength $elem] - 1}]
    set name [lindex $elem $leng]
    set exe  [file rootname $name]
    return $exe
}

proc getDirName { prg } {
    file dirname $prg
}

proc getSystemDir {} {
    global env
    switch -- [get_os_version] {
        "Windows 95" -
        "Windows 98" -
	"Windows Me" {
            set sysDir $env(windir)/system
        }
	default {
            set sysDir $env(SystemRoot)/system32
        }
    }
    return $sysDir
}

########################################################################
#
# loadList / saveList
#
#   loadList - load list of wrapped executables from $configFile
#   saveList - save list of wrapped executables into $configFile
#

proc loadList {} {

    global configFile configBack

    if { [file exists $configFile] } {
        file copy -force $configFile $configBack
    }

    set aList {}
    set fd [open $configFile {CREAT RDONLY}]
    while { ! [eof $fd]} {
        set line [gets $fd]
	if { [string length $line] > 0} {
            lappend aList "$line"
        }
    }
    close $fd
    return $aList
}

proc saveList { aList } {
    global configFile
    file delete -force $configFile
    set fd [open $configFile {CREAT WRONLY}]
    foreach e $aList {
        puts $fd $e
    }
    close $fd
}

########################################################################
#
# putList / getList - set/get list to/from listbox
#

proc putList { lb aList } {
    foreach e $aList {
        $lb insert end $e
    }
}

proc getList { lb } {
    $lb get 0 end
}

########################################################################
#
# checkList / appendList / deleteList - check / append / delete program from/to listbox
#

proc checkList { lb prg } {
    set cnt 0
    set lst [getList $lb]
    
    foreach n $lst {
        if { [string compare $prg $n] == 0 } {
	    incr cnt
        }
    }
    return $cnt
}

proc appendList { lb prg } {

    if {  [checkList $lb $prg] == 0 } {
        $lb insert end $prg
    }
}

proc deleteList { lb prg } {
    set cnt 0
    set lst [getList $lb]

    foreach n $lst {
        if { [string compare $n $prg] == 0 } {
	    $lb delete $cnt
        }
	incr cnt
    }
}

########################################################################
#
# registry operations
#

proc regGetEncode { prg } {

    global  perprogKey perprogEnc perprogDef

    if { [string compare $prg "" ] == 0 } {
        return $perprogDef
    }

    if {![isWindows]} {
        return $perprogDef
    }
    package require registry 1.0
    
    set name [getExeName $prg]
    set key $perprogKey$name

    if { [catch {set enc [registry get $key $perprogEnc]} err] } {
        return $perprogDef
    }
    if { [string compare $enc ""] == 0 } {
        return $perprogDef
    }
    return $enc
}

proc regSetEncode { prg enc } {

    global  perprogKey perprogEnc perprogDef

    if {![isWindows]} {
        return 1
    }

    package require registry 1.0

    set name [getExeName $prg]
    set key $perprogKey$name

    if { [string compare $enc $perprogDef] == 0 } {
        set enc ""
    }
    if { [catch {registry set $key $perprogEnc $enc sz} ] } {
        return 2
    }
    return 0
}

proc regGetLogLevel {} {
    global serverKey serverLogLevel serverLogLevelDef
    regGetValue $serverKey $serverLogLevel $serverLogLevelDef
}

proc regSetLogLevel {level} {
    global serverKey serverLogLevel
    regSetValue $serverKey $serverLogLevel $level dword
}

proc regGetLogFile {} {
    global serverKey serverLogFile serverLogFileDef
    set file [regGetValue $serverKey $serverLogFile $serverLogFileDef]
    if {[catch {file attributes $file -longname} lfile]} {
	# Maybe $file doesn't exist (yet).  Get the longname of
	# directory portion.
	set dir [file dirname $file]
	if {[catch {file attributes $dir -longname} ldir]} {
	    set ldir $dir
	}
	set lfile [file join $ldir [file tail $file]]
    }
    file nativename $lfile
}

proc regSetLogFile {file} {
    global serverKey serverLogFile
    regSetValue $serverKey $serverLogFile [file nativename $file]
}

proc regGetConfFile {} {
    global serverKey serverConfFile
    set file [regGetValue $serverKey $serverConfFile {}]
    if {[string compare $file {}] == 0} {
	return {}
    }
    if {[catch {file attributes $file -longname} lfile]} {
	# Maybe $file doesn't exist (yet).  Get the longname of
	# directory portion.
	set dir [file dirname $file]
	if {[catch {file attributes $dir -longname} ldir]} {
	    set ldir $dir
	}
	set lfile [file join $ldir [file tail $file]]
    }
    file nativename $lfile
}

proc regSetConfFile {file} {
    global serverKey serverConfFile
    regSetValue $serverKey $serverConfFile [file nativename $file]
}

proc regGetWhere {} {
    global serverKey
    regGetValue $serverKey Where 0
}

proc regSetWhere {where} {
    global serverKey
    regSetValue $serverKey Where $where dword
}

proc regGetValue {key name default} {
    if {![isWindows]} {
	puts "--regGetValue $key $name"
        return $default
    }
    package require registry 1.0
    
    if {[catch {registry get $key $name} value]} {
        return $default
    }
    if {[string compare $value {}] == 0} {
        return $default
    }
    return $value
}

proc regSetValue {key name value {type sz}} {
    if {![isWindows]} {
	puts "--regSetValue $key $name $value"
        return 1
    }

    package require registry 1.0

    if {[catch {registry set $key $name $value $type}]} {
        return 2 
    }
    return 0
}

########################################################################
#
# install / uninstall DLL s
#

proc fileInstall { prg } {

    global env
    global filesCpy11 filesCpy20
    
    if {![isWindows]} {
        return 1
    }

    switch -- [get_os_version] {
        "Windows 95" -
        "Windows 98" -
	"Windows Me" {
            set winDir $env(windir)
    	    set sysDir $winDir/system
	    set filesCpy $filesCpy11
	}
	default {
            set winDir $env(SystemRoot)
            set sysDir $winDir/system32
	    set filesCpy $filesCpy20
        }
    }

    set toDir [getDirName $prg ]

    foreach n $filesCpy {
        file copy -force $n $toDir
    }
    return 0
}

proc fileRemove { prg } {
    
    global filesDel11 filesDel20
    
    if {![isWindows]} {
        return 1
    }

    switch -- [get_os_version] {
        "Windows 95" {
	    set filesDel $filesDel11
	}
        "Windows 98" -
	"Windows Me" {
	    set filesDel $filesDel20
        }
	default {
	    set filesDel $filesDel20
        }
    }

    set fromDir [getDirName $prg ]

    foreach n $filesDel {
        file delete -force $fromDir/$n
    }
    return 0
}

########################################################################
#
# Wrap/Unwrap program
#

proc execWrap { pw lb dlg prg enc } {

    set prgName [$prg get]
    set encName [$enc get]

    # Make sure the program name is not empty
    if {[string compare $prgName {}] == 0} {
	confErrorDialog $dlg "Program must be specified.\nClick \"Browse..\" button for browsing."
	return
    }

    # It is dangerous to wrap programs in the system directory.
    set prgdir [file nativename [getDirName $prgName]]
    set sysdir [file nativename [getSystemDir]]
    if {[string compare -nocase $prgdir $sysdir] == 0} {
	tk_messageBox -icon error -type ok -title "Directory Error" \
		-parent $dlg \
		-message "Cannot wrap applications in the system directory.\nPlease copy the EXE file to elsewhere and wrap the copied one."
	destroy $dlg
	return 1
    }

    # Okay, copy the wrapper DLLs.
    if { [fileInstall $prgName] } {
        tk_messageBox -icon warning -type ok \
	              -title "Warning" \
	              -message "Cannot install DLLs" \
		      -parent $dlg
        destroy $dlg
	return 1
    }
    if { [regSetEncode $prgName $encName] } {
        tk_messageBox -icon warning -type ok \
	              -title "Warning" \
	              -message "Cannot set encoding" \
		      -parent $dlg
        fileRemove $prgName
        destroy $dlg
	return 2
    }

    # if local flag is on, create $prgName.local.
    global local_dll
    if {$local_dll} {
	create_dot_local $prgName $dlg
    } else {
	remove_dot_local $prgName $dlg
    }

    if { [checkList $lb $prgName] == 0 } {
        appendList $lb $prgName
    }
    saveList [getList $lb]
    destroy $dlg
}

proc execUnwrap { pw lb dlg prg } {

    set prgName [$prg get]
    
    if {[support_dll_redirection] && [file exists $prgName.local]} {
	set ans [tk_messageBox -icon question -type yesno \
			-title "Confirmation" \
			-message "Also remove $prgName.local file?" \
			-parent $dlg]
	if {[string compare $ans yes] == 0} {
	    remove_dot_local $prgName $dlg
	}
    }

    if { [checkList $lb $prgName] == 1 } {
        fileRemove $prgName
    }
    deleteList $lb $prgName