1#!/bin/sh 2# -*- tcl -*- \ 3exec tclsh "$0" ${1+"$@"} 4 5# -------------------------------------------------------------- 6# Installer for Tklib. The lowest version of the tcl core supported 7# by any module is 8.2. So we enforce that the installer is run with 8# at least that. 9 10package require Tcl 8.2 11 12set distribution [file dirname [info script]] 13lappend auto_path [file join $distribution modules] 14 15 16# -------------------------------------------------------------- 17# Version information for tklib. 18# List of modules to install (and definitions guiding the process) 19 20proc package_name {text} {global package_name ; set package_name $text} 21proc package_version {text} {global package_version ; set package_version $text} 22proc dist_exclude {path} {} 23proc critcl {name files} {} 24proc critcl_main {name files} {} 25proc critcl_notes {text} {} 26 27source [file join $distribution support installation version.tcl] ; # Get version information. 28source [file join $distribution support installation modules.tcl] ; # Get list of installed modules. 29source [file join $distribution support installation actions.tcl] ; # Get code to perform install actions. 30 31set package_nv ${package_name}-${package_version} 32set package_name_cap [string toupper [string index $package_name 0]][string range $package_name 1 end] 33 34# -------------------------------------------------------------- 35# Low-level commands of the installation engine. 36 37proc gen_main_index {outdir package version} { 38 global config 39 40 log "\nGenerating [file join $outdir pkgIndex.tcl]" 41 if {$config(dry)} {return} 42 43 set index [open [file join $outdir pkgIndex.tcl] w] 44 45 puts $index "# Tcl package index file, version 1.1" 46 puts $index "# Do NOT edit by hand. Let $package install generate this file." 47 puts $index "# Generated by $package installer for version $version" 48 49 puts $index { 50# All tklib packages need Tcl 8 (use [namespace]) 51if {![package vsatisfies [package provide Tcl] 8]} {return} 52 53# Extend the auto_path to make tklib packages available 54if {[lsearch -exact $::auto_path $dir] == -1} { 55 lappend ::auto_path $dir 56} 57 58# For Tcl 8.3.1 and later, that's all we need 59if {[package vsatisfies [package provide Tcl] 8.4]} {return} 60if {(0 == [catch { 61 package vcompare [info patchlevel] [info patchlevel] 62}]) && ( 63 [package vcompare [info patchlevel] 8.3.1] >= 0 64)} {return} 65 66# For older Tcl releases, here are equivalent contents 67# of the pkgIndex.tcl files of all the modules 68 69if {![package vsatisfies [package provide Tcl] 8.0]} {return} 70} 71 puts $index "" 72 puts $index "set maindir \$dir" 73 74 foreach pi [lsort [glob -nocomplain [file join $outdir * pkgIndex.tcl]]] { 75 set subdir [file tail [file dirname $pi]] 76 puts $index "set dir \[file join \$maindir [list $subdir]\] ;\t source \[file join \$dir pkgIndex.tcl\]" 77 } 78 79 puts $index "unset maindir" 80 puts $index "" 81 close $index 82 return 83} 84 85proc xcopyfile {src dest} { 86 # dest can be dir or file 87 run file copy -force $src $dest 88 return 89} 90 91proc xcopy {src dest recurse {pattern *}} { 92 run file mkdir $dest 93 94 if {[string equal $pattern *] || !$recurse} { 95 foreach file [glob [file join $src $pattern]] { 96 set base [file tail $file] 97 set sub [file join $dest $base] 98 99 if {0 == [string compare CVS $base]} {continue} 100 101 if {[file isdirectory $file]} then { 102 if {$recurse} { 103 run file mkdir $sub 104 xcopy $file $sub $recurse $pattern 105 106 # If the directory is empty after the recursion remove it again. 107 if {![llength [glob -nocomplain [file join $sub *]]]} { 108 file delete $sub 109 } 110 } 111 } else { 112 xcopyfile $file $sub 113 } 114 } 115 } else { 116 foreach file [glob [file join $src *]] { 117 set base [file tail $file] 118 set sub [file join $dest $base] 119 120 if {[string equal CVS $base]} {continue} 121 122 if {[file isdirectory $file]} then { 123 if {$recurse} { 124 run file mkdir $sub 125 xcopy $file $sub $recurse $pattern 126 127 # If the directory is empty after the recursion remove it again. 128 if {![llength [glob -nocomplain [file join $sub *]]]} { 129 run file delete $sub 130 } 131 } 132 } else { 133 if {![string match $pattern $base]} {continue} 134 xcopyfile $file $sub 135 } 136 } 137 } 138} 139 140proc get_input {f} {return [read [set if [open $f r]]][close $if]} 141proc write_out {f text} { 142 global config 143 if {$config(dry)} {log "Generate $f" ; return} 144 catch {file delete -force $f} 145 puts -nonewline [set of [open $f w]] $text 146 close $of 147} 148 149 150# -------------------------------------------------------------- 151# Use configuration to perform installation 152 153proc clear {} {global message ; set message ""} 154proc msg {text} {global message ; append message $text \n ; return} 155proc get {} {global message ; return $message} 156 157proc log {text} { 158 global config 159 if {!$config(gui)} {puts stdout $text ; flush stdout ; return} 160 .l.t insert end $text\n 161 .l.t see end 162 update 163 return 164} 165proc log* {text} { 166 global config 167 if {!$config(gui)} {puts -nonewline stdout $text ; flush stdout ; return} 168 .l.t insert end $text 169 .l.t see end 170 update 171 return 172} 173 174proc run {args} { 175 global config 176 if {$config(dry)} { 177 log [join $args] 178 return 179 } 180 if {[catch {eval $args} msg]} { 181 if {$config(gui)} { 182 installErrorMsgBox $msg 183 } else { 184 return -code error "Install error:\n $msg" 185 } 186 } 187 log* . 188 return 189} 190 191proc xinstall {type args} { 192 global modules guide 193 foreach m $modules { 194 eval $guide($m,$type) $m $args 195 } 196 return 197} 198 199proc ainstall {} { 200 global apps config tcl_platform distribution 201 202 if {[string compare $tcl_platform(platform) windows] == 0} { 203 set ext .tcl 204 } else { 205 set ext "" 206 } 207 208 foreach a $apps { 209 set aexe [file join $distribution apps $a] 210 set adst [file join $config(app,path) ${a}$ext] 211 212 log "\nGenerating $adst" 213 if {!$config(dry)} { 214 file mkdir [file dirname $adst] 215 catch {file delete -force $adst} 216 file copy -force $aexe $adst 217 } 218 219 if {[file exists $aexe.man]} { 220 if {$config(doc,nroff)} { 221 _manfile $aexe.man nroff n $config(doc,nroff,path) 222 } 223 if {$config(doc,html)} { 224 _manfile $aexe.man html html $config(doc,html,path) 225 } 226 } 227 } 228 return 229} 230 231proc doinstall {} { 232 global config package_version distribution package_name modules excluded 233 234 if {!$config(no-exclude)} { 235 foreach p $excluded { 236 set pos [lsearch -exact $modules $p] 237 if {$pos < 0} {continue} 238 set modules [lreplace $modules $pos $pos] 239 } 240 } 241 242 if {$config(doc,nroff)} { 243 set config(man.macros) [string trim [get_input \ 244 [file join $distribution support installation man.macros]]] 245 } 246 if {$config(pkg)} { 247 xinstall pkg $config(pkg,path) 248 gen_main_index $config(pkg,path) $package_name $package_version 249 } 250 if {$config(doc,nroff)} { 251 xinstall doc nroff n $config(doc,nroff,path) 252 } 253 if {$config(doc,html)} { 254 xinstall doc html html $config(doc,html,path) 255 } 256 if {$config(exa)} {xinstall exa $config(exa,path)} 257 if {$config(app)} {ainstall} 258 log "" 259 return 260} 261 262 263# -------------------------------------------------------------- 264# Initialize configuration. 265 266array set config { 267 pkg 1 pkg,path {} 268 app 1 app,path {} 269 doc,nroff 0 doc,nroff,path {} 270 doc,html 0 doc,html,path {} 271 exa 1 exa,path {} 272 dry 0 wait 1 valid 1 273 gui 0 no-gui 0 no-exclude 0 274} 275 276# -------------------------------------------------------------- 277# Determine a default configuration, if possible 278 279proc defaults {} { 280 global tcl_platform config package_version package_name distribution 281 282 if {[string compare $distribution [info nameofexecutable]] == 0} { 283 # Starpack. No defaults for location. 284 } else { 285 # Starkit, or unwrapped. Derive defaults location from the 286 # location of the executable running the installer, or the 287 # location of its library. 288 289 # For a starkit [info library] is inside the running 290 # tclkit. Detect this and derive the lcoation from the 291 # location of the executable itself for that case. 292 293 if {[string match [info nameofexecutable]* [info library]]} { 294 # Starkit 295 set libdir [file join [file dirname [file dirname [info nameofexecutable]]] lib] 296 } else { 297 # Unwrapped. 298 if {[catch {set libdir [lindex $::tcl_pkgPath end]}]} { 299 set libdir [file dirname [info library]] 300 } 301 } 302 303 set basedir [file dirname $libdir] 304 set bindir [file join $basedir bin] 305 306 if {[string compare $tcl_platform(platform) windows] == 0} { 307 set mandir {} 308 set htmldir [file join $basedir ${package_name}_doc] 309 } else { 310 set mandir [file join $basedir man mann] 311 set htmldir [file join $libdir ${package_name}${package_version} ${package_name}_doc] 312 } 313 314 set config(app,path) $bindir 315 set config(pkg,path) [file join $libdir ${package_name}${package_version}] 316 set config(doc,nroff,path) $mandir 317 set config(doc,html,path) $htmldir 318 set config(exa,path) [file join $bindir ${package_name}_examples${package_version}] 319 } 320 321 if {[string compare $tcl_platform(platform) windows] == 0} { 322 set config(doc,nroff) 0 323 set config(doc,html) 1 324 } else { 325 set config(doc,nroff) 1 326 set config(doc,html) 0 327 } 328 return 329} 330 331# -------------------------------------------------------------- 332# Show configuration on stdout. 333 334proc showpath {prefix key} { 335 global config 336 337 if {$config($key)} { 338 if {[string length $config($key,path)] == 0} { 339 puts "${prefix}Empty path, invalid." 340 set config(valid) 0 341 msg "Invalid path: [string trim $prefix " :"]" 342 } else { 343 puts "${prefix}$config($key,path)" 344 } 345 } else { 346 puts "${prefix}Not installed." 347 } 348} 349 350proc showconfiguration {} { 351 global config package_version package_name_cap 352 353 puts "Installing $package_name_cap $package_version" 354 if {$config(dry)} { 355 puts "\tDry run, simulation, no actual activity." 356 puts "" 357 } 358 359 puts "You have chosen the following configuration ..." 360 puts "" 361 362 showpath "Packages: " pkg 363 #showpath "Applications: " app 364 showpath "Examples: " exa 365 366 if {$config(doc,nroff) || $config(doc,html)} { 367 puts "Documentation:" 368 puts "" 369 370 showpath "\tNROFF: " doc,nroff 371 showpath "\tHTML: " doc,html 372 } else { 373 puts "Documentation: Not installed." 374 } 375 puts "" 376 return 377} 378 379# -------------------------------------------------------------- 380# Setup the installer user interface 381 382proc browse {label key} { 383 global config 384 385 set initial $config($key) 386 if {$initial == {}} {set initial [pwd]} 387 388 set dir [tk_chooseDirectory \ 389 -title "Select directory for $label" \ 390 -parent . \ 391 -initialdir $initial \ 392 ] 393 394 if {$dir == {}} {return} ; # Cancellation 395 396 set config($key) $dir 397 return 398} 399 400proc setupgui {} { 401 global config package_name_cap package_version 402 set config(gui) 1 403 404 wm withdraw . 405 wm title . "Installing $package_name_cap $package_version" 406 407 # .app checkbutton 1 0 1 {-anchor w -text {Applications:} -variable config(app)} 408 # .appe entry 1 1 1 {-width 40 -textvariable config(app,path)} 409 # .appb button 1 2 1 {-text ... -command {browse Applications app,path}} 410 foreach {w type cspan col row opts} { 411 .pkg checkbutton 1 0 0 {-anchor w -text {Packages:} -variable config(pkg)} 412 .dnr checkbutton 1 0 1 {-anchor w -text {Doc. Nroff:} -variable config(doc,nroff)} 413 .dht checkbutton 1 0 2 {-anchor w -text {Doc. HTML:} -variable config(doc,html)} 414 .exa checkbutton 1 0 3 {-anchor w -text {Examples:} -variable config(exa)} 415 416 .spa frame 3 0 4 {-bg black -height 2} 417 418 .dry checkbutton 2 0 6 {-anchor w -text {Simulate installation} -variable config(dry)} 419 420 .pkge entry 1 1 0 {-width 40 -textvariable config(pkg,path)} 421 .dnre entry 1 1 1 {-width 40 -textvariable config(doc,nroff,path)} 422 .dhte entry 1 1 2 {-width 40 -textvariable config(doc,html,path)} 423 .exae entry 1 1 3 {-width 40 -textvariable config(exa,path)} 424 425 .pkgb button 1 2 0 {-text ... -command {browse Packages pkg,path}} 426 .dnrb button 1 2 1 {-text ... -command {browse Nroff doc,nroff,path}} 427 .dhtb button 1 2 2 {-text ... -command {browse HTML doc,html,path}} 428 .exab button 1 2 3 {-text ... -command {browse Examples exa,path}} 429 430 .sep frame 3 0 7 {-bg black -height 2} 431 432 .run button 1 0 8 {-text {Install} -command {set ::run 1}} 433 .can button 1 1 8 {-text {Cancel} -command {exit}} 434 } { 435 eval [list $type $w] $opts 436 grid $w -column $col -row $row -sticky ew -columnspan $cspan 437 grid rowconfigure . $row -weight 0 438 } 439 440 grid .can -sticky e 441 442 grid rowconfigure . 9 -weight 1 443 grid columnconfigure . 0 -weight 0 444 grid columnconfigure . 1 -weight 1 445 446 wm deiconify . 447 return 448} 449 450proc handlegui {} { 451 setupgui 452 vwait ::run 453 showconfiguration 454 validate 455 456 toplevel .l 457 wm title .l "Install log" 458 text .l.t -width 70 -height 25 -relief sunken -bd 2 459 pack .l.t -expand 1 -fill both 460 461 return 462} 463 464# -------------------------------------------------------------- 465# Handle a command line 466 467proc handlecmdline {} { 468 showconfiguration 469 validate 470 wait 471 return 472} 473 474proc processargs {} { 475 global argv argv0 config 476 477 while {[llength $argv] > 0} { 478 switch -exact -- [lindex $argv 0] { 479 +excluded {set config(no-exclude) 1} 480 -no-wait {set config(wait) 0} 481 -no-gui {set config(no-gui) 1} 482 -simulate - 483 -dry-run {set config(dry) 1} 484 -html {set config(doc,html) 1} 485 -nroff {set config(doc,nroff) 1} 486 -examples {set config(exa) 1} 487 -pkgs {set config(pkg) 1} 488 -apps {set config(app) 1} 489 -no-html {set config(doc,html) 0} 490 -no-nroff {set config(doc,nroff) 0} 491 -no-examples {set config(exa) 0} 492 -no-pkgs {set config(pkg) 0} 493 -no-apps {set config(app) 0} 494 -pkg-path { 495 set config(pkg) 1 496 set config(pkg,path) [lindex $argv 1] 497 set argv [lrange $argv 1 end] 498 } 499 -app-path { 500 set config(app) 1 501 set config(app,path) [lindex $argv 1] 502 set argv [lrange $argv 1 end] 503 } 504 -nroff-path { 505 set config(doc,nroff) 1 506 set config(doc,nroff,path) [lindex $argv 1] 507 set argv [lrange $argv 1 end] 508 } 509 -html-path { 510 set config(doc,html) 1 511 set config(doc,html,path) [lindex $argv 1] 512 set argv [lrange $argv 1 end] 513 } 514 -example-path { 515 set config(exa) 1 516 set config(exa,path) [lindex $argv 1] 517 set argv [lrange $argv 1 end] 518 } 519 -help - 520 default { 521 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?" 522 exit 1 523 } 524 } 525 set argv [lrange $argv 1 end] 526 } 527 return 528} 529 530proc validate {} { 531 global config 532 533 if {$config(valid)} {return} 534 535 puts "Invalid configuration detected, aborting." 536 puts "" 537 puts "Please use the option -help to get more information" 538 puts "" 539 540 if {$config(gui)} { 541 tk_messageBox \ 542 -icon error -type ok \ 543 -default ok \ 544 -title "Illegal configuration" \ 545 -parent . -message [get] 546 clear 547 } 548 exit 1 549} 550 551proc installErrorMsgBox {msg} { 552 tk_messageBox \ 553 -icon error -type ok \ 554 -default ok \ 555 -title "Install error" \ 556 -parent . -message $msg 557 exit 1 558} 559 560proc wait {} { 561 global config 562 563 if {!$config(wait)} {return} 564 565 puts -nonewline stdout "Is the chosen configuration ok ? y/N: " 566 flush stdout 567 set answer [gets stdin] 568 if {($answer == {}) || [string match "\[Nn\]*" $answer]} { 569 puts stdout "\tNo. Aborting." 570 puts stdout "" 571 exit 0 572 } 573 return 574} 575 576# -------------------------------------------------------------- 577# Main code 578 579proc main {} { 580 global config 581 582 defaults 583 processargs 584 if {$config(no-gui) || [catch {package require Tk}]} { 585 handlecmdline 586 } else { 587 handlegui 588 } 589 doinstall 590 return 591} 592 593# -------------------------------------------------------------- 594main 595exit 0 596# -------------------------------------------------------------- 597