# -*- tcl -*-
# Library to support the ActiveTcl installer scripts.
# Contains the common functionality. Its first action is to load the
# data file containing distribution/release dependent information.

source [file join $::SCRIPT_DIR install_data.tcl]

if {0} {
    rename exit __exit
    proc exit {{status 0}} {
	puts "[info level 2]: Exiting with $status"
	__exit $status
    }
}

if {
    $::AT(MATURITY) != "stable" &&
    $::AT(MATURITY) != "final"
} {
    set ::AT(MVERSION) "$::AT(VERSION) $::AT(MATURITY)"
} else {
    set ::AT(MVERSION) $::AT(VERSION)
}

# Compatibility code to make this library useable for already
# distributed releases.

if {![info exists ::AT(tcl_VERSION)]} {set ::AT(tcl_VERSION) [info tclversion]}
if {![info exists ::AT(DEBUG)]}       {set ::AT(DEBUG) 0}
if {![info exists ::AT(TDK_ATVERS)]}  {set ::AT(TDK_ATVERS) 8.3.5.0}

set AT(ND_VER) [string map {. ""} $::AT(tcl_VERSION)]

if {$AT(DEBUG)} {
    set AT(ND_VERG) $AT(ND_VER)g
    set wish_exe wishg.exe
    append AT(dPGROUP) " Debug"
} else {
    set AT(ND_VERG) $AT(ND_VER)
    set wish_exe wish.exe
}

## Determine if we are a version of the TDK containing the new 'Tcl
## App' application. If yes, this also means that all the tools are
## starkits, and that their executable names have changed because of
## this (.tcl instead of .exe).

## Note aside: On unix we are patching the starkits to contain the
## absolute path of the installed tclsh. This means that the tools
## will work even if the PATH is not set. On windows we simply rely on
## the association for '.tcl'.

set HAVE_TCLAPP 0
if {[file exists [file join $::SCRIPT_DIR bin tclapp.tcl]] ||
    [file exists [file join $::SCRIPT_DIR bin tclapp]]} {
    set HAVE_TCLAPP 1
}


set INSTALL_MODE admin ; # Common installation is default.

# ======================================================================

# Return license text
#
proc license_text {} {
    set fh [open [file join $::SCRIPT_DIR license.terms]]
    set data [read $fh]
    close $fh
    return $data
}

# Return overinstall warning
#
proc overinstall_warning {} {
    return "WARNING:
You are about to install $::AT(dPGROUP) $::AT(MVERSION) in a directory
containing an installation of $::AT(dPGROUP) v$::AT(InstVersion).

Choose 'Next' to install over the existing files.
Choose 'Back' to select a different installation directory."
}

# Return message on finish
#
# unix		\/ normal, lite, pro
# windows	/\

array set ::PARTING {}

set ::PARTING(unix) {Please do not forget to extend your PATH and MANPATH variables to
get access to the applications and manpages distributed with @name@.

For a csh or compatible perform
    setenv PATH "@idir@/bin:$PATH"

For a sh or similar perform
    PATH="@idir@/bin:$PATH"
    export PATH

Some shells (bash for example) allow
    export PATH="@idir@/bin:$PATH"

Similar changes are required for MANPATH}

set ::PARTING(windows) {}

proc parting_message {} {
    # The parting message depends on the platform.

    set key $::tcl_platform(platform)

    if {![info exists ::RUNTIME_DIR]} {
	set ::RUNTIME_DIR "<installDirectory>"
    }
    return [string map [list \
	    @name@ $::AT(NAME) \
	    @idir@ $::RUNTIME_DIR \
	    ] $::PARTING($key)]
}

proc hype_message {} {
    if {![string equal $::AT(MODE) normal]} {return}
    log  { }
    log  {  }                                                                hype
    log  {  Serious about Programming in Tcl ?}                             {hype heading}
    log  {  }                                                                hype
    log* {  Get }                                                            hype
    log*        {ASPN Tcl}                                                  {hype emphasis}
    log                 {, the essential package for Tcl}                    hype
    log* {  programmers. }                                                   hype
    log*                {ASPN Tcl}                                          {hype emphasis}
    log                         { combines everything you}                   hype
    log  {  need in a single, high-value bundle, including advanced}         hype
    log  {  Tcl programming technologies and in-depth resource information.} hype
    log  {  }                                                                hype
    log  {  Find out more:}                                                  hype
    log* {    }                                                              hype
    log*      { http://www.ActiveState.com/ASPN/About/Tcl }                 {hype url}
    log                                               { }                    hype
    log  {  }                                                                hype
}


# df -- Determine available free space for a directory.
#
# Returns value in KB as a double.
#
proc df {{dir .}} {
    # Force the result to be a double, to allow 51 bits of int precision
    # and not error on large disk allocations
    switch $::tcl_platform(os) {
	FreeBSD - Linux - OSF1 - SunOS {
	    # Bugfix: If the path in an entry is too long SunOS splits
	    # the entry into two lines, one containing the path, the
	    # other containing the remainder of the information. This
	    # means that every in the last line moves one index to the
	    # front and index 3 refers to the percentage instead of
	    # the available space. Our fix is to count the elements
	    # from the end, as the available space is the third one
	    # from the end, and this idnex does not change when an
	    # entry is split into two lines.

	    return [lindex [lindex [split [exec df -k $dir] \n] end] end-2].0
	}
	HP-UX {
	    return [lindex [lindex [split [exec bdf   $dir] \n] end] 3].0
	}
	AIX {
	    return [lindex [lindex [split [exec df -k $dir] \n] end] 2].0
	}
	{Windows NT} - {Windows 95} {
	    catch {
		set dir [file nativename $dir]
		set res [eval exec [auto_execok dir] [list $dir]]
		set line [lindex [split $res "\n"] end]
		if {[regexp -nocase {([0-9,\.]+)\s+(bytes|KB|MB)\s+} \
			$line -> size type]} {
		    set size [string map {, {}} $size]
		    switch $type {
			MB - mb { return [expr {$size * 1000.0}] }
			KB - kb { return [expr {double($size)}] }
			BYTES - bytes {
			    if {[string match {*.*} $size]} {
				return [expr {$size / 1024.0}]
			    } else {
				# has to be unbraced to allow .0 conversion to
				# double trick to work (allow 51 bit int prec)
				return [expr $size.0 / 1024.0]
			    }
			}
		    }
		} else {
		    error "Unable to extract free space for $dir from output of 'dir'"
		}
	    }
	    # Some error occured, assume we have at least 100MB
	    return 100000.0
	}
	default {error "Unable to get disk free space on $::tcl_platform(os)"}
   }
}

# Determine the used space for a directory.
#
proc du {{dir .}} {
    switch -glob $::tcl_platform(os) {
	FreeBSD - Linux - OSF1 - SunOS - HP-UX - AIX {
	    return [lindex [exec du -sk $dir] 0]
	}
	"Windows*" {
	    # Just say we need 25MB
	    return 25000
	}
	default {error "Unable get disk usage on $::tcl_platform(os)"}
    }
}

# Check if enough space for $src dir exists in $dest dir
# Returns 0 on OK, otherwise space required
#
proc need_space {src dest} {
    set need [du $src]
    set have [df $dest]
    return [expr {($need > $have) ? $need : 0}]
}

proc check_installdir_basic {installdir} {
    global INSTALL_MODE tcl_platform

    if {[string equal {} $installdir]} {
	set installdir [default_installdir]
	set errmsg "Please choose a non-empty directory name."
	return [list $installdir $errmsg]
    }

    # Change the directory into an absolute path for better comparison
    # later.

    set installdir [file join [pwd] $installdir]

    # Check installation dir for existence and correct type.

    if {[file exists $installdir] && ![file isdirectory $installdir]} {
	set errmsg "The chosen path \"$installdir\" is not a directory.\
		\nPlease choose a directory."
	return [list $installdir $errmsg]
    } elseif {[string equal $installdir $::SCRIPT_DIR]} {
	set errmsg "You are trying to install $::AT(dPGROUP) over the directory\
		\ncontaining the distributed files. This is not allowed.\
		\nPlease choose a different directory."
	return [list $installdir $errmsg]
    } elseif {[inside_distribution $installdir]} {
	set errmsg "You are trying to install $::AT(dPGROUP) inside of the directory\
		\ncontaining the distributed files. This is not allowed.\
		\nPlease choose a different directory."
	return [list $installdir $errmsg]
    }

    return [list $installdir {}]
}

proc check_installdir_post {installdir} {
    set errmsg ""
    if {[catch {
	set pwd [pwd]
	if {![file exists $installdir]} { file mkdir $installdir }
	cd $installdir
	set installdir [pwd]
	cd $pwd
    } err]} {
	set errmsg "Invalid directory choice: $err.\
		\nPlease choose another directory."
    } elseif {![file writable $installdir]} {
	set errmsg "Cannot write to directory \"$installdir\".\
		\nPlease choose another directory."
    } elseif {[set need [need_space $::SCRIPT_DIR $installdir]]} {
	# Check of the available space for the chosen directory against
	# our requirements. Instead of using a fixed requirement we
	# query the unpacked archive for its size. 

	# The check is conservative as it counts the demos as part of
	# the requirements even if they will be installed in a
	# different location.
	set errmsg "The chosen path \"$installdir\" does not provide\
		\nenough space for the installation of $::AT(dPGROUP).\
		\n\nPlease choose a directory with at least ${need}K\
		available space.\n"
    }

    return [list $installdir $errmsg]
}


proc check_installdir {installdir} {
    set ::AT(InstVersion) ""
    set errmsg ""

    foreach {dir msg} [check_installdir_basic $installdir] break
    if {$msg != {}} {return [list $dir $msg]}

    set installdir $dir

    # Check installation dir for existence and correct type.

    if {[file exists $installdir]} {
	# Code executed for ActiveTcl and full Tcl/DevKit installation.

	if {[string equal $::AT(MODE) normal]} {
	    # Look for an existing installation in the chosen directory.
	    # Issue a warning even if overwriting is allowed.

	    # NOTE: We allow the installation of ActiveTcl even if the
	    # chosen directory contains a Tcl/DevKit installation. This
	    # allows the user/customer to replace the ActiveTcl part
	    # of a Tcl/DevKit installation with an updated version.

	    if {
		[contains_activetcl_installation $installdir] &&
		![overinstall_allowed]
	    } {
		set errmsg "The chosen directory contains a newer installation\
			\nof $::AT(dPGROUP) ($::AT(InstVersion)).\
			\nPlease choose a different directory."
		return [list $installdir $errmsg]
	    }
	} else {
	    # Look for an existing installation in the chosen directory.
	    # Issue a warning even if overwriting is allowed.

	    # NOTE: We allow the installation of a full Tcl/DevKit even if the
	    # chosen directory contains an ActiveTcl installation. This
	    # allows the user/customer to upgrade to Tcl/DevKit while
	    # simultaneously (possibly) upgrading the ActiveTcl
	    # part. There is no need to force the user to use the
	    # Upgrade Kit in this case. It is less efficient regarding
	    # download time and required disk space, but well, that is
	    # the users choice.

	    if {
		[contains_tdk_installation $installdir] &&
		![overinstall_allowed]
	    } {
		set errmsg "The chosen directory contains a newer installation\
			\nof $::AT(dPGROUP) ($::AT(InstVersion)).\
			\nPlease choose a different directory."
		return [list $installdir $errmsg]
	    }
	}
    }

    return [check_installdir_post $installdir]
}

proc check_installdir_lite {installdir} {
    # Code executed for Tcl/DevKit Upgrade Kit

    set ::AT(InstVersion) ""
    set errmsg ""

    foreach {dir msg} [check_installdir_basic $installdir] break
    if {$msg != {}} {return [list $dir $msg]}

    set installdir $dir

    # Check installation dir for existence and correct type.

    if {[file exists $installdir]} {

	# Look for an existing installation in the chosen directory.
	# If there is none the installation of lite (= upgrade) is
	# _not_ allowed.

	if {[contains_tdk_installation $installdir]} {
	    set errmsg "$::AT(NAME) $::AT(InstVersion) is already installed.\
		    \nIt is not possible to install\
		    $::AT(NAME) $::AT(MVERSION).\n\n"
	    return [list $installdir $errmsg]
	} elseif {![contains_activetcl_installation $installdir]} {
	    set errmsg "No installation of ActiveTcl found.\
		    \nIt is not possible to install\
		    $::AT(NAME) $::AT(MVERSION).\n\n"
	    return [list $installdir $errmsg]
	}

	# Check the installed version against ours to make sure
	# that the upgrade is possible.

	if {![package vsatisfies $::AT(InstVersion) 8.3.4.1]} {
	    set errmsg "You are currently using a previous install\
		    of ActiveTcl $::AT(InstVersion).\
		    \n\t(installed in $installdir)\
		    \n\n$::AT(NAME) $::AT(MVERSION) cannot be used\
		    with this installation.\nPlease install\
		    ActiveTcl 8.3.4.1 or higher."
	    return [list $installdir $errmsg]
	}
    }

    return [check_installdir_post $installdir]
}

proc inside_distribution {installdir} {
    set plen    [llength [file split $::SCRIPT_DIR]]
    set iprefix [eval [list file join] [lrange [file split $installdir] \
	    0 [incr plen -1]]]

    return [string equal $iprefix $::SCRIPT_DIR]
}

proc check_demodir {demodir} {
    set errmsg  ""
    if {$demodir == ""} {
	set demodir [default_demodir $::INSTALL_DIR]
	set errmsg "Please choose a non-empty directory name."
    } elseif {[file exists $demodir] && ![file isdirectory $demodir]} {
	# Check of installation dir for existence and correct type.
	set errmsg "The chosen path \"$demodir\" is not a directory.\
		\nPlease choose a directory."
    } elseif {[catch {
	set pwd [pwd]
	if {![file exists $demodir]} { file mkdir $demodir }
	cd $demodir
	set demodir [pwd]
	cd $pwd
    } err]} {
	set errmsg "Invalid directory choice: $err.\
		\nPlease choose another directory."
    } elseif {![file writable $demodir]} {
	set errmsg "Cannot write to directory \"$demodir\".\
		\nPlease choose another directory."
    } elseif {[set need [need_space [file join $::SCRIPT_DIR demos] $demodir]]} {
	# Check the available space for the chosen directory against
	# our requirements. Instead of using a fixed requirement we
	# query the unpacked archive for its size. 
	set errmsg "The chosen path \"$demodir\" does not provide\
		\nenough space for the installation of demo scripts.\
		\n\nPlease choose a directory with at least ${need}K\
		available space.\n"
    }

    return [list $demodir $errmsg]
}

proc check_runtimedir {runtimedir} {
    set errmsg  ""
    if {$runtimedir == ""} {
	set runtimedir $::INSTALL_DIR
	set errmsg "Please choose a non-empty directory name."
    } elseif {[file exists $runtimedir] && ![file isdirectory $runtimedir]} {
	# Check of installation dir for existence and correct type.
	set errmsg "The chosen path \"$runtimedir\" is not a directory.\
		\nPlease choose a directory."
    } elseif {[catch {
	set pwd [pwd]
	cd $runtimedir
	set runtimedir [pwd]
	cd $pwd
    } err]} {
	set errmsg "Invalid directory choice: $err.\
		\nPlease choose another directory."
    }

    return [list $runtimedir $errmsg]
}

proc default_installdir {} {
    if {[string equal "windows" $::tcl_platform(platform)]} {
	return "C:/Tcl"
    } else {
	return "/usr/local/ActiveTcl"
    }
}

proc default_demodir {installdir} {
    return [file join $installdir demos]
}

proc install_log {msg} {
    if {[info exists ::INSTALL_DIR]} {
	if {![info exists ::INSTALL_LOG]} {
	    global INSTALL_MODE

	    # Initialize the directory to contain the log and the uninstall application
	    set logdir [file dirname $::INSTALL_DIR/$::AT(LOG)]
	    if {![file exists $logdir/$::AT(UNINSTALLER)]} {
		file mkdir $logdir
		file copy $::SCRIPT_DIR/$::AT(UNINSTALLER) $logdir/$::AT(UNINSTALLER)
	    }
	    set ::INSTALL_LOG [open $::INSTALL_DIR/$::AT(LOG) w]
	    puts $::INSTALL_LOG "# -*- tcl -*- $::AT(LOG) v1.0\
		    \n# DO NOT DELETE THIS FILE.\
		    \n# It is needed by the uninstaller to clean up properly.\
		    \n# Installed on [clock format [clock seconds]]\n"

	    # Remember information about the type of installation
	    # (common / personal, admin rights).

	    puts $::INSTALL_LOG [list INSTALLTYPE $INSTALL_MODE]

	    # Fake the create entries for the directory containing the log file.
	    set d $logdir
	    set ndir [file nativename $::INSTALL_DIR]
	    while {![string equal [file nativename $d] $ndir]} {
		puts $::INSTALL_LOG [list MKDIR $d]
		set d [file dirname $d]
	    }
	    puts $::INSTALL_LOG [list FILECOPY $::INSTALL_DIR/$::AT(LOG)]
	    puts $::INSTALL_LOG [list FILECOPY $logdir/$::AT(UNINSTALLER)]

	}
	puts $::INSTALL_LOG $msg
    }
}

proc install_all {srcdir installdir {srcrelative {}}} {
    # Assumes existence of a [log] command.

    if {![file exists $installdir]} {
	log "\tCreating directory $installdir ..."
	file mkdir $installdir
    }
    # Note in the install log that we "made" the directory in either case,
    # so it will try to delete that directory if it is empty.
    install_log [list MKDIR $installdir]

    ## For the lite distribution we must neither install
    ## lib/tcl8.3/... nor lib/tk8.3/... nor lib/bwidget* nor lib/reg*

    if {
	[string equal $::AT(MODE) lite] &&
	([string equal $srcrelative lib/tcl$::AT(tcl_VERSION)] ||
	 [string equal $srcrelative lib/tk$::AT(tcl_VERSION)] ||
	 [string match lib/bwidget* $srcrelative] ||
	 [string match lib/reg* $srcrelative] ||
	 [string match lib/dde* $srcrelative])
    } {
	#log SKIP $srcdir
	return
    }

    foreach f [glob -nocomplain -directory $srcdir -types {f l} *] {
	#log "\t[file join $installdir [file tail $f]] ..."
	if {[catch {
	    file copy -force $f $installdir
	    install_log [list FILECOPY \
		    [file join $installdir [file tail $f]]]
	} err]} { log $err error }
    }

    foreach dir [glob -nocomplain -directory $srcdir -type d *] {
	set tail [file tail $dir]
	set inst [file join $installdir $tail]

	install_all $dir $inst [file join $srcrelative $tail]
    }
}

proc patch_tools {installdir} {
    # We can savely skip this action if the distribution does not
    # contain starkits, or doesn't need patching (platform).

    if {!$::HAVE_TCLAPP}                   {return}
    if {[string equal $::AT(MODE) normal]} {return}
    if {[string equal "windows" $::tcl_platform(platform)]} {return}

    set files [list]
    lappend files [file join $installdir bin tclapp]
    lappend files [file join $installdir bin tape]
    lappend files [file join $installdir bin procomp]
    lappend files [file join $installdir bin procheck]
    lappend files [file join $installdir bin proinspect]
    lappend files [file join $installdir bin prodebug]

    ## Launcher is windows only
    ## lappend files [file join $installdir bin prolaunch]

    # Now perform the patching.
    foreach f $files {
	log "*  $f ..."
	patch_kit $f tclsh [file join $installdir bin tclsh]
    }
}

proc patch_kit {kit word new} {
    # Replaces the first occurence of 'word' with 'new', in the header
    # (!) of the specified star'kit'.
    #
    # Unix-only!

    set tmpfile [pid].[file tail $kit]
    set out [open $tmpfile w]
    set in  [open $kit r]

    while {1} {
	gets $in line
	if {[set start [string first ${word} $line]] >= 0} {
	    set end [expr {$start + [string length $word]}]
	    incr start -1
	    puts -nonewline $out [string range $line 0 $start]

	    # Bugzilla 23548. Quote to handle spaces in the path.
	    puts -nonewline $out \"$new\"

	    puts            $out [string range $line $end end]
	    break
	}
	puts $out $line
    }
    fconfigure $out -encoding binary -translation binary
    fconfigure $in  -encoding binary -translation binary
    fcopy $in $out
    close $in
    close $out
    file copy -force $tmpfile $kit
    file delete $tmpfile

    if {[string equal $::tcl_platform(platform) windows]} {
	file attributes $kit -readonly 0
    } else {
	file attributes $kit -permissions 0755
    }
    return
}



proc patch_tut {} {
    if {![string equal $::AT(MODE) normal]} {
	## Patch project files in debugger tutorial code.
	## Pro and lite only.

	## In lite the demos are not present, hence nocomplain to prevent
	## the installer from balking.

	set demodir [file join $::DEMO_DIR TclDevKit cover]

	if {[string equal "windows" $::tcl_platform(platform)]} {
	    set exeext .exe
	} else {
	    set exeext ""
	}
	if {$::AT(DEBUG)} {
	    set exeext g$exeext
	}

	set files [glob -nocomplain [file join $demodir mult *.tpj]]
	foreach f $files {
	    log "*  $f ..."
	    patch_file_simple $f @demodir@    $::DEMO_DIR
	    patch_file_simple $f @installdir@ $::RUNTIME_DIR
	    patch_file_simple $f @exeext@     $exeext
	}
	set files [glob -nocomplain [file join $demodir csv *.tpj]]
	foreach f $files {
	    log "*  $f ..."
	    patch_file_simple $f @demodir@    $::DEMO_DIR
	    patch_file_simple $f @installdir@ $::RUNTIME_DIR
	    patch_file_simple $f @exeext@     $exeext
	}

	set files [glob -nocomplain [file join $::DEMO_DIR BWidgets *.tpj]]
	foreach f $files {
	    log "*  $f ..."
	    patch_file_simple $f @demodir@    $::DEMO_DIR
	    patch_file_simple $f @installdir@ $::RUNTIME_DIR
	    patch_file_simple $f @exeext@     $exeext
	    patch_file_simple $f @arch@       $::AT(ARCH)
	}

	if {$::HAVE_TCLAPP} {
	    set          files [glob -nocomplain [file join $::DEMO_DIR Img *.tpj]]
	    eval lappend files [glob -nocomplain [file join $::DEMO_DIR TclDevKit klondike *.tpj]]
	    eval lappend files [glob -nocomplain [file join $::DEMO_DIR Tkcon *.tpj]]
	    set tclext ""
	    if {[string equal "windows" $::tcl_platform(platform)]} {
		set tclext .tcl
	    }
	    foreach f $files {
		log "*  $f ..."
		patch_file_simple $f @demodir@    $::DEMO_DIR
		patch_file_simple $f @installdir@ $::RUNTIME_DIR
		patch_file_simple $f @exeext@     $exeext
		patch_file_simple $f @arch@       $::AT(ARCH)
		patch_file_simple $f @tclext@     $tclext
	    }
	}
    }
    return
}


proc placeholder {} {
    # Copied from make-active.tcl
    set longfakepath __________                                                        ; #  10
    set longfakepath $longfakepath$longfakepath$longfakepath$longfakepath$longfakepath ; #  50
    set longfakepath $longfakepath$longfakepath                                        ; # 100
    set longfakepath $longfakepath$longfakepath$longfakepath$longfakepath              ; # 400
    set longfakepath @$longfakepath@
    return $longfakepath
}

proc patch_shells {srcdir installdir runtimedir} {
    # No patching of anything for the lite applications.
    # WRONG. This was introduced in rev 40, but is wrong. We have to
    # patch the distributed proshells and wrapstubs like for the pro
    # distribution. Conditialize each section separately.
    ## if {[string equal $::AT(MODE) lite]} {return} ##

    set longfakepath [placeholder]

    # Check string sizes before trying to patch.

    if {[string length $installdir] > [string length $longfakepath]} {
	log "Can't patch shells and libraries, new path to long"
	return
    }

    set files [list]

    if {![string equal $::AT(MODE) lite]} {
	if {$::AT(DEBUG)} {
	    lappend files [file join $installdir bin tclshg]
	    lappend files [file join $installdir bin wishg]
	} else {
	    lappend files [file join $installdir bin tclsh]
	    lappend files [file join $installdir bin wish]
	}

	# We installed versioned variants of the shells too, so patch them also
	foreach f [glob -nocomplain [file join $installdir bin tclsh\[0-9\]*]] {
	    lappend files $f
	}
	foreach f [glob -nocomplain [file join $installdir bin wish\[0-9\]*]] {
	    lappend files $f
	}
    }

    if {"$::tcl_platform(os)" == "AIX"} {
	foreach f $files {
	    log "*  $f ..."
	    patch_aix_file $f $longfakepath [file join $runtimedir lib]
	}
    } elseif {"$::tcl_platform(os)" == "HP-UX"} {
	foreach f $files {
	    log "*  $f ..."
	    patch_file $f $longfakepath \
		    [file join $runtimedir lib] \
		    [file join $runtimedir lib tcl$::AT(tcl_VERSION)]
	}
    } else {
	foreach f $files {
	    log "*  $f ..."
	    patch_file $f $longfakepath [file join $runtimedir lib]
	}
    }

    set files [list]
    if {![string equal $::AT(MODE) lite]} {
	foreach f [glob -nocomplain [file join $installdir lib libtcl\[0-9\]*.so]] {
	    lappend files $f
	}
	foreach f [glob -nocomplain [file join $installdir lib libtcl\[0-9\]*.sl]] {
	    lappend files $f
	}
    }

    # Refixing 18606. The change reintroduced the problem.
    # Note: The static files are present only in the normal and pro
    # distributions (= Tcl/DevKit), but not for lite.

    foreach f [glob -nocomplain [file join $installdir lib libtcl\[0-9\]*.a]] {
	lappend files $f
    }

    ### The patching of the main tcl library is different between 8.3 and 8.4.
    ### And also special for HP.

    if {("$::tcl_platform(os)" == "HP-UX")} {
	foreach f $files {
	    log "*  $f ..."
	    patch_file $f $longfakepath \
		    [file join $runtimedir lib] \
		    [file join $runtimedir lib tcl$::AT(tcl_VERSION)] \
		    [file join $runtimedir lib tcl$::AT(tcl_VERSION)]
	}
    } elseif {
	("$::tcl_platform(os)" == "AIX") &&
	[package vsatisfies $::AT(tcl_VERSION) 8.4]
    } {
	# Patching 8.4 & AIX
	foreach f $files {
	    log "*  $f A..."
	    patch_aixlib_file $f $longfakepath \
		    [file join $runtimedir lib] \
		    [file join $runtimedir lib tcl$::AT(tcl_VERSION)] \
		    [file join $runtimedir lib]
	}
    } elseif {
	("$::tcl_platform(os)" == "AIX") ||
	[package vsatisfies $::AT(tcl_VERSION) 8.4]
    } {
	# Patching 8.4
	foreach f $files {
	    log "*  $f ..."
	    patch_file $f $longfakepath \
		    [file join $runtimedir lib] \
		    [file join $runtimedir lib tcl$::AT(tcl_VERSION)] \
		    [file join $runtimedir lib]
	}
    } else {   
	# Patching 8.3
	foreach f $files {
	    log "*  $f ..."
	    patch_file $f $longfakepath \
		    [file join $runtimedir lib tcl$::AT(tcl_VERSION)] \
		    [file join $runtimedir lib]
	}
    }

    set files [list]
    if {![string equal $::AT(MODE) lite]} {
	foreach f [glob -nocomplain [file join $installdir lib libtk\[0-9\]*.so]] {
	    lappend files $f
	}
	foreach f [glob -nocomplain [file join $installdir lib libtk\[0-9\]*.sl]] {
	    lappend files $f
	}
    }

    # Refixing 18606. The change reintroduced the problem.
    # Note: The static files are present only in the normal and pro
    # distributions (= Tcl/DevKit), but not for lite

    foreach f [glob -nocomplain [file join $installdir lib libtk\[0-9\]*.a]] {
	lappend files $f
    }

    if {"$::tcl_platform(os)" == "AIX"} {
	foreach f $files {
	    log "*  $f ..."
	    patch_aix_file $f $longfakepath [file join $runtimedir lib]
	}
    } else {
	foreach f $files {
	    log "*  $f ..."
	    patch_file $f $longfakepath [file join $runtimedir lib]
	}
    }

    # Pro and Lite distributions. Look for the wrapstubs and proshells.

    if {[string equal pro $::AT(MODE)] || [string equal lite $::AT(MODE)]} {
	set files [list]
	if {!$::HAVE_TCLAPP} {
	    lappend files [file join $installdir bin protclsh]
	    lappend files [file join $installdir bin prowish]

	    lappend files [file join $installdir bin procomp]
	    lappend files [file join $installdir bin prowrap]
	    lappend files [file join $installdir bin procheck]
	    lappend files [file join $installdir bin proinspect]
	    lappend files [file join $installdir bin prodebug]
	    ## Launcher is windows-only
	    ## lappend files [file join $installdir bin prolaunch]

	    # We installed versioned variants of the shells too, so patch them also
	    foreach f [glob -nocomplain [file join $installdir bin protclsh\[0-9\]*]] {
		lappend files $f
	    }
	    foreach f [glob -nocomplain [file join $installdir bin prowish\[0-9\]*]] {
		lappend files $f
	    }

	    # Only the static stubs here!
	    foreach f [glob [file join $installdir lib wrap*s.in]] {
		lappend files $f
	    }
	}
	foreach f $files {
	    log "*  $f ..."
	    patch_file $f $longfakepath \
		    [file join $runtimedir lib] \
		    [file join $runtimedir lib tcl$::AT(tcl_VERSION)] \
		    [file join $runtimedir lib]
	}

	# Bugzilla item 19001 ...
	# The remaining stubs are the dynamic stubs. Patching them is
	# slightly different. Reason: Only the search path to their
	# dynamic libraries has to be set by us. Now path for the
	# script library and such.

	set files [list]
	if {!$::HAVE_TCLAPP} {
	    foreach f [glob [file join $installdir lib wrap*.in]] {
		lappend files $f
	    }
	}
	foreach f $files {
	    log "*  $f ..."
	    patch_file $f $longfakepath [file join $runtimedir lib]
	}

    }

    ## Bugzilla item 18950
    ## Patch the *Config.sh files too, added by Steve.Cassidy@mq.edu.au

    if {![string equal $::AT(MODE) lite]} {
	set files [list]
	foreach f [glob [file join $installdir lib *Config.sh]] {
	    lappend files $f
	}
	foreach f $files {
	    log "*  $f ..."
	    patch_text_file $f $longfakepath $installdir
	}
    }
    return
}

proc patch_text_file {file key value} {
    ## patch a text file mapping $key to $value
    ## log "   - [list $key | $value]"

    if {[string equal $::tcl_platform(platform) windows]} {
	file attributes $file -readonly 0
    } else {
	file attributes $file -permissions u+w
    }

    set in  [open $file r]
    set out [open $file.tmp w]

    ## If the key contains backslashes (windows paths) match them
    ## literally!

    set key [string map [list \\ \\\\] $key]

    while {[gets $in line] >= 0} {
	regsub -all -- $key $line $value line
	puts $out $line
    }
    close $in
    close $out
    file rename -force $file.tmp $file
}

proc patch_file_simple {file key value} {
    set data [read [set fh [open $file r]]]
    close $fh

    set data [string map [list $key $value] $data]

    set              fh [open $file w]
    puts -nonewline $fh $data
    close           $fh
    return
}

proc patch_aixlib_file {file key valuea valueb valuec} {
    if {[string length $valuea] > [string length $key]} {
	log "Can't patch \"$file\", value too long"
	return
    }
    if {[string length $valueb] > [string length $key]} {
	log "Can't patch \"$file\", value too long"
	return
    }
    if {[string length $valuec] > [string length $key]} {
	log "Can't patch \"$file\", value too long"
	return
    }
    
    # Standard patching for first two values, A and B.
    # Special AIX patching for the last value, C.

    set  off [string length $valuea]
    incr off
    set valuea ${valuea}\000[string range $key $off end]

    set  off [string length $valueb]
    incr off
    set valueb ${valueb}\000[string range $key $off end]

    set  off [string length $valuec]
    incr off
    set valuec ${valuec}:[string range $key $off end]

    # Assert the equality of the lengths ...
    # Easier to do so here than to try and look and compare original
    # and patched binaries!

    if {[string length $key] != [string length $valuea]} {
	error "Extending the patch value a went wrong !!"
    }
    if {[string length $key] != [string length $valueb]} {
	error "Extending the patch value b went wrong !!"
    }
    if {[string length $key] != [string length $valuec]} {
	error "Extending the patch value c went wrong !!"
    }

    # Patch inplace ... (and make sure that we can!)
    # Read everything into memory, patch it, seek to beginning of file
    # and write the modifications back.

    if {[string equal $::tcl_platform(platform) windows]} {
	file attributes $file -readonly 0
    } else {
	file attributes $file -permissions u+w
    }

    set fh [open $file r+]
    fconfigure $fh -encoding binary -translation binary

    set data [read $fh]

    set  loc [string first $key $data]
    if {$loc >= 0} {
	set locb [expr {$loc + [string length $key]}]
	incr loc -1
	set data [string range $data 0 $loc]$valuea[string range $data $locb end]
    }
    set  loc [string first $key $data]
    if {$loc >= 0} {
	set locb [expr {$loc + [string length $key]}]
	incr loc -1
	set data [string range $data 0 $loc]$valueb[string range $data $locb end]
    }

    # Now map the third value.
    set data [string map [list $key $valuec] $data]

    seek $fh 0 start
    puts -nonewline $fh $data
    close $fh

    if {[string equal $::tcl_platform(platform) windows]} {
	file attributes $file -readonly 1
    } else {
	file attributes $file -permissions og-w
    }
    return

}

proc patch_aix_file {file key value} {
    if {[string length $value] > [string length $key]} {
	log "Can't patch \"$file\", value too long"
	return
    }

    # Extend the value so that it is as long as the key, use the
    # remainder of the key to do so. This is in preparation of the
    # in memory patching of all places containing the key.

    ### AIX is special in the shells. The place holder is followed
    ### by additional paths. We do not temrinate via \0, but use :
    ### to allow the loader to see the remainder of the list.

    set  off [string length $value]
    incr off
    set value ${value}:[string range $key $off end]

    # Assert the equality of the lengths ...
    # Easier to do so here than to try and look and compare original
    # and patched binaries!

    if {[string length $key] != [string length $value]} {
	error "Extending the patch value went wrong !!"
    }

    # Patch inplace ... (and make sure that we can!)
    # Read everything into memory, patch it, seek to beginning of file
    # and write the modifications back.

    if {[string equal $::tcl_platform(platform) windows]} {
	file attributes $file -readonly 0
    } else {
	file attributes $file -permissions u+w
    }

    set fh [open $file r+]
    fconfigure $fh -encoding binary -translation binary

    # Neither second nor third value. Map everything in one go.
    set data [string map [list $key $value] [read $fh]]



    seek $fh 0 start
    puts -nonewline $fh $data
    close $fh

    if {[string equal $::tcl_platform(platform) windows]} {
	file attributes $file -readonly 1
    } else {
	file attributes $file -permissions og-w
    }
    return
}


proc patch_file {file key value {valb {}} {valc {}}} {
    if {[string length $value] > [string length $key]} {
	log "Can't patch \"$file\", value too long"
	return
    }
    if {$valb != {}} {
	if {[string length $valb] > [string length $key]} {
	    log "Can't patch \"$file\", second value too long"
	    return
	}
    }
    if {$valc != {}} {
	if {[string length $valc] > [string length $key]} {
	    log "Can't patch \"$file\", third value too long"
	    return
	}
    }

    # Extend the value so that it is as long as the key, use the
    # remainder of the key to do so. This is in preparation of the
    # in memory patching of all places containing the key.

    set  off [string length $value]
    incr off
    set value $value\000[string range $key $off end]

    if {$valb != {}} {
	set  off [string length $valb]
	incr off
	set valb $valb\000[string range $key $off end]
    }
    if {$valc != {}} {
	set  off [string length $valc]
	incr off
	set valc $valc\000[string range $key $off end]
    }

    # Assert the equality of the lengths ...
    # Easier to do so here than to try and look and compare original
    # and patched binaries!

    if {[string length $key] != [string length $value]} {
	error "Extending the patch value went wrong !!"
    }
    if {$valb != {}} {
	if {[string length $key] != [string length $valb]} {
	    error "Extending the 2nd patch value went wrong !!"
	}
    }
    if {$valc != {}} {
	if {[string length $key] != [string length $valc]} {
	    error "Extending the 3rd patch value went wrong !!"
	}
    }

    # Patch inplace ... (and make sure that we can!)
    # Read everything into memory, patch it, seek to beginning of file
    # and write the modifications back.

    if {[string equal $::tcl_platform(platform) windows]} {
	file attributes $file -readonly 0
    } else {
	file attributes $file -permissions u+w
    }

    set fh [open $file r+]
    fconfigure $fh -encoding binary -translation binary

    if {($valb == {}) && ($valc == {})} {
	# Neither second nor third value. Map everything in one go.
	set data [string map [list $key $value] [read $fh]]
    } else {
	# At least one of valb, valc is not empty.

	if {$valb == {}} {
	    # valc is not empty => valb is now not empty.
	    set valb $valc
	    set valc {}
	}

	set data [read $fh]
	set loc  [string first $key $data]
	if {$loc >= 0} {
	    set locb [expr {$loc + [string length $key]}]
	    incr loc -1
	    set data [string range $data 0 $loc]$value[string range $data $locb end]
	}

	if {$valc == {}} {
	    # Now map the second value in one go, there is no third one.
	    set data [string map [list $key $valb] $data]
	} else {
	    set loc  [string first $key $data]
	    if {$loc >= 0} {
		set locb [expr {$loc + [string length $key]}]
		incr loc -1
		set data [string range $data 0 $loc]$valb[string range $data $locb end]
	    }
	    # Now map the third value.
	    set data [string map [list $key $valc] $data]
	}
    }

    seek $fh 0 start
    puts -nonewline $fh $data
    close $fh

    if {[string equal $::tcl_platform(platform) windows]} {
	file attributes $file -readonly 1
    } else {
	file attributes $file -permissions og-w
    }
    return
}

proc set_key {key value data} {
    # make sure to log when we set a key
    r_set $key $value $data
    install_log [list REGKEY $key $value $data]
}

proc r_set {key value data {mod {}}} {
    if {$mod == {}} {
	log_debug "\treg set \[$key, $value\] = ($data)"
	registry set $key $value $data
    } else {
	log_debug "\treg set ($mod) \[$key, $value\] = ($data)"
	registry set $key $value $data $mod
    }
}

proc r_get {key value} {
    log_debug "\treg get \[$key, $value\] = "

    set res [registry get $key $value]

    log_debug "\t\t$res"
    return $res
}

proc get_editor_app {} {
    set write [file nativename [auto_execok write]]
    if {$write == ""} {
	set write notepad.exe
    }
    return $write
}

proc get_edit_assoc {assoc ext} {
    # If an existing Edit association is there, don't change it,
    # as it may be a special one set up by the user.

    if {[catch {
	r_get HKEY_CLASSES_ROOT\\$assoc\\shell\\edit\\command {}
    } write]} {
	set write "\"[get_editor_app]\" \"%1\""
    } else {
	log "\tPreserving $ext Edit association \"$write\""
    }

    return $write
}


proc set_tcl_association {installdir ndir bindir} {
    ## Create the file association
    ## Not required for lite, we expect an existing ActiveTcl install 
    ## and thus assume the existence of the association

    if {[string equal $::AT(MODE) lite]} {return}


    set assoc ActiveTclScript

    if {[catch {
	log "\tAdding recognition of .tcl and .tbc scripts ..."
	# If an existing Edit association is there, don't change it,
	# as it may be a special one set up by the user.

	set write [get_edit_assoc $assoc .tcl]

	set assocList [list \
	     $assoc			{} "ActiveTcl Script" \
	     $assoc\\DefaultIcon	{} "$bindir\\tk$::AT(ND_VERG).dll,0" \
	     $assoc\\shell\\edit	{} &Edit \
	     $assoc\\shell\\edit\\command {} $write \
	     $assoc\\shell\\open\\command {} "\"$bindir\\wish$::AT(ND_VERG).exe\" \"%1\" %*" \
	    ]

	## Make sure the user requested that we install this association.
	if {![info exists ::INSTALL_REG_TCL] || $::INSTALL_REG_TCL} {
	    lappend assocList .tcl {} $assoc
	}
	if {![info exists ::INSTALL_REG_TBC] || $::INSTALL_REG_TBC} {
	    lappend assocList .tbc {} $assoc
	}

	foreach {key valueName data} $assocList {
	    set_key [class_root]\\$key $valueName $data
	}
    } err]} {
	log "ERROR: $err" error
    }
    return
}


proc set_association {
    assoc title
    application
    extensions
} {
    ## Create file associations
    ## Assume that the application is a list. One element => True application
    ## More elements => We did resolve chaining of open commands
    #
    ## Required for starkit based launcher. windows does not search
    ## for an open command for the open application of a file.

    set bindir [file nativename $::INSTALL_DIR]\\bin

    if {[catch {
	#log "___ $application"

	if {[llength $application] > 1} {
	    # Chained app, quote all parts.
	    set application "\"$bindir\\[join $application "\" \"$bindir\\" ]\""
	} elseif {[llength $application] == 1} {
	    # Normal app
	    set application "\"$bindir\\[lindex $application 0]\""
	} else {
	    # error, illegal call
	    error "internal error in call to 'set_association'"
	}

	#log "___ $application"

	set write [get_edit_assoc $assoc $assoc]

	foreach {key valueName data} [list \
		$assoc			     {} "$title" \
		$assoc\\DefaultIcon	     {} "$bindir\\tk$::AT(ND_VERG).dll,0" \
		$assoc\\shell\\edit	     {} &Edit \
		$assoc\\shell\\edit\\command {} $write \
		$assoc\\shell\\open\\command {} "$application \"%1\" %*" \
		] {
	    set_key [class_root]\\$key $valueName $data
	}

	foreach ext $extensions {
	    log "\tAdding recognition of $ext files ..."

	    foreach {key valueName data} [list \
		    $ext {} "$assoc" \
		    ] {
		set_key [class_root]\\$key $valueName $data
	    }
	}
    } err]} {
	log "ERROR: $err" error
    }
    return
}




proc set_product {installdir ndir bindir} {
    ## Register the product

    ## CHECK this code for correctness ...
    ## More than one documentation file is possible.
    ## Is it allowed to list more than one file for the 'help' key ?

    ## Bugzilla 18843 hack.
    ## When installing Tcl/DevKit also set keys for ActiveTcl,
    ## use a fixed version number for now. Later we will
    ## have to change this so that the build system is able
    ## to provide more information ... Maybe the build system
    ## should provide a list of keys and values, the latter
    ## having placeholders for install time information.

    ## Another hack: For Tcl/DevKit we know that there are
    ## two help files, and the second one is for ActiveTcl.

    ## Note: The upgrade kit does not have to set the ActiveTcl
    ##       keys, as it assumes that ActiveTcl is installed.


    set docfiles [list]
    foreach d $::AT(HELP) {
	lappend docfiles "$ndir\\doc\\$d"
    }

    set key "[soft_root]\\$::AT(Company)\\$::AT(PGROUP)"
    if {[catch {
	set_key  $key "CurrentVersion" "$::AT(VERSION)"
	set_key "$key\\$::AT(VERSION)" {} $ndir

	if {[llength $docfiles] > 0} {
	    set_key "$key\\$::AT(VERSION)\\Help" {} \
		    [lindex $docfiles 0]
	}
    } err]} { log "ERROR: $err" error }

    if {[string equal $::AT(MODE) pro]} {
	# Create the equivalent ActiveTcl keys. We get the version
	# information for ActiveTcl from the build configuration.

	array set SAVE [array get ::AT]
	set ::AT(PGROUP)  ActiveTcl
	set ::AT(VERSION) $::AT(TDK_ATVERS) 

	set key "[soft_root]\\$::AT(Company)\\$::AT(PGROUP)"
	if {[catch {
	    set_key  $key "CurrentVersion" "$::AT(VERSION)"
	    set_key "$key\\$::AT(VERSION)" {} $ndir
	    
	    if {[llength $docfiles] > 1} {
		set_key "$key\\$::AT(VERSION)\\Help" {} \
			[lindex $docfiles 1]
	    }
	} err]} { log "ERROR: $err" error }

	array set ::AT [array get SAVE]
	unset SAVE
    }

    return $docfiles
}

proc set_komodo_search {installdir ndir bindir} {
    ## Create the standard information used by Komodo to look for interpreters.
    ## Not required for lite, we expect an existing ActiveTcl install 
    ## and thus assume the existence of the association

    if {[string equal $::AT(MODE) lite]} {return}

    global INSTALL_MODE ; # "admin" or "user"

    if {[string equal $INSTALL_MODE user]} {
	# Personal installation without admin privileges ...
	# (If this is a personal installation for a user with
	# admin privileges we go forward with our action.

	log " "
	log "\tFor a personal installation we assume that extending \"App Paths\" with" warning
	log "\ta reference to tclsh is not possible as this action requires access to"  warning
	log "\tprivileged keys in the registry."                                        warning
	log " "                                                                         warning
	log "\tConsequence: ActiveState Komodo may not find the tclsh/wish of this"     warning
	log "\t             installation."                                              warning
	log " "

	return
    }

    if {$::AT(DEBUG)} {
	set key {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\tclshg.exe}
    } else {
	set key {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\tclsh.exe}
    }
    log "\tExtend \"App Paths\" with reference to tclsh"

    if {[catch {
	set_key $key {}   "$bindir\\tclsh$::AT(ND_VERG).exe"
	set_key $key Path "$bindir"
    } err]} { log "ERROR: $err" error }
    return
}

proc set_path_search {installdir ndir bindir} {
    ## Create the path information
    ## Not required for lite, we expect an existing ActiveTcl install 
    ## and thus assume the existence of the association

    if {[string equal $::AT(MODE) lite]} {return}

    global INSTALL_MODE ; # "admin" or "user"

    set systemEnv {HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment}

    set userEnv   {HKEY_CURRENT_USER\Environment}

    if {[string equal "Windows 95" $::tcl_platform(os)]} {
	# Windows 95/98/ME needs path added to AUTOEXEC.BAT
	log "NOTE: If you wish to have tclsh and wish in your"
	log "path, you must add \"$bindir\" to the PATH environment variable"
	log "in C:\\AUTOEXEC.BAT (takes effect upon restart)."
    } else {
	if {[catch {
	    log "\tAdding \"$bindir\" to your executable path ..."

	    # Cases:
	    # 1. Admin installation ...
	    #    a) bindir is in common PATH => Nothing to do
	    #    Extend common PATH.
	    # 2. Personal install ...
	    #    a) bindir is in common PATH   => Nothing to do.
	    #    b) bindir is in personal PATH => Nothing to do.
	    #       (That key may not exist !)
	    #    Extend personal PATH.

	    set curPath [r_get $systemEnv Path]

	    if {[regexp -nocase -- "***=$bindir;" $curPath]} {
		log "\t\t(\"$bindir\" already in your path)"
	    } else {
		switch -exact -- $INSTALL_MODE {
		    admin   {
			r_set $systemEnv Path "$bindir;$curPath" expand_sz
		    }
		    user {
			set curPath ""
			catch {set curPath [r_get $userEnv Path]}

			if {[regexp -nocase -- "***=$bindir;" $curPath]} {
			    log "\t\t(\"$bindir\" already in your path)"
			} else {
			    # Use %PATH% to enforce inheritance of
			    # existing path information from the
			    # global environment.

			    if {[string equal "" $curPath]} {
				set newPath "$bindir"
			    } else {
				set newPath "$bindir;$curPath"
			    }
			    if {![string match -nocase "%PATH%" $newPath]} {
				append newPath ";%PATH%"
			    }
			    r_set $userEnv Path $newPath expand_sz
			}
		    }
		    default {
			return -code error "PANIC.\
				Internal error of the installer.\
				This should not happen."
		    }
		}
	    }
	} err]} {
	    log "ERROR: $err" error
	}
    }

    if {![info exists ::INSTALL_PATHEXT] || $::INSTALL_PATHEXT} {
	if {[catch {
	    log "\tAdding \".tcl\" to your pathext ..."

	    # Cases:
	    # 1. Admin installation ...
	    #    a) .tcl is in common PATHEXT => Nothing to do
	    #    Extend common PATHEXT.
	    # 2. Personal install ...
	    #    a) .tcl is in common PATHEXT   => Nothing to do.
	    #    b) .tcl is in personal PATHEXT => Nothing to do.
	    #       (That key may not exist !)
	    #
	    #   Extend personal PATHEXT.
	    #
	    #   Bugzilla TclDevKit 20828: If it was empty, but the common
	    #   PATHEXT was not we have to copy the data from the common
	    #   PATHEXT to prevent the loss of these associations.

	    set nosystemdefault 0
	    if {[catch {
		set curSystemPath [r_get $systemEnv PATHEXT]
	    }]} {
		# The system environment variable PATHEXT was missing.
		# Fall back to hardwired defaults.
		set curSystemPath ".COM;.EXE;.BAT;.CMD"
		set nosystemdefault 1
	    }

	    if {[string match -nocase "*;.tcl*" $curSystemPath]} {
		log "\t\t(\".tcl\" already in your pathext)"
	    } else {
		switch -exact -- $INSTALL_MODE {
		    admin   {
			r_set $systemEnv PATHEXT "$curSystemPath;.tcl" sz
		    }
		    user {
			set curPersonalPath ""
			catch {set curPersonalPath [r_get $userEnv PATHEXT]}

			if {[string match -nocase "*;.tcl*" $curPersonalPath]} {
			    log "\t\t(\".tcl\" already in your pathext)"
			} else {
			    if {$curPersonalPath == ""} {
				# Bugzilla TclDevKit 20828
				#
				# Use common variable as source to prevent
				# the loss of the information contained
				# therein.

				set curPersonalPath "%PATHEXT%"
			    }
			    if {$nosystemdefault} {
				# Make sure that basic extensions are present if
				# the system PATHEXT was empty.
				append curPersonalPath ";" $curSystemPath
			    }
			    r_set $userEnv PATHEXT "$curPersonalPath;.tcl" expand_sz
			}
		    }
		    default {
			return -code error "PANIC.\
			    Internal error of the installer.\
			    This should not happen."
		    }
		}
	    }
	} err]} {
	    if {[string compare "Windows 95" $::tcl_platform(os)]} {
		# Only complain on Win2K/NT
		log "ERROR: $err" error
	    }
	}
    }

    catch {registry broadcast Environment}
    return
}

proc register_uninstaller {installdir ndir bindir} {
    ## Create the uninstall information

    global INSTALL_MODE

    set key "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\$::AT(PGROUP) $::AT(VERSION)"

    if {[string equal $INSTALL_MODE user]} {
	# Personal installation without admin privileges ...
	# (If this is a personal installation for a user with
	# admin privileges we go forward with our action.

	log " "
	log "\tFor a personal installation we assume that extending 'Settings | Control Panel | Add/Remove Programs'" warning
	log "\twith an uninstaller is not possible as this action requires access to"  warning
	log "\tprivileged keys in the registry."                                       warning
	log " "                                                                        warning
	log "\tThis means that the only way to uninstall this package is through the"  warning
	log "\tuninstall entry added to the start menu."                               warning
	log " "
	return
    }

    log "\tRegister uninstaller in system"

    if {[catch {
	set_key $key "DisplayName"    "$::AT(Company) $::AT(NAME) $::AT(MVERSION)"
	set_key $key "Publisher"      "$::AT(Company) Corporation"
	set_key $key "DisplayVersion" "$::AT(MVERSION)"
	set_key $key "HelpLink"       $::AT(url,help)
	set_key $key "URLInfoAbout"   $::AT(url,about)
	set_key $key "URLUpdateInfo"  $::AT(url,update)
	set uninst "\"$bindir\\wish$::AT(ND_VERG).exe\" \"[file nativename [file dirname $::INSTALL_DIR/$::AT(LOG)]/$::AT(UNINSTALLER)]\""
	set_key $key "UninstallString" $uninst

	install_log [list REGKEY $key]
    } err]} {
	log "\tERROR: $err" error
    }
    return
}


proc patch_registry {installdir {group @@}} {
    ## patch registry and create shortcuts
    ## Extending the registry

    package require registry
    package require dde

    set ndir [file nativename $installdir]
    set bindir $ndir\\bin

    ## Create the file association
    ## Register the product
    ## Create the standard information used by Komodo to look for interpreters.
    ## Create the path information
    ## Create the uninstall information

    set_tcl_association  $installdir $ndir $bindir

    if {![string equal $::AT(MODE) normal]} {
	# Pro or lite distribution have to set associations for the
	# various Tcl/DevKit project files

	set launcher prolaunch
	if {$::HAVE_TCLAPP} {
	    set launcher [list wish$::AT(ND_VERG).exe prolaunch.tcl]
	} else {
	    set launcher [list prolaunch.exe]
	}
	set_association \
		TclDevKitProject "Tcl Dev Kit Project File" \
		$launcher {.tpj .tap .tdk}

	## ___ Not defined yet ___
	## set_association TclProDebugger "TclPro Debugger Project" prodebug .tpd
	## set_association TclProCompiler "TclPro Compiler Project" procomp  .tpc
	## set_association TclProWrapper  "TclPro Wrapper Project"  prowrap  .tpw
    }

    set docfiles [set_product $installdir $ndir $bindir]
    set_komodo_search    $installdir $ndir $bindir
    set_path_search      $installdir $ndir $bindir
    register_uninstaller $installdir $ndir $bindir

    ## Creating the shortcuts
    ## This action depends on the distribution the installer is run from.
    ##
    ## Differences: Availability of README's, Demos.

    if {$group == "@@"} {
	set group "$::AT(Company) $::AT(dPGROUP) $::AT(MVERSION)"
    }

    ## FUTURE XXX FIXME : Declare the key in the 'data' files, use
    ##                    placeholders for the installation and demo
    ##                    directories.

    set smpdir [determine_startmenuprg]

    log_debug "Directory for start menu ="
    log_debug "\t$smpdir"

    set shortcut_items [list]
    # See [declare_menuentry] and [create_menu].

    if {[llength $docfiles] == 1} {
	set doc [lindex $docfiles 0]
	declare_menuentry "$::AT(dPGROUP) Help" {} {} \"$doc\"

    } elseif {[llength $docfiles] > 1} {
	foreach doc $docfiles {
	    set stem [file rootname [file tail $doc]]
	    if {"$stem" == "TclDevKit"} {
		set stem "Tcl Dev Kit"
	    } elseif {"$stem" == "ActiveTclHelp"} {
		# Bugzilla 25212
		set stem "ActiveTcl"
	    }
	    declare_menuentry "$stem Help" {} {} \"$doc\"
	}
    }

    # Bugzilla 19781/19704 ... General changes: Use the new commands
    # to declare and create menu entries.

    if {
	[string equal $::tcl_platform(os) "Windows NT"] ||
	[string equal $::tcl_platform(os) "Windows 95"] 
    } {
	set ico [file nativename [file attributes \
		"$ndir\\lib\\tk$::AT(tcl_VERSION)\\images\\uninstall.ico" \
		-shortname]]
    } else {
	set ico "$ndir\\lib\\tk$::AT(tcl_VERSION)\\images\\uninstall.ico"
    }

    # Bugzilla 19706 ...
    declare_menuentry \
	    "Uninstall $::AT(dPGROUP) $::AT(MVERSION)" \
	    $ico \
	    {} \
	    "\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
	    "\"[file nativename [file dirname $::INSTALL_DIR/$::AT(LOG)]\\$::AT(UNINSTALLER)]\""

    # References to the licenses in the CHM files.
    # mk:@MSITStore:C:\Tcl\20tdk\doc\TclDevKit.chm::/Licensing.html
    # mk:@MSITStore:C:\Tcl\20tdk\doc\ActiveTclHelp.chm::/ActiveTcl8.3.4.3-html/at.license.html
    # Assume that they are not available anywhere.

    set doc [file nativename [file join $::INSTALL_DIR license.terms]]
    declare_menuentry \
	    "$::AT(NAME) License" \
	    {} {} \
	    \"[get_editor_app]\" \"$doc\"

    if {0} {
	if {
	    [string equal $::tcl_platform(os) {Windows NT}] ||
	    [string equal $::tcl_platform(os) {Windows 95}]
	} {
	} else {
	    if {[string equal $::AT(MODE) normal]} {
		set doc [file nativename [file join $::INSTALL_DIR doc $::AT(HELP)]]
		
		declare_menuentry \
			"$::AT(NAME) License" \
			{} {} \
			\"mk:@MSITStore:${doc}::/$::AT(PGROUP)$::AT(VERSION)-html/at.license.html\"

	    } elseif {[string equal $::AT(MODE) pro] || [string equal $::AT(MODE) lite]} {
		set doc [file nativename [file join $::INSTALL_DIR doc [lindex $::AT(HELP) 0]]]

		declare_menuentry \
			"$::AT(NAME) License" \
			{} {} \
			\"mk:@MSITStore:${doc}::/Licensing.html\"
	    }
	}
    }

    if {[string equal $::AT(MODE) normal] || [string equal $::AT(MODE) pro]} {
	# Ensuring that the tcl/tk apps like tkcon and the demos use
	# the wish coming with the distribution, and not the wish of a
	# distribution installed afterward. IOW we bypass the .tcl
	# association.

	declare_menuentry Wish$::AT(ND_VER)  {} {} \
		"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\""

	declare_menuentry Tclsh$::AT(ND_VER) {} {} \
		"\"$ndir\\bin\\tclsh$::AT(ND_VERG).exe\""

	declare_menuentry tkcon              {} {} \
		"\"$ndir\\bin\\$::wish_exe\"" "\"$ndir\\bin\\tkcon.tcl\""

	declare_menuentry Readme             {} {} \
		"\"$ndir\\README.txt\""

	## Not yet. Requires PWD = demos/Snack to find its .wav
	## files. Installer does not handle such yet.
	## "\"$ndir\\bin\\$::wish_exe\" \"$demodir\\Snack\\widget.tcl\"" "Snack"

	# No demos yet: TclDOM, Tcllib, Tcl/DevKit, Soap, TclXML, TkHTML,
	#               Tktable
	#
	# Actually we have demos, a lot of demos for all of the
	# above. But either no central demo application, or the demos
	# have no GUI, making them pointless to use.

	set demodir [file nativename $::DEMO_DIR]

	if {$smpdir == {}} {
	    # No subdirectories possible. Just use one menu entry
	    # for all the demos, by linking to the demo folder.

	    declare_menuentry Demos {} {} "\"$demodir\""
	    set subtut {}
	} else {
	    declare_menuentry "Tk"           {} Demos \
		    "\"$ndir\\bin\\$::wish_exe\"" "\"$demodir\\Tk\\widget.tcl\""

	    declare_menuentry "BWidget"      {} Demos \
		    "\"$ndir\\bin\\$::wish_exe\"" "\"$demodir\\BWidgets\\demo.tcl\""

	    declare_menuentry "IWidgets"     {} Demos \
		    "\"$ndir\\bin\\$::wish_exe\"" "\"$demodir\\Iwidgets\\catalog.tcl\""

	    declare_menuentry "Img"          {} Demos \
		    "\"$ndir\\bin\\$::wish_exe\"" "\"$demodir\\Img\\demo.tcl\""

	    declare_menuentry "TCom - Chart" {} Demos \
		    "\"$ndir\\bin\\$::wish_exe\"" "\"$demodir\\Tcom\\chart.tcl\""
	    set subtut Demos
	}

	# Bugzilla 19743 ... Only for pro distributions.
	if {[string equal $::AT(MODE) pro]} {
	    # Bugzilla 19689 ... Explicit call of debugger to ensure usage of -coverage option.

	    if {$::HAVE_TCLAPP} {
		declare_menuentry "Hotspot Multiplication I"   {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\prodebug.tcl\" -coverage \"$demodir\\TclDevKit\\cover\\mult\\mult_1.tpj\""

		declare_menuentry  "Hotspot Multiplication II" {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\prodebug.tcl\" -coverage \"$demodir\\TclDevKit\\cover\\mult\\mult_2.tpj\""

		declare_menuentry "Coverage Testsuite I"       {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\prodebug.tcl\" -coverage \"$demodir\\TclDevKit\\cover\\csv\\csv.tpj\""

		declare_menuentry "Coverage Testsuite II"      {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\prodebug.tcl\" -coverage \"$demodir\\TclDevKit\\cover\\csv\\csv_new.tpj\""

		declare_menuentry "Wrap BWidget-Demo -- Starkit"          {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\tclapp.tcl\" -gui \"$demodir\\BWidgets\\demo_starkit.tpj\""

		declare_menuentry "Wrap BWidget-Demo -- Starpack"          {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\tclapp.tcl\" -gui \"$demodir\\BWidgets\\demo_starpack.tpj\""

		declare_menuentry "Wrap Img-Demo -- Starpack"          {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\tclapp.tcl\" -gui \"$demodir\\Img\\demo.tpj\""

		declare_menuentry "Wrap TkCon -- Starkit"          {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\tclapp.tcl\" -gui \"$demodir\\Tkcon\\demo.tpj\""

		declare_menuentry "Wrap Klondike -- Starpack"          {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\tclapp.tcl\" -gui \"$demodir\\TclDevKit\\klondike\\demo.tpj\""

		if {![string equal "Windows 95" $::tcl_platform(os)]} {
		    # Install only for NT class machines
		    declare_menuentry "TclSvc Register ExprServer"   {} $subtut \
			"\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\tclsvc.tcl\" -script \"$demodir\\TclSvc\\exprserver.tcl\" -servicename TclExpr -description Calculator"
		}

		# "http://www.tcl.tk/software/plugin/applets.html"
		declare_menuentry "Tcl Plugin Demos"   {} $subtut \
			"\"$demodir\\plugin\\plugin-demo.html\""

	    } else {
		declare_menuentry "Hotspot Multiplication I"   {} $subtut \
			"\"$ndir\\bin\\prodebug.exe\"" -coverage "\"$demodir\\TclDevKit\\cover\\mult\\mult_1.tpj\""

		declare_menuentry  "Hotspot Multiplication II" {} $subtut \
			"\"$ndir\\bin\\prodebug.exe\"" -coverage "\"$demodir\\TclDevKit\\cover\\mult\\mult_2.tpj\""

		declare_menuentry "Coverage Testsuite I"       {} $subtut \
			"\"$ndir\\bin\\prodebug.exe\"" -coverage "\"$demodir\\TclDevKit\\cover\\csv\\csv.tpj\""

		declare_menuentry "Coverage Testsuite II"      {} $subtut \
			"\"$ndir\\bin\\prodebug.exe\"" -coverage "\"$demodir\\TclDevKit\\cover\\csv\\csv_new.tpj\""

		declare_menuentry "Wrap BWidget-Demo"          {} $subtut \
			"\"$ndir\\bin\\prowrap.exe\"" -gui "\"$demodir\\BWidgets\\demo.tpj\""
	    }
	}
    }
    if {[string equal $::AT(MODE) pro] || [string equal $::AT(MODE) lite]} {

	if {$::HAVE_TCLAPP} {
	    declare_menuentry "$::AT(NAME) TclApp"                 {} {} "\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
		    "\"$ndir\\bin\\tclapp.tcl\""
	    declare_menuentry "$::AT(NAME) Package Editor"         {} {} "\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
		    "\"$ndir\\bin\\tape.tcl\""
	    declare_menuentry "$::AT(NAME) Compiler"               {} {} "\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
		    "\"$ndir\\bin\\procomp.tcl\""

	    declare_menuentry "$::AT(NAME) Compiler for 8.3"       {} {} \
		    "\"$ndir\\bin\\procomp83.exe\""

	    ## declare_menuentry "$::AT(NAME) Checker"                {} {} "\"$ndir\\bin\\procheck.tcl\""

	    declare_menuentry "$::AT(NAME) Checker"                {} {} "\"$ndir\\doc\\procheck.html\""

	    declare_menuentry "$::AT(NAME) Inspector"              {} {} "\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
		    "\"$ndir\\bin\\proinspect.tcl\""
	    declare_menuentry "$::AT(NAME) Debugger"               {} {} "\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
		    "\"$ndir\\bin\\prodebug.tcl\""
	    declare_menuentry "$::AT(NAME) Debugger with Coverage" {} {} "\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
		    "\"$ndir\\bin\\prodebug.tcl\"" -coverage

	    if {![string equal "Windows 95" $::tcl_platform(os)]} {
		# Install only for NT class machines
		declare_menuentry "$::AT(NAME) Tcl Service Manager"    {} {} "\"$ndir\\bin\\wish$::AT(ND_VERG).exe\"" \
			"\"$ndir\\bin\\tclsvc.tcl\""
	    }
	} else {
	    declare_menuentry "$::AT(NAME) Wrapper"                {} {} "\"$ndir\\bin\\prowrap.exe\""
	    declare_menuentry "$::AT(NAME) Compiler"               {} {} "\"$ndir\\bin\\procomp.exe\""
	    declare_menuentry "$::AT(NAME) Compiler for 8.4"       {} {} "\"$ndir\\bin\\procomp84.exe\""

	    ## declare_menuentry "$::AT(NAME) Checker"                {} {} "\"$ndir\\bin\\procheck.exe\""

	    declare_menuentry "$::AT(NAME) Checker"                {} {} "\"$ndir\\doc\\procheck.html\""

	    declare_menuentry "$::AT(NAME) Debugger"               {} {} "\"$ndir\\bin\\prodebug.exe\""
	    declare_menuentry "$::AT(NAME) Debugger with Coverage" {} {} "\"$ndir\\bin\\prodebug.exe\"" -coverage
	}

	declare_menuentry "Readme $::AT(NAME)"                 {} {} "\"$ndir\\README-tdk.txt\""

	##	\"$ndir\\bin\\protclsh$::AT(ND_VER).exe\" Protclsh$::AT(ND_VER) \
	##	\"$ndir\\bin\\prowish$::AT(ND_VER).exe\" Prowish$::AT(ND_VER) \
	##
    }

    # Now that the selection of menu entries is complete we can create them ...

    create_menu $group $shortcut_items $smpdir

    # ==================================================================

    ## Bugzilla item 18950
    ## Patch the *Config.sh files on Win* too

    log "Patching configuration scripts"

    set files [list]
    foreach f [glob [file join $installdir lib *Config.sh]] {
	lappend files $f
    }

    ## log "pfx  = [list $::AT(BLD_PFXPATH)]"
    ## log "epfx = [list $::AT(BLD_EPFXPATH)]"

    set ekey [string map [list / \\] $::AT(BLD_EPFXPATH)]
    set pkey [string map [list / \\] $::AT(BLD_PFXPATH)]

    foreach f $files {
	log "*  $f ..."
	# Look for backslash form of path as well..

	patch_text_file $f $::AT(BLD_EPFXPATH) $installdir
	patch_text_file $f $ekey               $installdir
	patch_text_file $f $::AT(BLD_PFXPATH)  $installdir
	patch_text_file $f $pkey               $installdir
    }
    return
}


proc registry_root {} {
    global INSTALL_MODE ; # "admin" or "user"
    switch -exact -- $INSTALL_MODE {
	admin   {return HKEY_LOCAL_MACHINE}
	user    {return HKEY_CURRENT_USER}
	default {
	    return -code error "PANIC.\
		    Internal error of the installer.\
		    This should not happen."
	}
    }
}

proc soft_root {}  {return "[registry_root]\\SOFTWARE"}
proc class_root {} {return "[soft_root]\\Classes"}

proc determine_startmenuprg {} {
    # Query registry and environment to find the directory whose
    # contents are used to construct the start menu.

    # Bugzilla 19781 ... Admin/User Installation.

    global INSTALL_MODE ; # "admin" or "user"
    global env

    if {[string equal "Windows 95" $::tcl_platform(os)]} {
	# Win 95 this info cannot be found in HKLM, only HKCU
	set key "HKEY_CURRENT_USER\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders"
	set prg  "Programs"
	set sme  "Start Menu"
	set idx  USERPROFILE
    } else {
	set key "[soft_root]\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders"
	switch -exact -- $INSTALL_MODE {
	    admin {
		set prg "Common Programs"
		set sme "Common Start Menu"
		set idx  ALLUSERSPROFILE
	    }
	    user {
		set prg  "Programs"
		set sme  "Start Menu"
		set idx  USERPROFILE
	    }
	    default {
		return -code error "PANIC.\
			Internal error of the installer.\
			This should not happen."
	    }
	}
    }


    if {![catch {set path [r_get $key $prg]}]} {
	return $path
    }

    # Beware !! From here on the result is non-portable (i.e. not
    # internationalized) and will not work on non-US/non-English machines.

    log "Unable to find \"$key $prg\"" warning
    log "Falling back to non-i18n data" warning

    if {![catch {set path [r_get $key $sme]}]} {
	return [file join $path {Programs}]
    }

    log "Unable to find \"$key $sme\"" warning
    log "Falling back to environment variable \"$idx\"" warning

    if {[info exists env($idx)]} {
	return [file join $::env($idx) {Start Menu} Programs]
    }

    log "Unable to determine where the startmenu is located" warning
    return {}
}

# Bugzilla 19731/19704 ... Part of general reorganization of this part
# of the code. Creates the program group and start menu of the
# application. Distinguishes common and personal installation, and
# also if the installer was able to find the start menu in the file
# system.

proc create_menu {group shortcuts smpdir} {
    # shortcuts is a list of quartets defining
    # - (D) display name of shortcut
    # - (I) icon to use for shortcut
    # - (S) subfolder to place the shortcut in (= submenu)
    # - (C) command/file linked to by the shortcut
    #
    # in this order. An empty icon signals to use the default one. An
    # empty directory signals that the entry goes into the main menu.
    #
    # 'list of quartets' means "shortcuts = {D I S C D I S C ...}".

    global INSTALL_MODE

    switch -exact -- $INSTALL_MODE {
	admin {set cgroupflag 1}
	user  {set cgroupflag 0}
	default {
	    return -code error "PANIC.\
		    Internal error of the installer.\
		    This should not happen."
	}
    }

    if {[catch {
	log "\tCreating program group \"$group\" ..."

	if {$smpdir == {}} {
	    # The system was unable to determine the location of the
	    # start menu in the file system. We generate the chosen
	    # program group and all entries, discarding the subfolder
	    # specification of the declared entries.

	    # Bugzilla 19735 ... Reenabled the deletion of the group, full
	    # refresh just in case this is an install over the same
	    # version of ActiveTcl or Tcl/DevKit.

	    catch {dde execute progman progman "\[DeleteGroup($group)\]"}
	    dde execute progman progman "\[CreateGroup($group,$cgroupflag)\]"

	    # Bugzilla 19704 ... Close window of program group, no need to
	    # clutter the screen. At least try to :(
	    dde execute progman progman "\[ShowGroup($group,6)\]"

	    install_log [list PROGGROUP $group]

	    foreach {name icon sub exe} $shortcuts {
		# Subfolders are of no relevance, we don't know where
		# to anchor them.

		create_menuentry $name $icon {} $exe
	    }
	} else {
	    # The installer know the location of the start menu in the
	    # file system, and thus also the location of the directory
	    # for any program group. To fix Bugzilla 19704 for good we
	    # create the directory for our program group with a file
	    # system command and use DDE and a temporary program group
	    # to create the necessary shortcut. After moving the
	    # shortcuts from the directory of the temporary group to
	    # the directory of the actual group we destroy the
	    # temporary group, thus forcing its window to go away. We
	    # also honor all subfolder specs when generating the
	    # entries.

	    set tmpgroup "$group - transient"

	    set tgdir [file join $smpdir $tmpgroup]
	    set gdir  [file join $smpdir $group]

	    log_debug "Transient group dir = $tgdir"
	    log_debug "Group directory     = $gdir"

	    catch {dde execute progman progman "\[DeleteGroup($tmpgroup)\]"}
	    catch {dde execute progman progman "\[DeleteGroup($group)\]"}
	    dde execute progman progman "\[CreateGroup($tmpgroup,$cgroupflag)\]"

	    foreach {name icon sub exe} $shortcuts {
		create_menuentry $name $icon $sub $exe $tgdir
	    }

	    file mkdir $gdir
	    install_log [list PROGGROUP $group]

	    eval file rename -force -- [glob [file join $tgdir *]] [list $gdir]

	    dde execute progman progman "\[DeleteGroup($tmpgroup)\]"
	}
    } err]} {
	log "ERROR: $err" error
    }
    return
}

# Bugzilla 19731/19704 ... Part of general reorganization of this part
# of the code. Wrapper around data structures to make the declaration
# of new shortcuts easier to comprehend and maintain.

proc declare_menuentry {name icon sub exe args} {
    upvar shortcut_items si
    global INSTALL_MODE tcl_platform

    if {
	[string equal $INSTALL_MODE user] &&
	[string equal $tcl_platform(os) "Windows NT"]
    } {
	# First word may not have "" surrounding it or DDE
	# goes haywire for a non-admin user. If the path
	# contains spaces we use the shortname for the transfer
	# to progman. That works.

	set exe [string trim $exe "\""]

	if {[string match "* *" $exe]} {
	    set exe [file nativename [file attributes $exe -shortname]]
	}
    }
    if {[llength $args] == 0} {
	lappend si $name $icon $sub $exe
    } else {
	lappend si $name $icon $sub "$exe [join $args]"
    }
    return
}


# Bugzilla 19731/19704 ... Part of general reorganization of this part
# of the code. Use DDE to create a shortcut in the chosen prgram group
# Handle an icon if declared. Move the generated shortcut into a
# subfolder of the group if so specified.

# This fixes the symption, not the problem
proc lnkname {groupdir exe name} {
    set lnk [file join $groupdir $name.lnk]
    log_debug "Trying $lnk"
    if {[file exists $lnk]} {return $lnk}

    ##    set lnk [file join $groupdir [string map {: _ / _ \\ _} $exe].lnk]
    ##    log_debug "Trying $lnk"
    ##    if {[file exists $lnk]} {return $lnk}

    error "Unable to determine name of link file for \"$name\""
}


proc create_menuentry {name icon sub exe {groupdir {}}} {
    #log "AddItem <<$name>> <<$icon>> <<$sub>> <<$exe>>"

    if {$icon != {}} {
	set cmd "\[AddItem($exe,$name,$icon)\]"
    } else {
	set cmd "\[AddItem($exe,$name)\]"
    }
    if {[catch {
	dde execute progman progman $cmd

	if {$sub != {}} {
	    set         sub [file join $groupdir $sub]
	    file mkdir $sub
	    file rename [lnkname $groupdir $exe $name] [file join $sub $name.lnk]
	}
    } err]} {
	log "ERROR: $err" error
    }
    return
}

if {0} {
    proc has_admin_permissions {{group @@}} {
	# Bugzilla 19731 ... Determine if the user has admin privileges.
	#
	# This is done by creating and deleting a common group.
	# The creation will fail without admin privileges.

	if {$group == "@@"} {
	    set group "$::AT(Company) $::AT(dPGROUP) $::AT(MVERSION)"
	}

	set tmpgroup "${group}-test-admin"

	package require dde

	## catch        {dde execute progman progman "\[DeleteGroup($tmpgroup)\]"}
	set fail [catch {dde execute progman progman "\[CreateGroup($tmpgroup,1)\]"}]
	if {!$fail} {
	    catch       {dde execute progman progman "\[DeleteGroup($tmpgroup)\]"}
	}
	set admin [expr {!$fail}]

	# We overwrite this procedure to memoize the result
	proc has_admin_permissions {{group @@}} [list return $admin]

	return $admin
    }
}


proc do_finish {srcdir installdir runtimedir} {
    ## finish installation
    ##
    ## Windows: Registry ...
    ## Unix:    Patch tclsh, wish for installed location.

    log "Finishing the installation"

    switch -glob -- $::tcl_platform(platform) {
	unix    {
	    if {$::HAVE_TCLAPP} {
		install_plugin_unix $installdir $runtimedir
	    }

	    log "Patching the shells and libraries for the new location ..."
	    patch_shells $srcdir $installdir $runtimedir
	    patch_tut
	    patch_tools $installdir
	}
	win*    {
	    if {$::HAVE_TCLAPP} {
		install_plugin_win $installdir $runtimedir
	    }

	    log "Extending the registry ..."
	    patch_registry $installdir
	    patch_tut
	}
	default {
	    error "Unknown platform $tcl_platform(platform)"
	}
    }

    log "Done"
    return
}

proc do_install_modules {srcdir installdir demodir} {
    log "Installing $::AT(NAME) ..."

    install_all $srcdir $installdir

    if {[catch {
	file delete [file join $installdir install.tk]
	file delete [file join $installdir install.tcl]
	file delete [file join $installdir install_lib.tcl]
	file delete [file join $installdir install_data.tcl]
	file delete [file join $installdir install_welcome.txt]
	file delete [file join $installdir install.bat]
	file delete [file join $installdir install.sh]

	# This file was copied to the place the install.log is found at.
	# We don't need it in the toplevel directory anymore.

	file delete [file join $installdir $::AT(UNINSTALLER)]
    } err]} { log $err } ; #- fake out emacs indent code {} 

    if {![string equal $::AT(MODE) lite]} {
	# Step II: Install the demos ...
	# Do nothing if they are already in the right place.

	if {[string match windows $::tcl_platform(platform)]} {
	    # On windows we compare without case as theat OS treats names in the same way.
	    set scres [string compare -nocase [file join $installdir demos] $demodir]
	} else {
	    set scres [string compare [file join $installdir demos] $demodir]
	}
	if {$scres != 0} {
	    # Copy over, then delete from place in installation

	    log "Moving demos to chosen location ..."

	    install_all [file join $installdir demos] $demodir
	    file delete -force -- [file join $installdir demos]
	}
    }

    log "Done ..."
    return
}

proc contains_activetcl_installation {dir} {
    set ::AT(InstVersion) ""
    set files [list \
	    [file join $dir README*] \
	    [file join $dir bin tclsh*] \
	    [file join $dir bin wish*] \
	    [file join $dir bin tkcon*] \
	    ]
    if {[llength [eval glob -nocomplain $files]] == 0} {
	# None of our regular files seem to be there.
	return 0
    }

    # Several key files were found.
    # Now check the contents of the README.

    set readme [file join $dir README.txt]
    if {[catch {open $readme} fh]} {
	# Couldn't open the README file...
	return 0
    }

    set readme [read $fh]
    close $fh
    # Return 0 if we didn't match, otherwise 1
    return [regexp {ActiveTcl\S*\s*(\d+\.\d+\.\d+\.\d+)} $readme \
	    -> ::AT(InstVersion)]
}

proc contains_tdk_installation {dir} {
    set ::AT(InstVersion) ""

    set files [list \
	    [file join $dir README-tdk*] \
	    [file join $dir bin pro*] \
	    ]
    if {$::HAVE_TCLAPP} {
	lappend files \
		[file join $dir bin tclapp*] \
		[file join $dir bin tape*]
    } else {
	lappend files \
		[file join $dir bin protclsh*] \
		[file join $dir bin prowish*]
    }
    if {[llength [eval glob -nocomplain $files]] == 0} {
	# None of our regular files seem to be there.
	return 0
    }

    # Several key files were found.
    # Now check the contents of the README.

    set readme [file join $dir README-tdk.txt]

    if {[catch {open $readme} fh]} {
	# Could not open the README for Tcl/DevKit ...
	return 0
    }

    set readme [read $fh]
    close $fh
    # Return 0 if we didn't match, otherwise 1
    return [regexp {TclDevKit\S*\s*(\d+\.\d+\.\d+\.\d+)} $readme \
	    -> ::AT(InstVersion)]
}


proc overinstall_allowed {} {
    # Are we allowed to overwrite the installation in the selected
    # installation directory?
    #
    # The logic is simple - if we satisfy the current version, which
    # means we are a >= version, then allow overinstallation

    return [package vsatisfies [package provide $::AT(PGROUP)] $::AT(InstVersion)]
}


proc ensure_plugin_dir {path} {
    set base [file dirname $path]
    if {[file exists $base] && [file isdirectory $base] && ![file exists $path]} {
	if {[catch {file mkdir $path}]} {
	    return {}
	}
    }
    return $path
}

proc get_moz_regkey {} {
    global INSTALL_MODE
    if {![string equal $INSTALL_MODE admin]} {
	set base HKEY_CURRENT_USER\\Software\\Mozilla
    } else {
	set base HKEY_LOCAL_MACHINE\\SOFTWARE\\Mozilla
    }

    # Retrieve highest installed version of Mozilla, either for
    # the current user, or system-wide. Below that the caller can
    # find the path to the plugin directory of that installation.

    if {[catch {set sub [registry keys $base Mozilla*]}]} {return {}}
    if {$sub == {}} {return {}}

    return [lindex [lsort -increasing $sub] end]
}

proc get_mozwin_plugindir {} {
    set  mozkey [get_moz_regkey]
    if {$mozkey != {}} {
	if {![catch {set mozplug [r_get $mozkey\\Extensions Plugins]}]} {
	    if {($mozplug != {}) && [file exists [file dirname $mozplug]]} {
		return $mozplug
	    }
	}
    }

    # Try a default location if nothing was found in the registry.

    set key "HKEY_CURRENT_USER\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders"
    if {![catch {set appdata [r_get $key AppData]}]} {
	set base [file join $appdata Mozilla]
	if {[file exists $base]} {
	    return [file join $base Plugins]
	}
    }

    return {}
}



proc get_msie_plugindir {} {
    # This command looks at various places in the registry to find
    # where either the MSIE plugins live, or where MSIE lives. It
    # returns either the path of where it believes the MSIE plugins
    # live, or the empty string.

    set key "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\IEXPLORE.EXE"
    if {![catch {set path [r_get $key {}]}] && [file exists $path]} {
	return [file join [file dirname $path] PLUGINS]
    }
    if {![catch {set path [r_get $key Path]}]} {
	set path  [string trimright $path ";"]
	if {[file exists $path]} {
	    return [file join $path PLUGINS]
	}
    }


    set key "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Internet Explorer\\Main"
    if {![catch {set path [r_get $key Cache_Directory]}] && [file exists [file dirname $path]]} {
	return [file join [file dirname $path] PLUGINS]
    }
    if {![catch {set path [r_get $key History_Directory]}] && [file exists [file dirname $path]]} {
	return [file join [file dirname $path] PLUGINS]
    }


    set key "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\IE Setup\\SETUP"
    if {![catch {set path [r_get $key {}]}] && [file exists $path]} {
	return [file join $path PLUGINS]
    }


    set key "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\IE4\\Setup"
    if {![catch {set path [r_get $key {}]}] && [file exists $path]} {
	return [file join $path PLUGINS]
    }


    set key {HKEY_LOCAL_MACHINE\SOFTWARE\Classes\Applications\iexplore.exe\shell\open\command}
    if {![catch {set path [r_get $key {}]}]} {
	set path [string trimleft $path {"}]
	regsub -- {".*$} $path {} path
	if {[file exists [file dirname $path]]} {
	    return [file join [file dirname $path] PLUGINS]
	}
    }


    set key {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Plugins\Extension}
    if {![catch {set extlist [registry keys $key]}]} {
	foreach e $extlist {
	    if {![catch {set path [r_get $key\\$e Location]}] && [file exists $path]} {
		return [file dirname $path]
	    }
	}
    }


    set key {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Shared Tools\HTML\Clients}
    if {![catch {set sub [registry values $key]}]} {
	foreach s $sub {
	    if {[file exists $s]} {
		return [file dirname $s]
	    }
	}
    }

    # Try a default location if nothing was found in the registry.

    set key "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion"
    if {![catch {set pfiles [r_get $key ProgramFilesDir]}]} {
	set base [file join $pfiles {Internet Explorer}]
	if {[file exists $base]} {
	    return [file join $base PLUGINS]
	}
    }

    # And fall back to a hardcoded path.

    set fallback "C:/Program Files/Plus!/Microsoft Internet"
    if {[file exists $fallback]} {
	return [file join $fallback PLUGINS]
    }

    return {}
}

proc get_plugin_dir {bcode} {
    # Browser code, platform is implicit argument.

    if {[string equal "windows" $::tcl_platform(platform)]} {
	switch -exact -- $bcode {
	    mozilla   {set pluginpath [get_mozwin_plugindir]}
	    iexplorer {set pluginpath [get_msie_plugindir]}
	}
    } else {
	switch -exact -- $bcode {
	    netscape {set pluginpath ~/.netscape/plugins}
	    mozilla  {set pluginpath ~/.mozilla/plugins}
	}
    }

    return [ensure_plugin_dir $pluginpath]
}



proc install_plugin_unix {installdir runtimedir} {
    log "Installing the tcl plugin"

    global BROWSE BROWSEDIR

    set longfakepath [placeholder]
    set patchvalue   [file join $runtimedir lib]

    set src  [lindex [glob $installdir/lib/nptcl3.0/libnptcl*] 0]

    if {[string length $patchvalue] > [string length $longfakepath]} {
	log "    Can't patch plugin library, chosen path to long" error
    } else {
	log "    Patching $src (plugin library)"
	log "    with location of tcl libraries"
	
	patch_file $src $longfakepath $patchvalue
    }

    foreach b [array names BROWSE] {
	if {!$BROWSE($b)} {continue}
	log "    for $b"
	set pdir $BROWSEDIR($b)

	# Now copy patched library over to browser for usage
	file copy -force $src $pdir
    }

    ## Append actual location of executable used by the plugin to 'installed.cfg'.

    set    f [open $installdir/lib/nptcl3.0/installed.cfg a]
    puts  $f ""
    puts  $f "# Actual location of wish ..."
    puts  $f "set ::plugin(executable) [list $installdir/bin/wish]"
    close $f

    return
}

proc install_plugin_win {installdir runtimedir} {
    log "Installing the tcl plugin"

    global BROWSE BROWSEDIR BROWSE_PHC BROWSE_MIME BROWSELABEL

    set src  [lindex [glob $installdir/lib/nptcl3.0/nptcl*] 0]

    set longfakepath [placeholder]
    set patchvalue   [file join $runtimedir bin]

    if {[string length $patchvalue] > [string length $longfakepath]} {
	log "*   Can't patch plugin library, chosen path to long" error
    } else {
	log "*   Patching $src (plugin library)"
	log "    with location of tcl libraries"
	
	patch_file $src $longfakepath $patchvalue
    }

    foreach b [array names BROWSE] {
	if {!$BROWSE($b)} {continue}
	log ""
	log "*   Installing for $BROWSELABEL($b)"
	set pdir $BROWSEDIR($b)

	# Now copy patched library over to browser for usage.
	# Note that this may fail, so catch it and warn the
	# user instead of crashing the installer. Bugzilla 23310.
	if {[catch {
	    file copy -force $src $pdir
	}]} {
	    log "    Could not perform the installation."                      error
	    log "    The operating system denied access the chosen directory." error
	    log " "
	    log "    You need administrative privileges to perform the installation." warning
	    log " "
	}
    }

    if {$BROWSE_PHC} {
	# We need the plugin host control, so we register it now.
	if {[catch {
	    log "*   Registering plugin host control"
	    exec regsvr32.exe /s [file nativename $installdir/lib/nptcl3.0/pluginhostctrl.dll]
	} msg]} {
	    log "    Could not register the plugin host control." error
	    log " "
	    log "    You need administrative privileges to perform this action." warning
	    log " "
	}
    }

    if {$BROWSE_MIME} {
	# Register plugin for application/x-tcl mime type

	if {[catch {
	    log "*   Registering mime-type for tcl plugin"
	    r_set {HKEY_CLASSES_ROOT\MIME\Database\Content Type\application/x-tcl} \
		    CLSID {{14E78123-A693-4F27-B6EE-DDDE18F93D3A}}
	    r_set {HKEY_CLASSES_ROOT\MIME\Database\Content Type\application/x-tcl} \
		    Extension .tcl
	} msg]} {
	    log "    Could not register the application/x-tcl mime-type for the plugin." error
	    log " "
	    log "    You need administrative privileges to perform this action." warning
	    log " "
	}
    }

    ## Append actual location of executable used by the plugin to 'installed.cfg'.

    set    f [open $installdir/lib/nptcl3.0/installed.cfg a]
    puts  $f ""
    puts  $f "# Actual location of wish ..."
    puts  $f "set ::plugin(executable) [list [file nativename $installdir/bin/wish]]"
    close $f
}

