installer.tcl

Go to the documentation of this file.

/* !/bin/sh*/
/*  -*- tcl -*- \*/
exec tclsh "$0" ${1+"$@"}

/*  --------------------------------------------------------------*/
/*  Installer for Tcllib. The lowest version of the tcl core supported*/
/*  by any module is 8.2. So we enforce that the installer is run with*/
/*  at least that.*/

package require Tcl 8.2

 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)*/

ret  package_name    (type text) {global package_name    ; set package_name    $text}
ret  package_version (type text) {global package_version ; set package_version $text}
ret  dist_exclude    (type path) {}
ret  critcl       (type name , type files) {}
ret  critcl_main  (type name , type files) {}
ret  critcl_notes (type 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.*/

 package = _nv ${package_name}-${package_version}
 package = _name_cap [string toupper [string index $package_name 0]][string range $package_name 1 end]

/*  --------------------------------------------------------------*/
/*  Low-level commands of the installation engine.*/

ret  gen_main_index (type outdir , type package , type 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.  Let $package install generate this file."
    puts $index "# Generated by $package installer for version $version"

    puts $index {
# All tcllib packages need Tcl 8 (use [namespace])
if {![package vsatisfies [package provide Tcl] 8]} {return}

# Extend the auto_path to make tcllib packages available
if {[lsearch -exact $::auto_path $dir] == -1} {
    lappend ::auto_path $dir
}

# For Tcl 8.3.1 and later, that's all we need
if {[package vsatisfies [package provide Tcl] 8.4]} {return}
if {(0 == [catch {
    package vcompare [info patchlevel] [info patchlevel]
}]) && (
    [package vcompare [info patchlevel] 8.3.1] >= 0
)} {return}

# For older Tcl releases, here are equivalent contents
# of the pkgIndex.tcl files of all the modules

if {![package vsatisfies [package provide Tcl] 8.0]} {return}
}
    puts $index ""
    puts $index "set maindir \$dir"

    foreach pi [lsort [glob -nocomplain [file join $outdir * pkgIndex.tcl]]] {
    set subdir [file tail [file dirname $pi]]
    puts $index "set dir \[file join \$maindir [list $subdir]\] ;\t source \[file join \$dir pkgIndex.tcl\]"
    }

    puts  $index "unset maindir"
    puts  $index ""
    close $index
    return
}

ret  xcopyfile (type src , type dest) {
    # dest can be dir or file
    run file copy -force $src $dest
    return
}

ret  xcopy (type src , type dest , type recurse , optional pattern =*) {
    run file mkdir $dest

    if {[string equal $pattern *] || !$recurse} {
    foreach file [glob [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 [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
        }
    }
    }
}

ret  get_input (type f) {return [read [set if [open $f r]]][close $if]}
ret  write_out (type f , type 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*/

ret  clear ()     {global message ; set     message ""}
ret  msg   (type text) {global message ; append  message $text \n ; return}
ret  get   ()     {global message ; return $message}

ret  log (type text) {
    global config
    if {!$config(gui)} {puts stdout $text ; flush stdout ; return}
    .l.t insert end $text\n
    .l.t see    end
    update
    return
}
ret  log* (type text) {
    global config
    if {!$config(gui)} {puts -nonewline stdout $text ; flush stdout ; return}
    .l.t insert end $text
    .l.t see    end
    update
    return
}

ret  run (type 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
}

ret  xinstall (type type , type args) {
    global modules guide
    foreach m $modules {
    eval $guide($m,$type) $m $args
    }
    return
}

ret  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
    }

    if {[file exists $aexe.man]} {
        if {$config(doc,nroff)} {
        _manfile $aexe.man nroff n $config(doc,nroff,path)
        }
        if {$config(doc,html)} {
        _manfile $aexe.man html html $config(doc,html,path)
        }
    }
    }
    return
}

ret  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)} {
        xinstall doc nroff n    $config(doc,nroff,path)
    }
    if {$config(doc,html)}  {
        xinstall doc html  html $config(doc,html,path)
    }
    }
    if {$config(exa)}       {xinstall exa $config(exa,path)}
    if {$config(app)}       {ainstall}
    log ""
    return
}


/*  --------------------------------------------------------------*/
/*  Initialize configuration.*/

array  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*/

ret  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 lcoation 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.*/

ret  showpath (type prefix , type 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."
    }
}

ret  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*/

ret  browse (type label , type 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
}

ret  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
}

ret  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*/

ret  handlecmdline () {
    showconfiguration
    validate
    wait
    return
}

ret  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
}

ret  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
}

ret  installErrorMsgBox (type msg) {
    tk_messageBox \
        -icon error -type ok \
        -default ok \
        -title "Install error" \
        -parent . -message $msg
    exit 1
}

ret  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*/

ret  main () {
    global config

    defaults
    processargs
    if {$config(no-gui) || [catch {package require Tk}]} {
    handlecmdline
    } else {
    handlegui
    }
    doinstall
    return
}

/*  --------------------------------------------------------------*/
main
exit 0
/*  --------------------------------------------------------------*/