#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
# --------------------------------------------------------------
# Installer for Tcllib. The lowest version of the tcl core supported
# by any module is 8.5. So we enforce that the installer is run with
# at least that.
#
# This installer does not handle Tcllibc.
package require Tcl 8.5 9
set distribution [file dirname [info script]]
lappend auto_path [file join $distribution modules]
# --------------------------------------------------------------
# Version information for tcllib.
# List of modules to install (and definitions guiding the process)
proc package_name {text} {global package_name ; set package_name $text}
proc package_version {text} {global package_version ; set package_version $text}
proc dist_exclude {path} {}
proc critcl {name files} {}
proc critcl_main {name files} {}
proc critcl_notes {text} {}
source [file join $distribution support installation version.tcl] ; # Get version information.
source [file join $distribution support installation modules.tcl] ; # Get list of installed modules.
source [file join $distribution support installation actions.tcl] ; # Get code to perform install actions.
set package_nv ${package_name}-${package_version}
set package_name_cap [string toupper [string index $package_name 0]][string range $package_name 1 end]
# --------------------------------------------------------------
# Low-level commands of the installation engine.
proc gen_main_index {outdir package version} {
global config
log "\nGenerating [file join $outdir pkgIndex.tcl]"
if {$config(dry)} {return}
set index [open [file join $outdir pkgIndex.tcl] w]
puts $index "# Tcl package index file, version 1.1"
puts $index "# Do NOT edit by hand."
puts $index "# Generated by $package's installer for version $version"
lappend map "\n\t" "\n" "\n " "\n"
puts $index [string map $map {
# Hide from Tcl installations not providing the minimum runtime.
if {![package vsatisfies [package provide Tcl] 8.5 9]} return
# Extend the auto_path to make tcllib packages available
if {$dir ni $::auto_path} {
lappend ::auto_path $dir
}
}]
puts $index "# This definition exist only to convey which overall version of Tcllib is installed."
puts $index "# It intentionally does not `package require` the bundled packages."
puts $index "package ifneeded tcllib $version \{package provide tcllib $version\}"
puts $index ""
puts $index "# Preload the bundled definitions"
puts $index "apply \{\{maindir\} \{"
puts $index " foreach module \{"
set buf {}
foreach pi [lsort [glob -nocomplain [file join $outdir * pkgIndex.tcl]]] {
set subdir [file tail [file dirname $pi]]
lappend buf $subdir
if {[string length $buf] > 60} { puts $index " $buf" ; set buf {} }
}
if {[llength $buf]} { puts $index " $buf" }
puts $index " \} \{"
puts $index " set dir \[file join \$maindir \$module\]"
#puts $index " if {!\[file exists $dir\]} continue"
#puts $index " if {!\[file isdirectory $dir\]} continue"
puts $index " source \[file join \$dir pkgIndex.tcl\]"
puts $index " \}"
puts $index "\}\} \$dir"
puts $index "return"
puts $index ""
close $index
return
}
proc xcopyfile {src dest} {
# dest can be dir or file
run file copy -force $src $dest
return
}
proc xcopy {src dest recurse {pattern *}} {
run file mkdir $dest
if {[string equal $pattern *] || !$recurse} {
foreach file [glob -nocomplain [file join $src $pattern]] {
set base [file tail $file]
set sub [file join $dest $base]
if {0 == [string compare CVS $base]} {continue}
if {[file isdirectory $file]} then {
if {$recurse} {
run file mkdir $sub
xcopy $file $sub $recurse $pattern
# If the directory is empty after the recursion remove it again.
if {![llength [glob -nocomplain [file join $sub *]]]} {
file delete $sub
}
}
} else {
xcopyfile $file $sub
}
}
} else {
foreach file [glob -nocomplain [file join $src *]] {
set base [file tail $file]
set sub [file join $dest $base]
if {[string equal CVS $base]} {continue}
if {[file isdirectory $file]} then {
if {$recurse} {
run file mkdir $sub
xcopy $file $sub $recurse $pattern
# If the directory is empty after the recursion remove it again.
if {![llength [glob -nocomplain [file join $sub *]]]} {
run file delete $sub
}
}
} else {
if {![string match $pattern $base]} {continue}
xcopyfile $file $sub
}
}
}
}
proc get_input {f} {return [read [set if [open $f r]]][close $if]}
proc write_out {f text} {
global config
if {$config(dry)} {log "Generate $f" ; return}
catch {file delete -force $f}
puts -nonewline [set of [open $f w]] $text
close $of
}
# --------------------------------------------------------------
# Use configuration to perform installation
proc clear {} {global message ; set message ""}
proc msg {text} {global message ; append message $text \n ; return}
proc get {} {global message ; return $message}
proc log {text} {
global config
if {!$config(gui)} {puts stdout $text ; flush stdout ; return}
.l.t insert end $text\n
.l.t see end
update
return
}
proc log* {text} {
global config
if {!$config(gui)} {puts -nonewline stdout $text ; flush stdout ; return}
.l.t insert end $text
.l.t see end
update
return
}
proc run {args} {
global config
if {$config(dry)} {
log [join $args]
return
}
if {[catch {eval $args} msg]} {
if {$config(gui)} {
installErrorMsgBox $msg
} else {
return -code error "Install error:\n $msg"
}
}
log* .
return
}
proc xinstall {type args} {
global modules guide
foreach m $modules {
eval $guide($m,$type) $m $args
}
return
}
proc ainstall {} {
global apps config tcl_platform distribution
if {[string compare $tcl_platform(platform) windows] == 0} {
set ext .tcl
} else {
set ext ""
}
foreach a $apps {
set aexe [file join $distribution apps $a]
set adst [file join $config(app,path) ${a}$ext]
log "\nGenerating $adst"
if {!$config(dry)} {
file mkdir [file dirname $adst]
catch {file delete -force $adst}
file copy -force $aexe $adst
}
}
return
}
proc doinstall {} {
global config package_version distribution package_name modules excluded
if {!$config(no-exclude)} {
foreach p $excluded {
set pos [lsearch -exact $modules $p]
if {$pos < 0} {continue}
set modules [lreplace $modules $pos $pos]
}
}
if {$config(doc,nroff)} {
set config(man.macros) [string trim [get_input \
[file join $distribution support installation man.macros]]]
}
if {$config(pkg)} {
xinstall pkg $config(pkg,path)
gen_main_index $config(pkg,path) $package_name $package_version
}
if {$config(doc,nroff)} {
foreach dir [glob -directory $distribution/idoc/man/files/modules *] {
xcopy $dir $config(doc,nroff,path) 1
}
xcopy $distribution/idoc/man/files/apps $config(doc,nroff,path) 1
}
if {$config(doc,html)} {
#xinstall doc html html $config(doc,html,path)
xcopy $distribution/idoc/www $config(doc,html,path) 1
}
if {$config(exa)} {xinstall exa $config(exa,path)}
if {$config(app)} {ainstall}
log ""
return
}
# --------------------------------------------------------------
# Initialize configuration.
array set config {
pkg 1 pkg,path {}
app 1 app,path {}
doc,nroff 0 doc,nroff,path {}
doc,html 0 doc,html,path {}
exa 1 exa,path {}
dry 0 wait 1 valid 1
gui 0 no-gui 0 no-exclude 0
}
# --------------------------------------------------------------
# Determine a default configuration, if possible
proc defaults {} {
global tcl_platform config package_version package_name distribution
if {[string compare $distribution [info nameofexecutable]] == 0} {
# Starpack. No defaults for location.
} else {
# Starkit, or unwrapped. Derive defaults location from the
# location of the executable running the installer, or the
# location of its library.
# For a starkit [info library] is inside the running
# tclkit. Detect this and derive the location from the
# location of the executable itself for that case.
if {[string match [info nameofexecutable]* [info library]]} {
# Starkit
set libdir [file join [file dirname [file dirname [info nameofexecutable]]] lib]
} else {
# Unwrapped.
if {[catch {set libdir [lindex $::tcl_pkgPath end]}]} {
set libdir [file dirname [info library]]
}
}
set basedir [file dirname $libdir]
set bindir [file join $basedir bin]
if {[string compare $tcl_platform(platform) windows] == 0} {
set mandir {}
set htmldir [file join $basedir ${package_name}_doc]
} else {
set mandir [file join $basedir man mann]
set htmldir [file join $libdir ${package_name}${package_version} ${package_name}_doc]
}
set config(app,path) $bindir
set config(pkg,path) [file join $libdir ${package_name}${package_version}]
set config(doc,nroff,path) $mandir
set config(doc,html,path) $htmldir
set config(exa,path) [file join $bindir ${package_name}_examples${package_version}]
}
if {[string compare $tcl_platform(platform) windows] == 0} {
set config(doc,nroff) 0
set config(doc,html) 1
} else {
set config(doc,nroff) 1
set config(doc,html) 0
}
return
}
# --------------------------------------------------------------
# Show configuration on stdout.
proc showpath {prefix key} {
global config
if {$config($key)} {
if {[string length $config($key,path)] == 0} {
puts "${prefix}Empty path, invalid."
set config(valid) 0
msg "Invalid path: [string trim $prefix " :"]"
} else {
puts "${prefix}$config($key,path)"
}
} else {
puts "${prefix}Not installed."
}
}
proc showconfiguration {} {
global config package_version package_name_cap
puts "Installing $package_name_cap $package_version"
if {$config(dry)} {
puts "\tDry run, simulation, no actual activity."
puts ""
}
puts "You have chosen the following configuration ..."
puts ""
showpath "Packages: " pkg
showpath "Applications: " app
showpath "Examples: " exa
if {$config(doc,nroff) || $config(doc,html)} {
puts "Documentation:"
puts ""
showpath "\tNROFF: " doc,nroff
showpath "\tHTML: " doc,html
} else {
puts "Documentation: Not installed."
}
puts ""
return
}
# --------------------------------------------------------------
# Setup the installer user interface
proc browse {label key} {
global config
set initial $config($key)
if {$initial == {}} {set initial [pwd]}
set dir [tk_chooseDirectory \
-title "Select directory for $label" \
-parent . \
-initialdir $initial \
]
if {$dir == {}} {return} ; # Cancellation
set config($key) $dir
return
}
proc setupgui {} {
global config package_name_cap package_version
set config(gui) 1
wm withdraw .
wm title . "Installing $package_name_cap $package_version"
foreach {w type cspan col row opts} {
.pkg checkbutton 1 0 0 {-anchor w -text {Packages:} -variable config(pkg)}
.app checkbutton 1 0 1 {-anchor w -text {Applications:} -variable config(app)}
.dnr checkbutton 1 0 2 {-anchor w -text {Doc. Nroff:} -variable config(doc,nroff)}
.dht checkbutton 1 0 3 {-anchor w -text {Doc. HTML:} -variable config(doc,html)}
.exa checkbutton 1 0 4 {-anchor w -text {Examples:} -variable config(exa)}
.spa frame 3 0 5 {-bg black -height 2}
.dry checkbutton 2 0 7 {-anchor w -text {Simulate installation} -variable config(dry)}
.pkge entry 1 1 0 {-width 40 -textvariable config(pkg,path)}
.appe entry 1 1 1 {-width 40 -textvariable config(app,path)}
.dnre entry 1 1 2 {-width 40 -textvariable config(doc,nroff,path)}
.dhte entry 1 1 3 {-width 40 -textvariable config(doc,html,path)}
.exae entry 1 1 4 {-width 40 -textvariable config(exa,path)}
.pkgb button 1 2 0 {-text ... -command {browse Packages pkg,path}}
.appb button 1 2 1 {-text ... -command {browse Applications app,path}}
.dnrb button 1 2 2 {-text ... -command {browse Nroff doc,nroff,path}}
.dhtb button 1 2 3 {-text ... -command {browse HTML doc,html,path}}
.exab button 1 2 4 {-text ... -command {browse Examples exa,path}}
.sep frame 3 0 8 {-bg black -height 2}
.run button 1 0 9 {-text {Install} -command {set ::run 1}}
.can button 1 1 9 {-text {Cancel} -command {exit}}
} {
eval [list $type $w] $opts
grid $w -column $col -row $row -sticky ew -columnspan $cspan
grid rowconfigure . $row -weight 0
}
grid .can -sticky e
grid rowconfigure . 9 -weight 1
grid columnconfigure . 0 -weight 0
grid columnconfigure . 1 -weight 1
wm deiconify .
return
}
proc handlegui {} {
setupgui
vwait ::run
showconfiguration
validate
toplevel .l
wm title .l "Install log"
text .l.t -width 70 -height 25 -relief sunken -bd 2
pack .l.t -expand 1 -fill both
return
}
# --------------------------------------------------------------
# Handle a command line
proc handlecmdline {} {
showconfiguration
validate
wait
return
}
proc processargs {} {
global argv argv0 config
while {[llength $argv] > 0} {
switch -exact -- [lindex $argv 0] {
+excluded {set config(no-exclude) 1}
-no-wait {set config(wait) 0}
-no-gui {set config(no-gui) 1}
-simulate -
-dry-run {set config(dry) 1}
-html {set config(doc,html) 1}
-nroff {set config(doc,nroff) 1}
-examples {set config(exa) 1}
-pkgs {set config(pkg) 1}
-apps {set config(app) 1}
-no-html {set config(doc,html) 0}
-no-nroff {set config(doc,nroff) 0}
-no-examples {set config(exa) 0}
-no-pkgs {set config(pkg) 0}
-no-apps {set config(app) 0}
-pkg-path {
set config(pkg) 1
set config(pkg,path) [lindex $argv 1]
set argv [lrange $argv 1 end]
}
-app-path {
set config(app) 1
set config(app,path) [lindex $argv 1]
set argv [lrange $argv 1 end]
}
-nroff-path {
set config(doc,nroff) 1
set config(doc,nroff,path) [lindex $argv 1]
set argv [lrange $argv 1 end]
}
-html-path {
set config(doc,html) 1
set config(doc,html,path) [lindex $argv 1]
set argv [lrange $argv 1 end]
}
-example-path {
set config(exa) 1
set config(exa,path) [lindex $argv 1]
set argv [lrange $argv 1 end]
}
-help -
default {
puts stderr "usage: $argv0 ?-dry-run/-simulate? ?-no-wait? ?-no-gui? ?-html|-no-html? ?-nroff|-no-nroff? ?-examples|-no-examples? ?-pkgs|-no-pkgs? ?-pkg-path path? ?-apps|-no-apps? ?-app-path path? ?-nroff-path path? ?-html-path path? ?-example-path path?"
exit 1
}
}
set argv [lrange $argv 1 end]
}
return
}
proc validate {} {
global config
if {$config(valid)} {return}
puts "Invalid configuration detected, aborting."
puts ""
puts "Please use the option -help to get more information"
puts ""
if {$config(gui)} {
tk_messageBox \
-icon error -type ok \
-default ok \
-title "Illegal configuration" \
-parent . -message [get]
clear
}
exit 1
}
proc installErrorMsgBox {msg} {
tk_messageBox \
-icon error -type ok \
-default ok \
-title "Install error" \
-parent . -message $msg
exit 1
}
proc wait {} {
global config
if {!$config(wait)} {return}
puts -nonewline stdout "Is the chosen configuration ok ? y/N: "
flush stdout
set answer [gets stdin]
if {($answer == {}) || [string match "\[Nn\]*" $answer]} {
puts stdout "\tNo. Aborting."
puts stdout ""
exit 0
}
return
}
# --------------------------------------------------------------
# Main code
proc main {} {
global config
defaults
processargs
if {$config(no-gui) || [catch {package require Tk}]} {
handlecmdline
} else {
handlegui
}
doinstall
return
}
# --------------------------------------------------------------
if {[catch {
main
}]} {
puts $errorInfo
exit 1
} else {
exit 0
}
# --------------------------------------------------------------
