# -*- tcl -*-
# Main installation script for ActiveTcl
# --------------------------------------
#
# Copyright 2001, ActiveState Corp.
# All Rights Reserved.

package require ActiveTcl 8.3.3.3
package require Tk
package require BWidget

option add *Button.highlightthickness 1
option add *Scrollbar.highlightthickness 1
option add *Text.highlightthickness 1
option add *Label.highlightthickness 0
option add *Label.borderWidth 0



proc main {} {
    wm protocol . WM_DELETE_WINDOW cancel
    wm title . "$::AT(NAME) $::AT(VERSION) Installer"

    # Read the logo and create an image from it.

    set logo [image create photo -file \
	    [file join $::tk_library images ActiveTclSplash.gif]]

    set left [frame .left]
    set ::BASE [PagesManager .right]
    set sep  [frame .sep -height 2 -bd 2 -relief sunken]
    set ::BTNS [frame .btns]

    label $left.logo -image $logo
    pack  $left.logo -expand 0 -fill both -side top

    grid $left $::BASE -sticky news
    grid $sep -columnspan 2 -sticky ew
    grid $::BTNS -columnspan 2 -sticky ew
    grid columnconfig $::BTNS 0 -weight 1
    grid columnconfig . 1 -weight 1
    grid rowconfigure . 0 -weight 1

    set ::CANCEL [button $::BTNS.cncl -text "Cancel" -command { cancel }]
    set ::NEXT   [button $::BTNS.next -text "Next >" -command {set ::WAIT 1}]
    set ::BACK   [button $::BTNS.back -text "< Back" -command {set ::WAIT -1}]

    grid $::BACK $::NEXT $::CANCEL -sticky e -padx 4 -pady 8
    #grid remove $::BACK

    # By default, invoke the Next button on <Return>
    bind . <Key-Return> { next }

    # Magic debug console invocation
    bind . <Triple-3> { catch {console show} }

    # Initial license acceptance parameter
    set ::ACCEPT 0
    # Default install directory
    set ::INSTALL_DIR [default_installdir]
    # Default install error message
    set ::ERRMSG ""

    # Note: The procedures open and manipulate the user interface.
    # They use [vwait] to enter the eventloop where needed so that
    # sequencing control is not taken from [main].

    set state 1
    while {$state} {
	#puts =$state
	switch -exact $state {
	    1 { incr state [intro $::BASE] }
	    2 { incr state [license $::BASE] }
	    3 {
		# This page is always skipped when backstepping
		# from get_installdir.
		if {[string equal $::AT(MODE) lite]} {
		    # Just skip this. A similar check was done
		    # as part of the intro page.
		    incr state
		} else {
		    incr state [check_previous_install $::BASE]
		}
	    }
	    4 { incr state [get_installdir $::BASE] }
	    5 { incr state [overinstall $::BASE] }
	    6 { incr state [get_demodir $::BASE] }
	    7 {	incr state [install_ready $::BASE] }
	    8 {
		#puts Done
		exit 0
	    }
	    default {
		return -code error "Unknown run state \"$state\""
	    }
	}
    }
    #puts =$state
}

# ----------------------------------------------

proc intro {pages} {
    set pname intro
    set page [$pages getframe $pname]

    set welcome_msg $::WELCOME
    set fg black
    set next 1
    
    if {![winfo exists $page]} {
	# This check has to be done only once.
	# And if there is trouble there is neither next nor
	# backstepping from a later page.

	if {[string equal $::AT(MODE) lite]} {
	    foreach {ok msg} [lookfor_previous_install $::BASE] break
	    if {!$ok} {
		set welcome_msg $msg
		set fg red
		set next 0
	    } elseif {$msg != {}} {
		append welcome_msg \n $msg
	    }
	}

	set page [$pages add $pname]

	text $page.msg \
		-tabs {5m 10m 28m 40m 55m 65m 80m} \
		-width 70 \
		-fg $fg

	$page.msg insert end $welcome_msg

	## label $page.msg -anchor nw -justify left -width 70 -text $welcome_msg -fg $fg
	grid $page.msg -sticky news -padx 8 -pady 4
	grid rowconfigure $page 0 -weight 1
	grid columnconfigure $page 0 -weight 1

	$pages compute_size
    }
    $pages raise $pname

    # Return value to move to next state, no BACK button for this one

    if {$next} {
	return [wait_next 0]
    } else {
	return [wait_next 0 0 "Exit"]
    }
}

proc license_ok {} {
    $::NEXT configure -state [expr {$::ACCEPT ? "normal" : "disabled"}]
}

proc disable_next {} {
    $::NEXT configure -state disabled
}

proc license {pages} {
    set pname license
    set page [$pages getframe $pname]
    if {![winfo exists $page]} {
	set page [$pages add $pname]
	grid [ScrolledWindow $page.s -auto both] -sticky news -padx 4 -pady 4
	set tw [text $page.s.t -width 80 -height 8]
	$page.s setwidget $tw

	radiobutton $page.ok -variable ::ACCEPT -value 1 -anchor w \
		-command license_ok \
		-text "I accept the terms in the License Agreement"
	radiobutton $page.no -variable ::ACCEPT -value 0 -anchor w \
		-command license_ok \
		-text "I do not accept the terms in the License Agreement"
	grid $page.ok -stick we
	grid $page.no -stick we

	grid columnconfigure $page 0 -weight 1
	grid rowconfigure $page 0 -weight 1

	$tw insert end [license_text]
	$tw configure -state disabled

	# Accept focus even when disabled
	bind $tw <1>		{ focus %W }
	bind $tw <Key-Return>	{ next }

	$pages compute_size
    }
    after idle license_ok
    $pages raise $pname

    # Return value to move to next state
    return [wait_next]
}

# ----------------------------------------------
# INSTALLATION CHECK ROUTINES
# ----------------------------------------------

proc lookfor_previous_install {pages} {
    # This procedure is similar to ''check_previous_install'' (see
    # after this proc). Instead of asking to uninstall a previous
    # installation it wants to have such. This is used by the
    # 'lite'  distribution to find the ActiveTcl installation to
    # upgrade.

    # Note that in contrast to ''check_previous_install'' this
    # procedure does not constitute its own page. It is called
    # by the ''intro'' page procedure and returns an error code
    # (0 = error, 1 = ok) and a message. The message can be set
    # even if there are no problems.

    # We can't do this for Unix. For these platforms the check is
    # done after querying the user for a directory.

    if {![string equal "windows" $::tcl_platform(platform)]} { return {1 ""} }

    package require registry

    set next 1
    set msg ""
    set keyp {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\TclPro}
    set keya {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl}

    if {![catch {registry get $keyp "CurrentVersion"} ver_dummy]} {
	# We have TclPro already, no need to install it.

	set msg "$::AT(PGROUP) $ver_dummy is already installed. \
		\nIt is not possible to install $::AT(PGROUP) $::AT(VERSION)."
	set next 0

    } elseif {[catch {registry get $keya "CurrentVersion"} ver]} {
	# There is no ActiveTcl installed. Lite cannot be installed.

	# FIXME: We might want to check for an installation
	# of ActiveTclPro to give a more accurate error message.

	set msg "No installation of ActiveTcl found. \
		\nIt is not possible to install $::AT(NAME)."
	set next 0
    } else {
	# ActiveTcl found, but is it ok too ?

	if {[catch {registry get "$keya\\$ver" ""} verdir]} {
	    # This means that Lite should not be installed, it
	    # would mean trouble.

	    set msg "Previously installed version \"$ver\"\
		    partially uninstalled.\
		    It is not possible to use \"$::AT(NAME)\"."
	    set next 0
	} elseif {[string match "8.3.3.2" $ver]} {
	    set msg "You are currently using ActiveTcl $ver.\
		    \n\t(installed in $verdir)\
		    \n\n$::AT(NAME) $::AT(VERSION) cannot be used\
		    with this installation.\nPlease install\
		    ActiveTcl 8.3.4.1 or higher."
	    set next 0
	} elseif {
	    ([regexp -all {\.} $ver] == 3) &&
	    [package vsatisfies $ver 8.3.3.2]
	} {
	    # It is of type M.m.p.build and is >= 8.3.3.2
	    # If it satisfies 8.3.4.1. installation may proceed

	    if {[package vsatisfies $ver 8.3.4.1]} {
		set msg "Upgrading ActiveTcl $ver \
			(installed in $verdir)\nusing\
			$::AT(NAME) $::AT(VERSION)"
		# Use the location of ActiveTcl for our installation too.
		set ::INSTALL_DIR $verdir
	    } else {
		set msg "You are currently using ActiveTcl $ver.\
			\n\t(installed in $verdir)\
			\n\n$::AT(NAME) $::AT(VERSION) cannot be used\
			with this installation. Please install\
			ActiveTcl 8.3.4.1 or higher."
		set next 0
	    }
	} else {
	    set msg "Unrecognized installed ActiveTcl version \"$ver\".\
		    \n\n$::AT(NAME) $::AT(VERSION) cannot be used\
		    with this installation."
	    set next 0
	}
    }

    ## The checking is done, now show the results.

    if {![string length $msg]} {
	set msg "Internal error, no message was set"
	set next 0
    }

    return [list $next $msg]
}

proc check_previous_install {pages} {
    # The purpose of this is to verify how we will interact with
    # previous installations.  At this point, it only helps uninstall
    # ActiveTcl 8.3.3.2 since that had no uninstaller.

    if {![string equal "windows" $::tcl_platform(platform)]} { return 1 }

    package require registry

    set msg ""
    set key "HKEY_LOCAL_MACHINE\\SOFTWARE\\ActiveState\\$::AT(PGROUP)"

    if {![catch {registry get $key "CurrentVersion"} ver]} {
	if {[catch {registry get "$key\\$ver" ""} verdir]} {
	    set msg "Previously installed version \"$ver\"\
		    partially uninstalled."
	} elseif {[string equal $::AT(MODE) normal] && [string match "8.3.3.2" $ver]} {
	    set msg "You are currently using a previous install\
		    of $::AT(PGROUP) $ver.\
		    \n\t(installed in $verdir)\
		    \n\nDo you want to uninstall this before continuing?"

	    button $::BTNS.unst -text "Uninstall 8.3.3.2" \
		    -command [subst {
		uninstall-8.3.3.2 [list [file join $verdir]]
		# We restart this screen to start the process over.
		destroy $::BTNS.unst
		# The value one means continue after finishing uninstall
		set ::WAIT 1
	    }
	    ]
	    grid $::BTNS.unst -row 0
	} elseif {[regexp -all {\.} $ver] == 3} {
	    if {[string equal $::AT(MODE) normal] && [package vsatisfies $ver 8.3.3.2]} {
		# It is of type M.m.p.build and is >= 8.3.3.2
		#
		set msg "You are currently using a previous install\
			of $::AT(PGROUP) $ver.\
			\n\t(installed in $verdir)\
			\n\It is recommended that you uninstall this before\
			continuing."
	    } elseif {[string equal $::AT(MODE) pro] && [package vsatisfies $ver 1.5.0.1]} {
		# It is of type M.m.p.build and is >= 1.5.0.1
		#
		set msg "You are currently using a previous install\
			of $::AT(PGROUP) $ver.\
			\n\t(installed in $verdir)\
			\n\It is recommended that you uninstall this before\
			continuing."
	    } else {
		set msg "Unrecognized installed $::AT(PGROUP) version \"$ver\"."
	    }
	} else {
	    set msg "Unrecognized installed $::AT(PGROUP) version \"$ver\"."
	}
    }

    if {[string length $msg]} {
	set page [$pages getframe cinst]
	if {![winfo exists $page]} {
	    set page [$pages add cinst]
	    label $page.msg -anchor nw -justify left -width 70
	    grid $page.msg -sticky new -padx 8 -pady 4
	    grid rowconfigure $page 0 -weight 1
	    grid columnconfig $page 0 -weight 1
	}
	$page.msg configure -text $msg
	$pages raise cinst

	set res [wait_next]
	catch {destroy $::BTNS.unst}
	return $res
    }

    return 1
}

# ----------------------------------------------

proc browse_dir {e} {
    set dir [tk_chooseDirectory]
    if {[string length $dir]} {
	$e delete 0 end
	$e insert end $dir
    }
}

proc install_ok {dir} {
    $::NEXT configure -state [expr {($dir == "")?"disabled":"normal"}]
    return 1
}

proc get_installdir {pages} {
    set pname query
    set page [$pages getframe $pname]
    if {![winfo exists $page]} {
	set page [$pages add $pname]
	label $page.msg -anchor nw -justify left -width 70 \
		-text "Please specify the installation directory."
	label $page.errmsg -anchor nw -justify left -fg red
	grid $page.msg -columnspan 2 -sticky new -padx 4 -pady 4
	grid $page.errmsg -columnspan 2 -sticky new -padx 8

	entry  $page.ent -width 40 -validate key -vcmd { install_ok %P }
	button $page.browse -image [Bitmap::get open] \
		-command [list browse_dir $page.ent]
	grid $page.ent $page.browse -sticky news

	grid rowconfigure $page 0 -weight 1
	grid columnconfig $page 0 -weight 1

	bind $page.ent <Key-Return> { next }
    }
    $pages raise $pname
    focus $page.ent

    $page.ent delete 0 end
    $page.ent insert end $::INSTALL_DIR
    after idle [list $page.ent validate]

    if {[string length $::ERRMSG]} {
	$page.errmsg configure -text $::ERRMSG
    }

    # -2 means skip over check_previous_install when going back
    set res [wait_next -2]
    set ::INSTALL_DIR [$page.ent get]
    set ::DEMO_DIR    [default_demodir $::INSTALL_DIR]
    if {$res < 0} { return $res }

    ## Here is the place where the entered directory is verified.

    if {[string equal $::AT(MODE) lite]} {
	foreach {::INSTALL_DIR ::ERRMSG} [check_installdir_lite $::INSTALL_DIR] {break}
	if {[string length $::ERRMSG]} {
	    # Something wrong with dir, do this again
	    return 0
	} else {
	    # Skip the overinstall check and demo dir
	    set ::ERRMSG ""
	    return 3
	}
    } else {
	foreach {::INSTALL_DIR ::ERRMSG} [check_installdir $::INSTALL_DIR] {break}
	if {[string length $::ERRMSG]} {
	    # Something wrong with dir, do this again
	    return 0
	} elseif {[string length $::AT(InstVersion)]} {
	    # That we are here means that overinstallation was/is allowed.
	    # Moved to next step (overinstall check).
	    set ::ERRMSG ""
	    return 1
	} else {
	    # Skip the overinstall check
	    set ::ERRMSG ""
	    return 2
	}
    }
}

# ----------------------------------------------

proc overinstall {pages} {
    set page [$pages getframe overinstall]
    if {![winfo exists $page]} {
	set page [$pages add overinstall]
	label $page.msg -anchor nw -justify left -width 70 \
		-text [overinstall_warning]
	grid $page.msg -sticky new -padx 8 -pady 4
	grid rowconfigure $page 0 -weight 1
	grid columnconfig $page 0 -weight 1
    }
    $pages raise overinstall

    return [wait_next]
}

# ----------------------------------------------

proc get_demodir {pages} {
    set pname demos
    set page [$pages getframe $pname]
    if {![winfo exists $page]} {
	set page [$pages add $pname]
	label $page.msg -anchor nw -justify left -width 70 \
		-text "Please specify the demos directory."
	label $page.errmsg -anchor nw -justify left -fg red
	grid $page.msg -columnspan 2 -sticky new -padx 4 -pady 4
	grid $page.errmsg -columnspan 2 -sticky new -padx 8

	entry  $page.ent -width 40 -validate key -vcmd { install_ok %P }
	button $page.browse -image [Bitmap::get open] \
		-command [list browse_dir $page.ent]
	grid $page.ent $page.browse -sticky news

	grid rowconfigure $page 0 -weight 1
	grid columnconfig $page 0 -weight 1

	bind $page.ent <Key-Return> { next }
    }
    $pages raise $pname
    focus $page.ent

    $page.ent delete 0 end
    $page.ent insert end $::DEMO_DIR
    after idle [list $page.ent validate]

    if {[string length $::ERRMSG]} {
	$page.errmsg configure -text $::ERRMSG
    }

    # -2 means skip over overinstall warning when going back
    set res [wait_next -2]
    set ::DEMO_DIR [$page.ent get]
    if {$res < 0} { return $res }

    foreach {::DEMO_DIR ::ERRMSG} [check_demodir $::DEMO_DIR] {break}
    if {[string length $::ERRMSG]} {
	# Something wrong with dir, do this again
	return 0
    } else {
	return 1
    }
}

# ----------------------------------------------

proc install_ready {pages} {
    set pname ready
    set page [$pages getframe $pname]
    set firsttime 0
    if {![winfo exists $page]} {
	set firsttime 1
	set page [$pages add $pname]
	grid [ScrolledWindow $page.s -auto both] -sticky news -padx 4 -pady 4
	set tw [text $page.s.t -width 20 -height 8 -wrap none]
	$page.s setwidget $tw

	grid columnconfigure $page 0 -weight 1
	grid rowconfigure $page 0 -weight 1

	if {[string equal $::AT(MODE) lite]} {
	    set ::DEMO_DIR {}
	    $tw insert 1.0 "Press 'Next' to begin installation\n" "" \
		    "     Installation Directory:\t$::INSTALL_DIR\n" ""
	} else {
	    $tw insert 1.0 "Press 'Next' to begin installation\n" "" \
		    "     Installation Directory:\t$::INSTALL_DIR\n" "" \
		    "     Demos Directory:\t$::DEMO_DIR\n\n"
	}

	$tw configure -state disabled
	$tw tag configure error -background #CC4444

	# Accept focus even when disabled
	bind $tw <1>		{ focus %W }
	bind $tw <Key-Return>	{ next }
    }
    after idle license_ok
    $pages raise $pname
    set ::LOGWIN $page.s.t

    set res [wait_next]
    if {$res < 0} {
	# The exact target depends on the current combination of
	# lite/platform: No lite => Standard behaviour

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

	if {[string equal "windows" $::tcl_platform(platform)]} {
	    return -4 ; # We are state 7, target is 3 (lookfor_previous)
	} else {
	    return -3 ; # Target state is 4 (get_installdir)
	}
    }

    # At this point, there is no going back
    grid remove $::BACK $::NEXT

    # Install all the files
    do_install_modules $::SCRIPT_DIR $::INSTALL_DIR $::DEMO_DIR
    # Patch files or add registry stuff
    do_finish $::SCRIPT_DIR $::INSTALL_DIR

    log "\n[parting_message]"

    # This only allows exit
    wait_next 0 0 "Finish"
}

# ----------------------------------------------
# LOGGING ROUTINE
# ----------------------------------------------

proc log {msg {type ok}} {
    if {[string length $msg]} {
	$::LOGWIN configure -state normal
	$::LOGWIN insert end "$msg\n" $type
	$::LOGWIN see end
	$::LOGWIN configure -state disabled
	update
    }
}

# ----------------------------------------------
# WAIT ROUTINES
# ----------------------------------------------

proc next {} { $::NEXT invoke }
proc cancel {} { exit 0 }

proc wait_next {{back -1} {next 1} {cancel "Cancel"}} {
    if {$back} { grid $::BACK } else { grid remove $::BACK }
    if {$next} { grid $::NEXT } else { grid remove $::NEXT }
    $::BACK configure -state normal -command [list set ::WAIT $back]
    $::NEXT configure -state normal -command [list set ::WAIT $next]
    $::CANCEL configure -text $cancel -state normal -command cancel

    vwait ::WAIT
    return $::WAIT
}

# ----------------------------------------------
# SPECIAL UNINSTALLER FOR 8.3.3.2
# ----------------------------------------------

proc uninstall-8.3.3.2 {dir} {
    # This version came without an INSTALL.LOG
    # Just be a little brutal in getting rid of it
    foreach file [list \
	    $dir/bin/itcl32.dll \
	    $dir/bin/itk32.dll \
	    $dir/bin/tcl83.dll \
	    $dir/bin/tclpip83.dll \
	    $dir/bin/tclsh83.exe \
	    $dir/bin/tclx83.dll \
	    $dir/bin/tk83.dll \
	    $dir/bin/tkcon.tcl \
	    $dir/bin/tkx83.dll \
	    $dir/bin/wish83.exe \
	    $dir/doc/ActiveTclHelp.chm \
	    $dir/include \
	    $dir/lib/bwidget1.3.0 \
	    $dir/lib/dde1.1 \
	    $dir/lib/itcl3.2 \
	    $dir/lib/itk3.2 \
	    $dir/lib/iwidgets \
	    $dir/lib/iwidgets3.0.2 \
	    $dir/lib/reg1.0 \
	    $dir/lib/tcl8.3 \
	    $dir/lib/tcllib1.0 \
	    $dir/lib/tclX8.3 \
	    $dir/lib/tk8.3 \
	    $dir/lib/Tktable2.7 \
	    $dir/lib/tkX8.3 \
	    $dir/license.terms \
	    $dir/README.txt \
	    ] {
	file delete -force $file
    }
    catch {eval file delete -force [glob -nocomplain $dir/lib/*.{sh,lib}]}
    foreach subdir {bin doc include lib} {
	if {[llength [glob -nocomplain $dir/$subdir/*]] == 0} {
	    file delete -force $dir/$subdir
	}
    }
    if {[llength [glob -nocomplain $dir/*]] == 0} {
	file delete -force $dir
    }
    package require registry
    catch {
	registry delete \
		{HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl} \
		"CurrentVersion"
    }
    catch {
	registry delete \
		{HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl\8.3.3.2}
    }
    catch {
	package require dde
	dde execute progman progman {[DeleteGroup(ActiveState ActiveTcl)]}
    }
}

# ----------------------------------------------
# GO TO IT
# ----------------------------------------------

set ::SCRIPT_DIR [file dirname [info script]]
set here [pwd] ; cd $::SCRIPT_DIR ; set ::SCRIPT_DIR [pwd] ; cd $here

if {[catch {
    source [file join $SCRIPT_DIR install_lib.tcl]
    main
} err]} {
puts $err
    catch {bgerror $err}
}
#puts Exiting
exit