#
#
# install.tcl - Installation support
#
option add *Entry.background		white	startup
option add *Entry.foreground 		black 	startup
option add *Button.padX 		1	startup
option add *Button.padX 		1	startup
option add *Button.highlightThickness 	0	startup
option add *Entry.relief 		flat	startup
option add *Entry.highlightThickness 	0	startup
option add *font 			fixed 	startup

proc install_init { appName dotFile } {
    global install env tcl_platform wish
    set install(appName) $appName
    set install(appname) [string tolower $appName]
    set install(dirlist) {}
    set install(filecheck) {}
    set install(progcheck) {}
    switch -- $tcl_platform(platform) {
	windows {
	    set wish "c:\\Program Files\\wish41.exe"
	}
	macintosh {
	    # doesn't matter - we aren't doing a shell script anyway.
	    set wish "Wish 4.1"
	}
	default { 
	    set wish wish4.1
	    foreach dir [split $env(PATH) :] {
		if [file exists [file join $dir wish4.1]] {
		    set wish [file join $dir wish4.1]
		    break
		}
	    }
	}
    }
    install_progVar wish $wish {wish absolute pathname}
    set install(dotFile) $dotFile
    if [file readable $dotFile] {
	if [catch {uplevel #0 source $dotFile} msg] {
	    puts stderr "source $dotFile: $msg"
	}
    } else {
	if {[catch {glob ../$install(appname)*/$dotFile} files] == 0} {
	    installAlternates $files 1
	}
    }
}
proc installAlternates { files isdefault } {
    wm withdraw .
    toplevel .config
    set fm [frame .config.rim -bd 10]
    message $fm.msg -aspect 1500 -text \
"Please select an alternate configuration."
    pack $fm -fill both -expand 1
    pack $fm.msg
    set id 0
    foreach f $files {
	button $fm.but$id -text $f -command [list installConfig $f $isdefault]
	pack $fm.but$id -fill both -expand 1
	incr id
    }
    button $fm.but$id -text "Ignore configurations" -command installConfig
    pack $fm.but$id -fill both -expand 1
    tkwait window .config
    wm deiconify .
}
proc installConfigs {} {
    global install
    if {[catch {glob ../$install(appname)*/$install(dotFile)*} files] == 0} {
	installAlternates $files 0
    }
}
proc installConfig { {file {}} {isdefault 1} } {
    global install
    installFeedback "installConfig $file"
    if {$file != {}} {
	if [catch {uplevel #0 source $file} msg] {
	    installFeedback $msg
	    return
	}
	if {! $isdefault} {
	    set install(dotFile) $file
	}
    }
    destroy .config
}
proc install_var { var value {comment {}} } {
    global install
    lappend install(sequence) $var
    set install(default,$var) $value
    set install(comment,$var) $comment
    upvar #0 $var x
    if ![info exists x] {
	set x $value
    }
}
proc install_version { var version {comment {Version stamp}} } {
    global install
    install_var $var $version $comment
    upvar #0 $var x
    set x $version		;# Override saved version, if any
    set install(versionVar) $var
}
proc install_dir { var value comment } {
    global install
    lappend install(dirlist) $var
    install_var $var $value $comment
}
proc install_glob { name args } {
    global install
    set install(glob,$name) $args
}
proc install_fileVar { var pathname comment } {
    install_var $var $pathname $comment
    global install
    lappend install(filecheck) $var
#    set install(filecheck,$var) $comment
}
proc install_progVar { var pathname comment } {
    install_var $var $pathname $comment
    global install
    lappend install(progcheck) $var
#    set install(progcheck,$var) $comment
}
proc install_sed { suffix args } {
    global install
    set install(sedSuffix) $suffix
    set install(sedProgs) $args
}
proc install_libDir {var pathname comment} {
    global install
    install_dir $var $pathname $comment
}
proc install_testdir {var pathname} {
    global install
    set install(test,$var) $pathname
}
proc install_expect { var pathname comment } {
    install_progVar $var $pathname $comment
    global install
    set install(expectVar) $var
}

proc install_ps { var cmd comment } {
    install_var $var $cmd $comment
    global install
    set install(psVar) $var
}

proc installFieldVar { var } { return $var }
proc installFieldComment { var } {
    global install ; return $install(comment,$var)
}
proc installFieldDefault { var } {
    global install ; return $install(default,$var)
}

proc install_help { text } {
    global install
    set install(helpText) $text
}

proc installFeedback { text } {
    global install
    catch {
	$install(msg) configure -text $text
	update
    }
}
proc installError { text } {
    puts stderr $text
    installFeedback $text
}
proc installFieldInit {} {
    global install
    set install(lastentry) {}
}
proc installDoField { var } {
    global install
    if ![info exists install(wuid)] { set install(wuid) 0 }
    incr install(wuid)
    set f [frame .rim.import$install(wuid) -relief raised]
    button $f.label -text [format "%-30s:" [installFieldComment $var]] \
	-command "installShowValue $var" -font fixed
    entry $f.entry -font fixed -width 40 -textvariable $var
    set install($var,entry) $f.entry

    pack $f -side top -expand true -fill both
    pack $f.label -side left -padx 3
    pack $f.entry -side right -expand true -fill both
}
proc installUpdateFieldXX { item {override 0} } {
    global install
    set var [installFieldVar $item]
    set entry $install(entry,$var)
    $entry delete 0 end
    $entry insert 0 [installFieldDefault $item $override]
}
proc installFieldDone {} {
}
proc installFieldDoneXX {} {
    global install
    if {[info exists install(firstentry)] && \
	[info exists install(lastentry)]} {
	bind $install(lastentry) <Tab> [list focus $install(firstentry)]
    }
}

proc installSetValue { _var } {
}
proc installSetValueXX { _var } {
    global install
    if [info exists install(entry,$_var)] {
	set _value [$install(entry,$_var) get]
	if [string match *(* $_var] {
	    set _arrayName [lindex [split $_var (] 0]
	    global $_arrayName
	} else {
	    global $_var
	}
	set $_var $_value
#	installFeedback "$_var $_value"
    }
}
proc installGetValue { varName } {
    upvar #0 $varName var
    if ![info exists var] {
	puts stderr "Undefined $varName"
	return ""
    } else {
	return $var
    }
}
proc installShowValue { var } {
    global install
    if [info exists install(entry,$var)] {
	set entry $install(entry,$var)
	$entry select from 0
	$entry select to end
	focus $entry
    }
}
proc installVerify {} {
    global install
    installFeedback "Checking Pathnames..."
    set errors {}
    foreach var $install(dirlist) {
	set path [installGetValue $var]
	if {[string length $path] == 0} {
	    continue
	}
	if ![file isdirectory $path] {
	    set willMakeDir 0
	    foreach dirVar $install(dirlist) {
		if [info exists install(glob,$dirVar)] {
		    set willMakeDir 1
		}
	    }
	    if {! $willMakeDir} {
		lappend errors [format "Not a directory: %s <%s>" \
		    $path [installFieldComment $var]]
	    } else {
		lappend errors [format "Will create directory: %s <%s>" \
		     $path [installFieldComment $var] ]
	    }
	}
	if ![regexp ^/ $path] {
	    lappend errors [format "%-30s Warning: <%s> %s" \
		[installFieldComment $var] $path "is not an absolute pathname"]
	}
    }
    foreach var $install(filecheck) {
	set path [installGetValue $var]
	if {[string length $path] == 0} {
	    continue
	}
	if ![file exists $path] {
	    lappend errors [format "%-30s <%s> %s" \
		[installFieldComment $var] $path "does not exist"]
	}
	if ![regexp ^/ $path] {
	    lappend errors [format "%-30s Warning: <%s> %s" \
		[installFieldComment $var] $path "is not an absolute pathname"]
	}
    }
    foreach var $install(progcheck) {
	set path [installGetValue $var]
	if {[string length $path] == 0} {
	    continue
	}
	if ![file executable $path] {
	    lappend errors [format "%-30s <%s> %s" \
		[installFieldComment $var] $path "is not executable"]
	}
	if ![regexp ^/ $path] {
	    lappend errors [format "%-30s Warning: <%s> %s" \
		[installFieldComment $var] $path "is not an absolute pathname"]
	}
    }
    if [info exists install(psVar)] {
	if [catch {eval exec $cmd [pid]} err] {
	    lappend errors [format "%-30s Warning: <%s> %s" \
		"ps command" "$cmd [pid]" $err]
	}
    }
    if {$errors != {}} {
	installFeedback "Verify errors"
    } else {
	installFeedback "Verify OK"
	return
    }
    catch {destroy .verify}
    toplevel .verify
    frame .verify.top
    button .verify.top.quit -text "Dismiss" -command {destroy .verify}
    label .verify.top.label -text "  Verify Errors "
    pack .verify.top -side top -fill both -expand true
    pack .verify.top.quit -side left
    pack .verify.top.label -side left -fill both

    set numLines [llength $errors]
    if {$numLines > 30} {
	set numLines 30
    }
    text .verify.t -width 80 -height $numLines -yscrollcommand {.verify.s set} -font fixed
    scrollbar .verify.s -orient vert -command {.verify.t yview}
    pack .verify.s -side right -fill y
    pack .verify.t -side left -expand true -fill both
    foreach line $errors {
	.verify.t insert end $line\n
    }

}

proc installRegsub {Xvar old new} {
    upvar $Xvar X
    # denature old and new
    regsub -all {[&\\]} $new {\\&} new
    regsub -all {[][\+\?\$\|\\]} $old {\\&} old
    # replace all
    regsub $old $X $new X
}
proc installSed { } {
    global install

    # Create configuration information
    set config #CONFIGURATION\n
    foreach var $install(sequence) {
	append config [list set $var [installGetValue $var]] \n
    }
    foreach prog $install(sedProgs) {
	set out ""
	if { [catch {open ${prog}$install(sedSuffix)} in] ||
		[catch {open ${prog} w} out] } {
	    installFeedback "Cannot patch $prog: $in $out"
	    continue
	}
	# read the old file and use regsub to edit it.

	set X [read $in]
	close $in
    
	set w [installGetValue wish]
	installRegsub X "exec wish4.1" "exec $w"
    
	# Set up for helper expect scripts, if needed and if possible
	if [info exists install(expectVar)] {
	    set pathname [installGetValue $install(expectVar)]
	    installRegsub X "exec expect" "exec $pathname"
	}
	if ![installRegsub X #CONFIGURATION\n $config] {
	    installFeedback "Could not patch in configuration"
	}

	# write the new file
	puts $out $X
	close $out
    }
}
proc installPatch {} {
    global install
    installSave
    installVerify
    installSed
    set sample [lindex $install(sedProgs) 0]
    catch {exec diff -c ${sample}$install(sedSuffix) $sample} diff
    catch {destroy .test}
    set numLines [llength [split $diff \n]]
    if {$numLines == 0} {
	installFeedback "No diffs after patching"
	return
    }
    toplevel .test
    frame .test.top
    button .test.top.quit -text "Dismiss" -command {destroy .test}
    label .test.top.label -text "  Context diff of $sample"
    pack .test.top -side top -fill both -expand true
    pack .test.top.quit -side left 
    pack .test.top.label -side left -fill both

    installFeedback "$numLines lines of diff output"
    if {$numLines < 30} {
	text .test.t -width 80 -height $numLines -font fixed
	pack .test.t -side bottom -expand true -fill both
    } else {
	text .test.t -width 80 -height 30 -yscrollcommand {.test.s set} -font fixed
	scrollbar .test.s -orient vert -command {.test.t yview}
	pack .test.s -side right -fill y
	pack .test.t -side left -expand true -fill both
    }
    .test.t insert end $diff
}
proc install_test { args } {
    global install
    set install(test) $args
}
proc installTest {} {
    global install
    # Run patch again with testing library, if it is defined
    set real {}
    foreach x [array names install] {
	if [regexp test,(.*) $x z varname] {
	    upvar #0 $varname var
	    if [info exists var] {
		set install(real,$varname) $var
		set var $install(test,$varname)
		lappend real $varname
	    }
	}
    }
    installSed
    if [info exists install(test)] {
	installFeedback $install(test)
	eval $install(test)
    } else {
	installFeedback "No install_test command"
    }
    foreach varname $real {
	upvar #0 $varname var
	set var $install(real,$varname)
    }
}
proc installTclIndex {} {
    installFeedback "Refreshing ./lib/tclIndex"
    auto_mkindex ./lib *.tcl
    installFeedback ""
}

proc installButton {} {
	button .rim.buttons.yes -text "Really Install" -command {installInner}
    button .rim.buttons.no -text "Cancel" -command {installCancel}
    pack forget .rim.buttons.install
    pack .rim.buttons.no .rim.buttons.yes -side left
}
proc installSave { } {
    global install argv0
    # Save it
    installSetValue install(dotFile)
    if [catch {open $install(dotFile) w} out] {
	installFeedback "Cannot write $install(dotFile)"
	return
    }
    if ![info exists argv0] {
	set argv0 $install(appname).install
    }
    puts $out "# Saved state from $argv0"
    puts $out "# [exec date]"
    foreach varName $install(sequence) {
	set value [installGetValue $varName]
	puts $out [list set $varName $value]
    }
    close $out
    installFeedback "Saved settings in $install(dotFile)"
}
proc installCancel {} {
    after 10 {
	destroy .rim.buttons.yes ; destroy .rim.buttons.no
	pack .rim.buttons.install -before .rim.buttons.quit -side left
    }
}
proc installCmd { logProc unixCmd } {
    if {$logProc != "nolog"} {
	$logProc $unixCmd
    } else {
	if ![regexp ^# $unixCmd] {
	    eval exec $unixCmd
	}
    }
}
proc installInner { {logProc nolog} } {
    global install
    installVerify
    installSed
    foreach dirVar $install(dirlist) {
	#
	# Install directory - make sure it exists
	#
	set dir [installGetValue $dirVar]
	MakeDir $logProc $dir
	if {($logProc == "nolog") && ![file isdirectory $dir]} {
	    installError "LibDir $dir is not a directory"
	    continue
	} 
	if [info exists install(glob,$dirVar)] {
	    #
	    # Install glob pattern - copy the files in
	    #
	    foreach f [eval glob -nocomplain $install(glob,$dirVar)] {
		if [catch {
		    set t [file tail $f]
		    if {$dirVar == "man"} {
			# Hack to tweak file suffix
			set end [expr [string length $dir]-1]
			set suffix [string index $dir $end]
			set newf [file root $t].$suffix
		    } else {
			set newf $t
		    }
		    if {![catch {file stat $dir/$newf old}] &&
			![catch {file stat $f new}] &&
			($old(dev) == $new(dev)) &&
			($old(ino) == $new(ino))} {
			installCmd $logProc [list #File OK: $dir/$newf]
		    } else {
			if [file isdirectory $f] {
			    installCmd $logProc [list rm -rf $dir/$newf]
			    installCmd $logProc [list cp -r $f $dir/$newf]
			} else {
			    installCmd $logProc [list rm -f $dir/$newf]
			    installCmd $logProc [list cp $f $dir/$newf]
			}
		    }
		    if {$dirVar == "bin"} {
			installCmd $logProc [list chmod a+rx $dir/$newf]
		    } else {
			installCmd $logProc [list chmod a+r $dir/$newf]
		    }
		} msg] {
		    installFeedback "Dir install error: $msg"
		    return
		} else {
		    if {$logProc == "nolog"} {
			installFeedback "Installed $newf"
		    }
		}
	    }
	}
    }
    if {$logProc == "nolog"} {
	installCancel
	installFeedback "Install complete"
    }
}
proc MakeDir { logProc dir } {
    if [file isdirectory $dir] {
	return 1
    } elseif [file exists $dir] {
	installError "LibDir $dir is not a directory"
	return 0
    } else {
	if [MakeDir $logProc [file dirname $dir]] {
	    installCmd $logProc [list mkdir $dir]
	    installCmd $logProc [list chmod a+rx $dir]
	    return 1
	} else {
	    return 0
	}
    }
}
proc installFake {} {
    global exmh install
    toplevel .fake
    frame .fake.top
    button .fake.top.quit -text "Dismiss" -command {destroy .fake}
    label .fake.top.label -text "  Pending install actions"
    pack .fake.top -side top -fill both -expand true
    pack .fake.top.quit -side left
    pack .fake.top.label -side left -fill both

    text .fake.t -width 80 -height 20 -yscrollcommand {.fake.s set} -font fixed
    scrollbar .fake.s -orient vert -command {.fake.t yview}
    pack .fake.s -side right -fill y
    pack .fake.t -side left -expand true -fill both

    proc log { text } {
	.fake.t insert end $text\n
    }
    installInner log
}
proc install_dialog {title} {
    global install tk_version

    wm title . $title
    wm minsize . 200 200

    toplevel .info
    wm title .info "Install info for $install(appName)"


    text .info.t
    .info.t config -yscrollcommand {.info.s set} -setgrid true
    wm minsize .info 40 10
    scrollbar .info.s -orient vert -command {.info.t yview}
    pack .info.s -side right -fill y
    pack .info.t -side left -fill both -expand true
    .info.t insert 1.0 $install(helpText)
    update idletasks

    frame .rim -bd 5 -relief flat
    pack .rim -side top -expand true -fill both

    installFieldInit
    foreach v $install(sequence) {
	installDoField $v
    }
    installFieldDone

    set install(msg) [label .rim.feedback -text "" -anchor w -padx 10]
    pack $install(msg) -side top -expand true -fill both
    
    frame .rim.buttons -relief raised
    pack .rim.buttons -side top -expand true -fill both
    
    button .rim.buttons.quit -text "Quit" -command {exit}
    button .rim.buttons.keys -text "Find/Replace" -command {installFind}
    button .rim.buttons.conf -text "Conf" -command {installConfigs}
    button .rim.buttons.patch -text "Patch" -command {installPatch}
    button .rim.buttons.test -text "Test" -command {installTest}
#    button .rim.buttons.register -text "Register" -command {install_register}
    button .rim.buttons.verify -text "Verify" -command {installFake}
    button .rim.buttons.install -text "Install" -command {installButton}
    button .rim.buttons.tclindex -text "TclIndex" -command {installTclIndex}
    frame .rim.buttons.space -width 10 -height 10

    button .rim.buttons.readme -text "I have read the instructions" \
	-command install_pack_buttons
    pack .rim.buttons.readme -side left
    pack .rim.buttons.quit -side right
}
proc install_pack_buttons {} {
    pack forget .rim.buttons.readme
    pack .rim.buttons.patch  \
	.rim.buttons.tclindex  \
	.rim.buttons.test  \
	.rim.buttons.verify  \
	.rim.buttons.space  \
	.rim.buttons.install -side left
    pack \
	.rim.buttons.quit  \
	.rim.buttons.keys  \
	.rim.buttons.conf -side right
}
proc installFind {} {
    toplevel .find
    message .find.msg -aspect 2000 -text \
"Global search and replace over the installer fields."
    pack .find.msg

    global install
    if ![info exists install(find)] {
	set install(find) /usr/local
    }

    set f [frame .find.find -bd 4]
    label $f.label -text Find: -anchor e -width 8
    entry $f.entry -textvariable install(find)
    bind $f.entry <Return> {focus .find.repl.entry}
    pack $f -side top -fill x
    pack $f.label -side left
    pack $f.entry -side top -fill x
    focus $f.entry

    set f [frame .find.repl -bd 4]
    button $f.label -text Replace: -anchor e -width 8 -command \
	{installFindInner $install(find) $install(replace)}
    entry $f.entry -textvariable install(replace)
    bind $f.entry <Return> {installFindInner $install(find) $install(replace)}
    pack $f -side top -fill x
    pack $f.label -side left
    pack $f.entry -side top -fill x
}
proc installFindInner {find repl} {
    global install
    foreach varName $install(sequence) {
	upvar #0 $varName var
	if [info exists var] {
	    regsub $find $var $repl var
	}
    }
}
proc install_register {} {
    global install
    upvar #0 $install(versionVar) vers

    catch {destroy .register}
    set t [toplevel .register]
    message $t.msg -text \
"Installer for $install(appName) $vers

Please register your copy of $install(appName)
so that we can keep you informed about
new releases of the software."


    frame $t.email
    label $t.email.label -text "Email Address"
    entry $t.email.entry -textvariable install(email)
    pack $t.email -side top -fill x -padx 10 -pady 5
    pack $t.email.label -side left
    pack $t.email.entry -side top -fill x

    frame $t.but
    pack $t.but -fill both

    button $t.cancel  -text "Register Now" -command installRegisterNow
    button $t.ok  -text "Do Not Register" -command [list installRegisterNow Cancel] -state normal
    pack $t.ok $t.cancel -side left -expand true -in $t.but -padx 10 -pady 10
}

proc installRegisterNow {{cancel {}}} {
    global install
    if {![info exists install(email)] || [string length $install(email)] == 0} {
	set install(email) "(unregistered)"
    }
    if {[string length $cancel] != 0} {
	wm withdraw .register
	update
    }

    catch {exec uname -a} uname
    regsub -all \n $install(appName) " " product
    set msg \
"To: brent.welch@eng.sun.com
Subject: Register $product
From: $install(email)

$install(email) is a registered user of $product
$uname
"
    catch {
	exec /usr/lib/sendmail brent.welch@eng.sun.com << $msg
    } 
    if {[string length $cancel] == 0} {
	.register.msg config -text "Registration Complete"
	pack forget .register.cancel
	.register.ok config -text "Dismiss" -command {destroy .register}
	return
    } else {
	destroy .register
    }
}

