geos_one/archie
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
d896ff745c
archie/tcl-dp/teki.tcl

2241 lines
69 KiB
Tcl
Raw Normal View History

Intial commit
2024-05-27 16:13:40 +02:00
#!/bin/sh
# \
exec wish "$0" ${1+"$@"}
if {$tcl_version < 7.6} {
puts stderr "requires Tcl 7.6 or later"
exit
}
# teki.tcl --
#
# The Tcl Extension Kit/Installer. This file manages packages for
# Tcl/Tk
# Notes about the organization of this file:
# Major sections are delimited by a string of "-" characters -- e.g. "-------"
# At the beginning of each major section, the purpose and routines in that
# section are described.
# teki-specific packages reside in the "tekilib" directory below teki.tcl
#set tk_version 7.6
set home [string trimright [file dirname [info script]] ./]
set home [file join [pwd] $home tekilib]
lappend auto_path $home
set TekiInfo(library) $home
unset home
if [catch {package require http}] {
set TekiInfo(http) 0
} else {
set TekiInfo(http) 1
}
package require Debug
package require Undo
# Define some useful fonts
if [info exists tk_version] {
set TekiInfo(gui) 1
set majorversion [lindex [split $tk_version .] 0]
if {$majorversion >= 8} {
set TekiInfo(varfont) [font create -family Times -weight bold -size 18]
set TekiInfo(fixedfont) [font create -family Courier -size 10]
} else {
set TekiInfo(varfont) *-Times-Bold-R-Normal--*-240-*-*-*-*-*-*
set TekiInfo(fixedfont) -*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*
}
unset majorversion
} else {
set TekiInfo(gui) 0
}
if $TekiInfo(gui) {
package require Progress-Tk
package require Wise
} else {
package require Progress-Tcl
}
# -----------------------------------------------------------------------
#
# Error handling, general UI commands.
#
# This section contains code to handle errors and print messages.
# It defines basic functions whose interface can be a GUI (if we're
# running in wish) or a text based interface (if we're running in
# a shell)
# TekiError prints an error message
# TekiWarning is called to ask the user for confirmation or a decision
# (such as deleting a file or set of files)
if $TekiInfo(gui) {
proc TekiError {msg} {
bgerror "$msg"
}
proc TekiWarning {msg default options} {
Wise_Message "Warning" $msg $options 0
}
} else {
proc TekiError {msg} {
puts stderr $msg
}
proc TekiWarning {msg default options} {
global x
puts stderr "Warning: $msg"
set len [llength $options]
set done 0
while {!$done} {
for {set i 0} {$i < $len} {incr i} {
puts stderr "Type $i to [lindex $options $i]"
}
set x [string trim [gets stdin]]
if [string match {[0-9]} "$x"] {
set done [expr ($x >=0) && ($x < $len)]
}
}
return $x
}
}
# -----------------------------------------------------------------------
#
# User Interface
#
# This section of code creates and manages the user interface. The UI
# consists of a main window with two parts (top and bottom), plus a menu
# bar. The top contains the readme file of the currently selected package,
# the bottom a list of packages installed on the system. The
# functions TekiCreateMenus and TekiCreateWindow create this interface.
# The function TekiCreateUI creates the menus and main window (by
# calling TekiCreateMenus and TekiCreateWindow).
#
# The function TekiUpdateReadme redraws the top portion, and should
# be called whenever the current package -- TekiInfo(currPackage) -- is changed.
# The function TekiUpdateBrowser redraws the bottom, and should be
# called whenever tclPkgInfo(installed) changes. The function
# TekiBrowserCallback is called when the user clicks in the bottom
# area, selecting a new package. The functions TekiDoFileInstall,
# TekiDoFileUninstall, and TekiDoFileExit, are called when the user
# selects File->Install, File->Uninstall, or File->Exit menu items,
# respectively. DoFileInstall pops up a file selection dialog,
# then verifies and installs the file.
set TekiInfo(currPackage) tcl[info tclversion]
#
# TekiCreateMenus
# Create the menu bar across the top of the window
#
# Arguments:
# None
#
proc TekiCreateMenus {} {
global tclPkgInfo TekiInfo
Debug_Enter TekiCreateMenus
frame .menu -relief raised -bd 2
pack .menu -side top -fill x
# File Menu
set m .menu.file.m
menubutton .menu.file -text File -menu $m -underline 0
pack .menu.file -side left
menu $m
$m add command -label "Install" -underline 0 -command TekiDoFileInstall
$m add command -label "Uninstall" -underline 1 -command TekiDoFileUninstall
$m add separator
$m add command -label "Exit" -underline 1 -command TekiDoFileExit
# WWW Menu
set m .menu.www.m
menubutton .menu.www -text WWW -menu $m -underline 0
pack .menu.www -side left
menu $m
$m add command -label "Update" -underline 0 -command TekiDoWWWUpdate
$m add command -label "Browse" -underline 1 -command TekiDoWWWBrowse
if {$TekiInfo(http) == 0} {
.menu.www.m entryconfigure Browse -state disabled
.menu.www.m entryconfigure Update -state disabled
}
Debug_Leave
}
#
# TekiCreateWindow
# Create the main window -- this window lists the installed packages, and has a
# README section.
#
# Arguments:
# none
#
proc TekiCreateWindow {} {
global tclPkgInfo TekiInfo
Debug_Enter TekiCreateWindow
set w .browser
frame $w
pack $w -side bottom -fill x -expand no
scrollbar $w.scroll -command "$w.list yview"
listbox $w.list -font $TekiInfo(fixedfont) -relief sunken -width 100 \
-bd 2 -yscrollcommand "$w.scroll set" -setgrid 1 -height 12 \
-selectmode extended
pack $w.scroll -side right -fill y
pack $w.list -expand no -fill both
set TekiInfo(Browser) $w.list
TekiUpdateBrowser
# Create the README section of the frame
set w .readme
frame $w
pack $w -side top -fill both -expand yes
scrollbar $w.scroll -command "$w.text yview"
text $w.text -font $TekiInfo(fixedfont) -relief sunken -width 100 \
-bd 2 -yscrollcommand "$w.scroll set" -setgrid 1 -height 10
set TekiInfo(Readme) $w.text
pack $w.scroll -side right -fill y
pack $w.text -expand yes -fill both
TekiUpdateReadme
update
bind $TekiInfo(Browser) <Button-1> TekiBrowserCallback
bindtags $TekiInfo(Browser) [list Listbox all $TekiInfo(Browser)]
Debug_Leave
}
#
# TekiUpdateReadme -
# Updates the readme window of the Info window.
# Called whenever the current package changes.
# The associated widget is a text widget.
#
proc TekiUpdateReadme {} {
global tclPkgInfo TekiInfo
Debug_Enter TekiUpdateReadme
set w $TekiInfo(Readme)
set currPkg [lindex $TekiInfo(currPackage) 0]
if {[string length $currPkg] == 0} {
return
}
set filename $tclPkgInfo($currPkg,infoFile)
set name $tclPkgInfo($currPkg,name)
$w delete 1.0 end
$w insert end "Information on the $currPkg package\n\n"
set m1 .menu.file.m
set m2 .menu.www.m
if {($name == "Tcl") || ($name == "Tk")} {
$m1 entryconfigure Uninstall -state disabled
$m2 entryconfigure Update -state disabled
} else {
$m1 entryconfigure Uninstall -state normal
if $TekiInfo(http) {
$m2 entryconfigure Update -state normal
}
}
if {[string length $filename] &&
[file exists $filename] &&
[file readable $filename]} {
set f [open $filename r]
$w insert end [read $f]
close $f
} else {
$w insert end "No information available"
}
wm title . "TEKI -- $currPkg"
Debug_Leave
}
#
# TekiUpdateBrowser -
# Updates the browser window.
# Called whenever the list of installed packages changes.
#
proc TekiUpdateBrowser {} {
global tclPkgInfo TekiInfo
Debug_Enter TekiUpdateBrowser
set w $TekiInfo(Browser)
$w delete 0 end
$w insert end "Packages installed:"
$w insert end [format "%-11s%-8s %-15s%-28s" "package" "version" "requires" "description"]
if {[winfo depth $w] > 1} {
set hot "-background #808080 -relief raised -borderwidth 1"
set normal "-background {} -relief flat"
} else {
set hot "-foreground white -background black"
set normal "-foreground {} -background {}"
}
set tclPkgInfo(installed) [lsort $tclPkgInfo(installed)]
foreach pkg $tclPkgInfo(installed) {
set des $tclPkgInfo($pkg,description)
set ver $tclPkgInfo($pkg,version)
set req $tclPkgInfo($pkg,requires)
# The following code does one of two things, depending
# on whether the package is part of another package.
set split [file split $pkg]
set lsplit [llength $split]
$w insert end [format "%-15s%-8s%-16s%-28s" $pkg $ver $req $des]
}
Debug_Leave
}
#
# TekiBrowserCallback --
# This procedure is called when the user clicks on a package in the browser window.
# It is responsible for updating the UI to show details of the selected package
#
# Arguments:
# index The index of the character that the user clicked on.
#
proc TekiBrowserCallback {} {
global tclPkgInfo TekiInfo
Debug_Enter "TekiBrowserCallback"
set w $TekiInfo(Browser)
set packages {}
foreach i [$w curselection] {
if {$i < 2} {
# The first two elements are the labels, so don't allow the
# user to select these
$w selection clear $i
} else {
set info [$w get $i]
set pkg [lindex $info 0]
lappend packages $pkg
}
}
set TekiInfo(currPackage) $packages
TekiUpdateReadme
Debug_Leave
}
#
# TekiCreateUI
# Create the TEKI User Interface in the main window (".")
# 1. Create the menus
# 2. Create & show the browse windows
#
proc TekiCreateUI {} {
global tclPkgInfo TekiInfo
Debug_Enter TekiCreateUI
TekiCreateMenus
TekiCreateWindow
set currPkg $TekiInfo(currPackage)
wm title . "TEKI -- $currPkg"
wm iconname . "TEKI"
Debug_Leave
}
#-----------------------------------------------------------------------
# WISE user interface support
# The following procedures control the WISE user interface (defined in the
# Wise package). The wizards are called by the Teki*Wizard procedures.
#
# The function TekiInteractiveInstall coordinates everything -- it
# reads/verifies the Teki file, calls the wizards to select various
# parameters, downloads any files that are needed, and calls TekiInstall
#
# The functions TekiNormalizeDirName
# Bring the name of a directory into "canonical" form. What a pain!
proc TekiNormalizeDirName {d} {
Debug_Enter TekiNormalizeDirName
set cwd [pwd]
switch [file pathtype $d] {
absolute -
volumerelative {
set path {}
set len 0
}
relative {
set path [file split $cwd]
set len [llength $path]
}
}
foreach c [file split $d] {
switch $c {
{.} {}
{..} {
incr len -1;
set path [lrange $path 0 [expr $len-1]]
}
default {
lappend path $c
incr len
}
}
}
Debug_Leave
return [eval file join $path]
}
# Try to make the directory writable
proc TekiMakeWritable {dir} {
global tcl_platform tcl_version
set majorversion [lindex [split $tcl_version .] 0]
switch $tcl_platform(platform) {
unix {
if {$majorversion >= 8} {
file attributes $dir -permissions 755
} else {
exec chmod a+wx $dir
}
}
mac* -
windows {
if {$majorversion >= 8} {
file attributes $dir -readonly 0
} else {
error "Permission denied"
}
}
}
}
# Make sure the directory exists, is writable, and is a directory.
# If $dir exists and is a file, flag an error
# If $dir doesn't exist, ask the user if they want to create it
# if they do, then try to create it, otherwise flag an error
# If the return value is 0, then the directory can't be used
# for installation. If the return value is 1, then we can proceed
proc TekiVerifyDir {dir} {
#
# Make the directory if needed
#
if {[file exists $dir]} {
if {![file isdirectory $dir]} {
TekiError "Error: $dir exists and is not a directory"
return 0
}
} else {
# Doesn't exist. Make it
set rv [TekiWarning "Directory $dir does not exist, create?" 0 {Ok Cancel}]
if {$rv == 0} {
if [catch {file mkdir $dir} err] {
TekiError "Error creating $dir\n $err"
return 0
}
} else {
# Cancelled by user
return 0
}
}
# If we get to here, $dir exists and is a directory
# Try to make it writable if it's not
if {![file writable $dir]} {
if [catch {TekiMakeWritable $dir} err] {
TekiError "Error: $dir is not writable\n$err"
return 0
}
}
return 1
}
# Utility to delete an item from a list
proc TekiListDelete {list item} {
set index [lsearch $list $item]
if {$index != -1} {
set list [concat [lrange $list 0 [expr $index-1]] \
[lrange $list [expr $index+1] end]]
}
return $list
}
# The (Teki*Wizard) procedures encode the logic of the wizards.
# Each procedure corresponds to one wizard. The information gathered
# through the wizards is used to set elements in the global array TekiInfo()
#
# The entry point to the machine is the TekiTypeWizard (abbreviated
# "type"). At any time, pressing the cancel button aborts the wizards,
# pressing "finish" goes directly to "verify", pressing "back" goes back
# to the previous state, and, generally, pressing "next" goes on to
# the next state. The only exception is in the initial wizard where
# the user selects between "custom" and "typical" installation. If
# the user selects "typical" and selects "next", the installation
# parameters are reset to their defaults and the wizard goes directly
# to the verify state.
#
# To encode this logic, a sequence of procedure calls are executed, one
# for each wizard. Each wizard calls the next wizard directly. To
# implement the "back" button, the procedure just returns. To implement
# the "cancel" and "finish" buttons, unusual return codes
# ($TekiInfo(cancelCode) for cancel, $TekiInfo(finishCode) for finish)
# are returned by the wizard procedures and caught at the entry point
# of the first wizard.
#
# The wizards are:
# type - get installation type (custom or typical)
# packages - let the user select which packages to install (only used
# if there's more than one package available)
# archList - get the list of architectures to install for
# extras - ask whether to install examples, docs, and data
# codeDir - get target directory for code files
# docDir - get target directory for documentation (only if installing
# documentation)
# verify - verify all paramters
set TekiInfo(cancelCode) 5
set TekiInfo(finishCode) 6
# Reset the TekiInfo variables that corespond to the wizard parameters
# to their default values.
proc TekiWizardDefaults {} {
global TekiInfo newPackage
# reset to defaults
set TekiInfo(packages) $newPackage(defaultPackages)
set TekiInfo(archList) $newPackage(defaultArch)
if {$TekiInfo(archList) == "all"} {
set TekiInfo(archList) {}
foreach sys $TekiInfo(systemNames) {
lappend TekiInfo(archList) [lindex $sys 0]
}
}
set TekiInfo(extras) {}
if $newPackage(defaultInstallDoc) {
lappend TekiInfo(extras) doc
}
if $newPackage(defaultInstallData) {
lappend TekiInfo(extras) data
}
if $newPackage(defaultInstallExamples) {
lappend TekiInfo(extras) examples
}
set TekiInfo(codeDir) [info library]
set x [file dirname [file dirname $TekiInfo(codeDir)]]
set TekiInfo(docDir) [file join $x doc]
}
proc TekiTypeWizard {} {
global TekiInfo
# Ask if typical or custom install
while (1) {
set rv [Wise_Radiolist "Select installation type" \
{{typical typical 1} {custom custom 0}} 1]
switch $rv {
{next typical} -
{finish typical} {
TekiWizardDefaults
TekiVerifyWizard
}
{next custom} {
TekiPackagesWizard
}
{finish custom} {
TekiVerifyWizard
}
cancel {
return -code $TekiInfo(cancelCode)
}
default {
TekiError "Internal error:\n $rv\ndoesn't match case in switch"
}
}
}
}
proc TekiPackagesWizard {} {
global TekiInfo newPackage
set packages $newPackage(available)
#
# If there's only one package, just pretend they hit "next"
#
if {[llength $packages] != 1} {
while (1) {
set choices {}
foreach pkg $packages {
if {[lsearch $TekiInfo(packages) $pkg] == -1} {
lappend choices [list $newPackage($pkg,name) $pkg 0]
} else {
lappend choices [list $newPackage($pkg,name) $pkg 1]
}
}
set rv [Wise_Checklist "Select packages to install" $choices]
switch [lindex $rv 0] {
next {
set TekiInfo(packages) [lrange $rv 1 end]
TekiArchListWizard
}
back {
return
}
finish {
set TekiInfo(packages) [lrange $rv 1 end]
TekiVerifyWizard
}
cancel {
return -code $TekiInfo(cancelCode)
}
}
}
} else {
set TekiInfo(packages) $packages
TekiArchListWizard
}
}
proc TekiArchListWizard {} {
global TekiInfo newPackage
set objFileCount 0
foreach pkg $TekiInfo(packages) {
incr objFileCount [llength $newPackage($pkg,objFiles)]
}
if {$objFileCount == 0} {
TekiExtrasWizard
return
}
while (1) {
#
# We need to rebuild the choices list each time through the
# loop so we can retain the users setting when they go on
# to the next wizard and then hit the "back" button. If
# we don't rebuild it, then the wizard contents might
# be out of sync with TekiInfo(archList), since this is
# changed on next/finish
#
set choices {}
foreach pkg $TekiInfo(packages) {
foreach pair $newPackage($pkg,objFiles) {
set name [lindex $pair 0]
if {[lsearch $choices [list $name]*] == -1} {
if {[lsearch $TekiInfo(archList) $name] == -1} {
lappend choices [list $name $name 0]
} else {
lappend choices [list $name $name 1]
}
}
}
}
set rv [Wise_Checklist "Select architectures to install" $choices]
switch [lindex $rv 0] {
next {
set TekiInfo(archList) [lrange $rv 1 end]
TekiExtrasWizard
}
back {
return
}
finish {
set TekiInfo(archList) [lrange $rv 1 end]
TekiVerifyWizard
}
cancel {
return -code $TekiInfo(cancelCode)
}
}
}
}
proc TekiExtrasWizard {} {
global TekiInfo newPackage
#
# Figure out if there are any extras to install! If not, skip
# this step.
#
set docFileCount 0
set dataFileCount 0
set exampleFileCount 0
foreach pkg $TekiInfo(packages) {
incr docFileCount [llength $newPackage($pkg,docFiles)]
incr dataFileCount [llength $newPackage($pkg,dataFiles)]
incr exampleFileCount [llength $newPackage($pkg,exampleFiles)]
}
if {$docFileCount == 0} {
set TekiInfo(extras) [TekiListDelete $TekiInfo(extras) doc]
}
if {$dataFileCount == 0} {
set TekiInfo(extras) [TekiListDelete $TekiInfo(extras) data]
}
if {$exampleFileCount == 0} {
set TekiInfo(extras) [TekiListDelete $TekiInfo(extras) example]
}
if {($docFileCount + $dataFileCount + $exampleFileCount) == 0} {
TekiCodeDirWizard
return
}
while (1) {
set choices {}
if $docFileCount {
lappend choices [list "Install documentation" doc \
[expr [lsearch $TekiInfo(extras) doc] != -1]]
}
if $dataFileCount {
lappend choices [list "Install data files" data \
[expr [lsearch $TekiInfo(extras) data] != -1]]
}
if $exampleFileCount {
lappend choices [list "Install examples" examples \
[expr [lsearch $TekiInfo(extras) examples] != -1]]
}
set rv [Wise_Checklist "Select Extras to install" $choices]
switch [lindex $rv 0] {
next {
set TekiInfo(extras) [lrange $rv 1 end]
TekiCodeDirWizard
}
back {
return
}
finish {
set TekiInfo(extras) [lrange $rv 1 end]
TekiVerifyWizard
}
cancel {
return -code $TekiInfo(cancelCode)
}
}
}
}
proc TekiCodeDirWizard {} {
global TekiInfo auto_path env tcl_pkgPath
while (1) {
# Give the user several standard options of where to install
# the code:
# option #1: the current value of the codeDir
# option #2: [info library]
# option #3: the TCLLIBPATH environment variable
# option #4: the parent of [info library]
# option #5: all the elements of tclPkgPath
# option #6: all the elements of auto_path
# option #7: "other"
# The logic makes sure each choice only appears once.
set choices {}
set dir [TekiNormalizeDirName $TekiInfo(codeDir)]
lappend choices [list $dir $dir 1]
set dir [TekiNormalizeDirName [info library]]
if {[lsearch $choices [list $dir $dir ?]] == -1} {
lappend choices [list $dir $dir 0]
}
if [info exists env(TCLLIBPATH)] {
set dir [TekiNormalizeDirName $env(TCLLIBPATH)]
if {[lsearch $choices [list $dir $dir ?]] == -1} {
lappend choices [list $dir $dir 0]
}
}
set dir [TekiNormalizeDirName [info library]/..]
if {[lsearch $choices [list $dir $dir ?]] == -1} {
lappend choices [list $dir $dir 0]
}
foreach dir $tcl_pkgPath {
set dir [TekiNormalizeDirName $dir]
if {[lsearch $choices [list $dir $dir ?]] == -1} {
lappend choices [list $dir $dir 0]
}
}
foreach dir $auto_path {
set dir [TekiNormalizeDirName $dir]
if {[lsearch $choices [list $dir $dir ?]] == -1} {
lappend choices [list $dir $dir 0]
}
}
lappend choices [list other other 0]
set rv [Wise_Radiolist "Select root directory for code files" $choices]
#
# If they choose other, let them chose a directory.
# After we have the candidate directory, make sure it
# exists and is writable.
#
set option [lindex $rv 0]
set rv [lrange $rv 1 end]
switch $option {
next -
finish {
if {$rv == "other"} {
set dir [Wise_GetDirName $dir]
if {$dir == ""} {
continue; # try again....
}
} else {
set dir $rv
}
#
# Warn them if they're installing in a non-standard place
#
set found 0
foreach d $auto_path {
set nd [TekiNormalizeDirName $d]
if [string match $nd $dir] {
set found 1
break
}
}
if {!$found} {
foreach d $tcl_pkgPath {
set nd [TekiNormalizeDirName $d]
if [string match $nd $dir] {
set found 1
break
}
}
}
if {!$found} {
TekiWarning "Warning: you are installing in a non-standard location
Be sure to add $dir to your TCLLIBPATH environment variable" 0 Ok
}
if {![TekiVerifyDir $dir]} {
continue
}
set TekiInfo(codeDir) $dir
if {$option == "next"} {
TekiDocDirWizard
} else {
TekiVerifyWizard
}
}
back {
return
}
cancel {
return -code $TekiInfo(cancelCode)
}
}
}
}
proc TekiDocDirWizard {} {
global TekiInfo
if {[lsearch $TekiInfo(extras) doc] == -1} {
TekiVerifyWizard
return
}
while (1) {
# Give the user several standard options of where to install
# the documentation:
# option #1: the current value of the docDir
# option #2: [info library]/../../doc
# option #3: $codeDir/doc
# option #4: "other"
# The logic makes sure each choice only appears once.
set choices {}
set dir [TekiNormalizeDirName $TekiInfo(docDir)]
lappend choices [list $dir $dir 1]
set dir [TekiNormalizeDirName [info library]/../../doc]
if {[lsearch $choices [list $dir $dir ?]] == -1} {
lappend choices [list $dir $dir 0]
}
set dir [TekiNormalizeDirName $TekiInfo(codeDir)/doc]
if {[lsearch $choices [list $dir $dir ?]] == -1} {
lappend choices [list $dir $dir 0]
}
lappend choices [list other other 0]
set rv [Wise_Radiolist "Select root directory for documentation files" $choices]
set option [lindex $rv 0]
set rv [lrange $rv 1 end]
switch $option {
next -
finish {
if {$rv == "other"} {
set dir [Wise_GetDirName $dir]
if {$dir == ""} {
continue; # try again....
}
} else {
set dir $rv
}
if {![TekiVerifyDir $dir]} {
continue
}
set TekiInfo(docDir) $dir
TekiVerifyWizard
}
back {
return
}
cancel {
return -code $TekiInfo(cancelCode)
}
}
}
}
proc TekiVerifyWizard {} {
global TekiInfo newPackage
set installDoc [expr [lsearch $TekiInfo(extras) doc] != -1]
set installData [expr [lsearch $TekiInfo(extras) data] != -1]
set installExamples [expr [lsearch $TekiInfo(extras) examples] != -1]
set msg "Install these packages:\n"
foreach pkg $TekiInfo(packages) {
set msg [format "%s %s %s\n" $msg \
$newPackage($pkg,name) \
$newPackage($pkg,version)]
}
set msg [format "%s\n...for these architectures:\n" $msg]
foreach arch $TekiInfo(archList) {
set msg [format "%s %s\n" $msg $arch]
}
set msg [format "%s\nInstall code in \n %s\n" $msg $TekiInfo(codeDir)]
if {$installDoc} {
set msg [format "%s\nInstall documentation in \n %s\n" \
$msg $TekiInfo(docDir)]
}
if {$installExamples} {
set msg [format "%s\nInstall examples in \n %s\n" \
$msg $TekiInfo(codeDir)]
}
if {$installData} {
set msg [format "%s\nInstall data files in \n %s\n" \
$msg $TekiInfo(codeDir)]
}
set rv [TekiWarning $msg 0 {Finish {< Back} Cancel}]
if {$rv == 0} {
return -code $TekiInfo(finishCode)
}
if {$rv == 2} {
return -code $TekiInfo(cancelCode)
}
}
#
# Display copyrights for all selected packages.
# Returns a list of packages for which the user accepted the copyright
#
proc TekiDisplayCopyrights {pkgList} {
global tclPkgInfo TekiInfo newPackage auto_path env
Debug_Enter TekiDisplayCopyrights
set packages {}
set accept 0
set dontaccept 1
set acceptrest 2
set abort 3
set code 0
foreach {pkg fn} $pkgList {
if {($code != $acceptrest) &&
[file exists $fn]} {
set f [open $fn r]
set msg [read $f]
close $f
set name $newPackage($pkg,name)
set code [Wise_Message "Copyright for $name" \
$msg {Accept {Do not Accept} {Accept Rest} Abort}]
if {$code == $accept} {
lappend packages $pkg
}
if {$code == $acceptrest} {
lappend packages $pkg
}
if {$code == $dontaccept} {
TekiWarning "Skipping installation of $name" 0 {Ok}
}
if {$code == $abort} {
TekiWarning "Aborting installation" 0 {Ok}
return {}
}
} else {
lappend packages $pkg
}
}
Debug_Leave
return $packages
}
# The following procedure is called by DoFileInstall and
# DoWWWBrowse to
# 1. Read/verify the teki file
# 2. Gather the installation parameters
# 3. Fetch & display copyright notices
# 4. Install the extension
#
# It does a web based install if $web is true, a file system
# based install if $web if false
proc TekiInteractiveInstall {tekiFile web} {
global tclPkgInfo TekiInfo newPackage auto_path env
Debug_Enter TekiInteractiveInstall
# 1. Read and verify it
catch {unset newPackage}
set code [catch {TekiReadFile $tekiFile} err]
if $code {
TekiError "Error reading $tekiFile\n $err\nerrorCode = $code"
catch {unset newPackage}
return
}
set code [catch {TekiVerifyFile} err]
if $code {
TekiError "Invalid Teki file $tekiFile:\n$err"
catch {unset newPackage}
return
}
# 2. Collect all the information from the user.
TekiWizardDefaults
set code [catch TekiTypeWizard err]
if {$code == $TekiInfo(cancelCode)} {
return
}
if {$code != $TekiInfo(finishCode)} {
TekiError $err
return
}
# 3. Fetch/display all the copyright notices. If web based install,
# download the copyright files. The wwwCleanup variable is a list
# of all the files in tmpdir that we have to delete when we're done.
set fileList {}
set nocopyright {}
set tmpdir $TekiInfo(tmpDir)
set index 0
if $web {
foreach pkg $TekiInfo(packages) {
set inFile $newPackage($pkg,copyright)
set srcURL $newPackage($pkg,srcURL)
set outFile [file join $tmpdir copyright$index]
if [string length $inFile] {
if [catch {TekiDownloadFile $srcURL/$inFile $outFile} err] {
TekiWarning "Couldn't find copyright file\n$srcURL/$inFile\n$err\n\nskipping package" 0 {Ok}
} else {
lappend fileList $pkg $outFile
}
} else {
lappend nocopyright $pkg
}
}
} else {
foreach pkg $TekiInfo(packages) {
set srcDir $newPackage($pkg,srcDir)
set copyright $newPackage($pkg,copyright)
set inFile [file join [file dirname $tekiFile] $srcDir $copyright]
if [string length $copyright] {
if {![file exists $inFile]} {
TekiWarning "Couldn't find copyright file\n$inFile\n\nskipping package" 0 {Ok}
} else {
lappend fileList $pkg $inFile
}
} else {
lappend nocopyright $pkg
}
}
}
set TekiInfo(packages) [concat $nocopyright [TekiDisplayCopyrights $fileList]]
if $web {
foreach file $fileList {
catch {file delete -force $file}
}
}
if {$TekiInfo(packages) == ""} {
Debug_Leave
return;
}
# 4. Install it!
set installDoc [expr [lsearch $TekiInfo(extras) doc] != -1]
set installData [expr [lsearch $TekiInfo(extras) data] != -1]
set installExamples [expr [lsearch $TekiInfo(extras) examples] != -1]
TekiInstall [file dirname $tekiFile] $web \
$TekiInfo(codeDir) $TekiInfo(docDir) \
$TekiInfo(packages) $TekiInfo(archList) \
$installData $installDoc $installExamples
TekiGetAllPkgInfo
TekiUpdateBrowser
catch {unset newPackage}
Debug_Leave
}
#-----------------------------------------------------------------------
#
# File menu callbacks --
#
# TekiDoFileInstall is called when the user select the Install item in the
# File menu
# TekiDoFileUninstall is called when the user select the Uninstall item in the
# File menu
# TekiDoFileExit is called when the user select the Exit item in the File menu
#
# TekiDoFileInstall -- called from the "File->Install" menu item.
#
proc TekiDoFileInstall {} {
global tclPkgInfo TekiInfo newPackage auto_path env
Debug_Enter TekiDoFileInstall
catch {unset newPackage}
# Get the teki install file
set file [tk_getOpenFile -title "Open TEKI file" -filetypes {{{Tek Files} .tek} {{All Files} *}}]
if {$file == ""} {
return;
}
TekiInteractiveInstall $file 0
Debug_Leave
}
#
# TekiDoFileUninstall {} {
#
# Uninstall the current package, update UI
#
proc TekiDoFileUninstall {} {
global tclPkgInfo tcl_library TekiInfo
Debug_Enter TekiDoFileUninstall
set packages {}
foreach pkg $TekiInfo(currPackage) {
set name $tclPkgInfo($pkg,name)
if {($name == "Tcl") || ($name == "Tk")} {
tk_dialog .error "Error" "Can't uninstall $pkg" {} 0 Ok
continue
}
lappend packages $pkg
}
TekiUninstall $packages
TekiGetAllPkgInfo
TekiUpdateBrowser
set w $TekiInfo(Browser)
$w selection set end
set info [$w get end]
set TekiInfo(currPackage) [lindex $info 0]
TekiUpdateReadme
Debug_Leave
}
proc TekiDoFileExit {} {
Debug_Enter TekiDoFileExit
exit
}
#-----------------------------------------------------------------------
#
# WWW menu callbacks --
#
#
# Update the currently selected package.
# 1. Fetching the .tek file using the package's the URL field
# 2. Report the current version number and the new version number.
# Ask the user if they want to proceed.
# 3. If so, copy all the package files into a temporary directory
# and install from there
#
proc TekiDoWWWUpdate {} {
global tclPkgInfo TekiInfo
Debug_Enter TekiDoWWWUpdate
Debug_Leave
}
proc TekiWWWBrowseInstall {} {
global TekiInfo
set tmpDir $TekiInfo(tmpDir)
# Gather files for a batch install, and generate/use a bundle file
set filelist {}
set pkgList {}
set index 0
foreach i [.toc.list curselection] {
if {$i == 0} {
# skip labels :-)
continue
}
# The first element of the selection is the package number,
# which is the index in TekiInfo(contents). Retrieve it so
# we know which package the user selected.
set info [.toc.list get $i]
set index [lindex $info 0]
incr index -1
set tuple [lindex $TekiInfo(contents) $index]
set name [lindex $tuple 0]
set inFile [lindex $tuple 5]
set pkg [lindex $tuple 6]
set tmpDir $TekiInfo(tmpDir)
set outFile [file join $tmpDir tekiTmp$index]
if [catch {TekiDownloadFile $inFile $outFile} err] {
set rv [TekiWarning "Couldn't install package $name\nError occured while downloading\n$inFile\n$err" 0 {Ok Cancel}]
if {$rv == 0} {
foreach f $filelist {
file delete -force $f
}
return
}
} else {
lappend filelist $outFile
lappend pkgList $pkg
incr index
}
}
if {[llength $filelist] == 0} {
TekiWarning "No valid packages found to install" 0 {Ok}
return
}
set bundleFile [file join $tmpDir tekiBundle.tek]
set f [open $bundleFile w]
puts $f {# TekiFile 1.0
# Automatically generated TEKI bundle file
}
foreach file $filelist {
puts $f "TekiReadFile $file"
}
puts $f "set newPackage(defaultPackages) [list $pkgList]"
close $f
TekiInteractiveInstall $bundleFile 1
file delete -force $bundleFile
foreach f $filelist {
file delete -force $f
}
}
proc TekiWWWBrowseReadme {} {
global TekiInfo
set packages {}
set tmpDir $TekiInfo(tmpDir)
foreach i [.toc.list curselection] {
if {$i == 0} {
# skip labels :-)
continue
}
# The first element of the selection is the package number,
# which is the index in TekiInfo(contents). Retrieve it so
# we know which package the user selected.
set info [.toc.list get $i]
set index [lindex $info 0]
incr index -1
set tuple [lindex $TekiInfo(contents) $index]
set name [lindex $tuple 0]
set ver [lindex $tuple 1]
set url [lindex $tuple 4]
if {[string length $url] == 0} {
set rv [TekiWarning "No information available on $name $ver" 0 {Ok Cancel}]
if {$rv == 1} {
return
}
continue
}
set outFile [file join $tmpDir readme]
if [catch {TekiDownloadFile $url $outFile} err] {
set rv [TekiWarning "Coulnd't find readme for $name $ver:\n $err" 0 {Ok Cancel}]
if {$rv == 1} {
return
}
continue
}
set f [open $outFile r]
set msg [read $f]
close $f
file delete -force $outFile
set code [Wise_Message "Information for $name" $msg {Ok Cancel}]
if {$code == 1} {
return
}
}
}
proc TekiWWWBrowseAll {} {
global TekiInfo
.toc.list delete 0 end
set str [format "%-4s%-11s%-8s %-15s%-28s" "#" "package" "version" "requires" "description"]
.toc.list insert end $str
set i 1
foreach tuple $TekiInfo(contents) {
set pkg [lindex $tuple 0]
set ver [lindex $tuple 1]
set req [lindex $tuple 2]
set des [lindex $tuple 3]
.toc.list insert end [format "%-4d%-15s%-8s%-16s%-28s" $i $pkg $ver $req $des]
incr i
}
}
proc TekiWWWBrowseCompat {} {
global tcl_version tk_version TekiInfo
.toc.list delete 0 end
set str [format "%-4s%-11s%-8s %-15s%-28s" "#" "package" "version" "requires" "description"]
.toc.list insert end $str
set i 1
foreach tuple $TekiInfo(contents) {
set sat 1
foreach pair [lindex $tuple 2] {
set pkg [lindex $pair 0]
set ver [lindex $pair 1]
Debug_Print $pkg $ver
if {($pkg == "Tcl") && ![package vsatisfies $tcl_version $ver]} {
set sat 0
}
if {($pkg == "Tk") && ![package vsatisfies $tk_version $ver]} {
set sat 0
}
}
if $sat {
set pkg [lindex $tuple 0]
set ver [lindex $tuple 1]
set req [lindex $tuple 2]
set des [lindex $tuple 3]
.toc.list insert end [format "%-4d%-15s%-8s%-16s%-28s" $i $pkg $ver $req $des]
}
incr i
}
}
proc TekiDoWWWBrowse {} {
global TekiInfo
set url $TekiInfo(browseURL)
set tmpDir $TekiInfo(tmpDir)
set outFile [file join $tmpDir contents.tkr]
if [catch {TekiDownloadFile $url $outFile} err] {
TekiWarning "Couldn't find browse information file\n$err" 0 {Ok}
return
}
TekiReadTOCFile $outFile
file delete -force $outFile
# Ok, TekiInfo(contents) should contain a list of
# name version requires descript readme-url tek-file-url
if {[info commands .toc] == ""} {
toplevel .toc
set w .toc
set numButtons 5
button $w.install -text Install -command TekiWWWBrowseInstall
button $w.readme -text "View Readme" -command TekiWWWBrowseReadme
button $w.showall -text "Show All Packages" -command TekiWWWBrowseAll
button $w.showcompat -text "Show Compatible Packages" -command TekiWWWBrowseCompat
button $w.cancel -text "Close" -command "wm withdraw .toc"
scrollbar $w.scroll -command "$w.list yview"
listbox $w.list -font $TekiInfo(fixedfont) -relief sunken -width 100 \
-bd 2 -yscrollcommand "$w.scroll set" -setgrid 1 -height 12 \
-selectmode extended
grid $w.scroll -column $numButtons -row 0 -sticky ns
grid $w.list -column 0 -columnspan $numButtons -row 0 -sticky nsew
grid $w.install -column 0 -row 1
grid $w.readme -column 1 -row 1
grid $w.showall -column 2 -row 1
grid $w.showcompat -column 3 -row 1
grid $w.cancel -column 4 -row 1 -columnspan 2
}
Wise_CenterWindow .toc
wm transient .toc .
TekiWWWBrowseAll
}
#-----------------------------------------------------------------------
#
# WWW support --
#
# This section contains code to download files and directories from
# a URL into a temp file.
#
# Get a decent value for the temporary directory
#
switch $tcl_platform(platform) {
windows {set TekiInfo(tmpDir) C:/TEMP}
unix {set TekiInfo(tmpDir) /tmp}
}
if {[info exists env(TMP)] && [file isdirectory $env(TMP)]} {
set TekiInfo(tmpDir) $env(TMP)
}
if {[info exists env(TMPDIR)] && [file isdirectory $env(TMPDIR)]} {
set TekiInfo(tmpDir) $env(TMPDIR)
}
if {[info exists env(TEMP)] && [file isdirectory $env(TEMP)]} {
set TekiInfo(tmpDir) $env(TEMP)
}
if {[info exists env(TEMPDIR)] && [file isdirectory $env(TEMPDIR)]} {
set TekiInfo(tmpDir) $env(TEMPDIR)
}
set TekiInfo(browseURL) http://www2.cs.cornell.edu/zeno/bsmith/contents.tkc
# -----------------------------------------------------------------------
#
# Routines to read and verify .tek files
#
# Todo:
# Bullet-proof this section using a safe interpreter
#
proc TekiReadTOC1.0 {filename} {
global TekiInfo
if [catch {source $filename} err] {
global errorCode errorInfo
error "Error reading version 1.0 TEKI TOC file $filename.
Execute \"source $filename\" in a Tcl shell to find error" \
$errorInfo $errorCode
}
}
proc TekiReadTOCFile {filename} {
Debug_Enter TekiReadTOCFile
set f [open $filename r]
set x [split [gets $f]]
close $f
if {([llength $x] != 3) ||
[string compare [lindex $x 0] #] ||
[string compare [lindex $x 1] TekiTOC] } {
error "Invalid Teki Table-of-contents file"
}
set tekiFileVersion [lindex $x 2]
if [catch {TekiReadTOC$tekiFileVersion $filename} err] {
global errorCode errorInfo
error $err $errorInfo $errorCode
}
Debug_Leave
}
proc TekiReadVersion1.0 {filename} {
global newPackage
if [catch {source $filename} err] {
global errorCode errorInfo
error "Error reading version 1.0 TEKI file $filename.
Execute \"source $filename\" in a Tcl shell to find error" \
$errorInfo $errorCode
}
}
proc TekiReadFile {filename} {
Debug_Enter ReadTekiFile
set cwd [pwd]
cd [file dirname $filename]
set filename [file tail $filename]
set f [open $filename r]
set x [split [gets $f]]
close $f
if {([llength $x] != 3) ||
[string compare [lindex $x 0] #] ||
[string compare [lindex $x 1] TekiFile] } {
cd $cwd
error "Invalid Teki file"
}
set tekiFileVersion [lindex $x 2]
if [catch {TekiReadVersion$tekiFileVersion $filename} err] {
global errorCode errorInfo
cd $cwd
error $err $errorInfo $errorCode
}
cd $cwd
Debug_Leave
}
proc TekiVerifyFile {} {
global newPackage
foreach attr {available defaultPackages defaultArch
defaultInstallDoc defaultInstallExamples defaultInstallData} {
if ![info exists newPackage($attr)] {
error "Teki file does not define attribute '$attr'"
}
}
foreach pkg $newPackage(available) {
foreach attr {name version description requires updateURL srcURL
registerURL srcDir destDir infoFile tclFiles dataFiles
docDir docFiles exampleFiles objFiles copyright} {
if ![info exists newPackage($pkg,$attr)] {
error "Package $pkg does not define attribute '$attr'"
}
}
}
foreach pkg $newPackage(defaultPackages) {
if ![info exists newPackage($pkg,name)] {
error "Teki file defines invalid package $pkg in as part of defaultPackages"
}
}
}
# ---------------------------------------------------------------------- -
#
# TekiInstall
#
# Install a package.
# The file has been read and verified, and the packages variable refers
# to good packages (they exist in newPackage, haven't already been
# installed, etc). The errors we have to worry about are errors copying
# files.
#
# TekiDownloadFile --
#
# Copy $url into $tmpDir/$file, making directories as needed
#
# Throws an error if user presses cancel button during download
# or another error occurs.
# The caller must delete the file when done.
proc TekiCancelDownload {} {
global TekiInfo
wm withdraw .dl
http_reset $TekiInfo(token)
}
proc TekiDownloadProgressEnd {} {
wm withdraw .dl
}
proc TekiDownloadProgressStart {url} {
global TekiInfo
if {[info commands .dl] == ""} {
toplevel .dl
label .dl.l -font $TekiInfo(fixedfont)
scale .dl.s -orient horizontal -sliderrelief flat \
-sliderlength 0 -showvalue 0
button .dl.cancel -text Cancel -command TekiCancelDownload
grid .dl.l -row 0 -column 0 -sticky ew
grid .dl.s -row 1 -column 0 -sticky ew
grid .dl.cancel -row 2 -column 0
} else {
.dl.s configure -sliderlength 0
}
wm title .dl "Downloading $url"
.dl.l configure -text $url
Wise_CenterWindow .dl
}
proc TekiDownloadProgress {token max curr} {
global TekiInfo
set TekiInfo(token) $token
if {$max > 0} {
set width [winfo width .dl.s]
set pixels [expr int($curr*$width/$max)]
.dl.s configure -sliderlength $pixels
update idletasks
}
}
proc TekiDownloadFile {url dest} {
global errorInfo errorCode
file mkdir [file dirname $dest]
set f [open $dest w]
fconfigure $f -translation binary
TekiDownloadProgressStart $url
set code [catch {http_get $url -channel $f -progress TekiDownloadProgress} token]
TekiDownloadProgressEnd
close $f
if {$code} {
catch {file delete -force $dest}
error "HTTP error:\n $token\n\nwhile fetching\n $url" \
$errorInfo $errorCode
}
upvar #0 $token state
# The variable state(http) contains the server response
# code. If the code is [45]xx, there's a problem with the
# URL.
if {[string match {[45]*} [lindex $state(http) 1]]} {
catch {file delete -force $dest}
set err [lrange $state(http) 2 end]
error "HTTP error:\n $err\n\nwhile fetching\n $url" \
}
# Handle URL redirects
if {$state(status) == "reset"} {
file delete -force $dest
uplevel #0 unset $token
error "Connection reset by user"
}
foreach {name value} $state(meta) {
if {[regexp -nocase ^location$ $name]} {
file delete -force $dest
TekiDownloadFile [string trim $value] $dest
}
}
uplevel #0 unset $token
}
#
# Copy from $src to $dest
# Make directories as needed
# Download file is source is a URL
# Example:
# src = http://www2.cs.cornell.edu/bsmith/tmp/tcl-files/foo.tcl
# dest = /usr/local/lib/tcl/dp4.0/tcl-files/foo.tcl
#
proc TekiCopy {src dest} {
file mkdir [file dirname $dest]
if [string match http://* $src] {
TekiDownloadFile $src $dest
} else {
file copy $src $dest
}
}
#
# TekiInstall --
#
# Install the packages passed in. Can be called
# with through the command line or the Teki GUI.
#
# Parameters:
#
# dirBase -- directory where teki file is located. Other
# file (code, etc) are given by the srcDir relative
# to this directory
# web -- if true if we're doing a Web-based install and the
# $srcURL for each package is used to locate files to copy.
# If false, $dirBase/$srcDir for each package gives the
# place where the source files are located.
# codePrefix -- prefix for installing code, data, and examples. For
# example, /usr/local/lib/tcl
# docPrefix -- prefix for installing documentation. (e.g., /usr/man)
# packages -- list of packages to install (members of newPackage(installed))
# archList -- list of archtectures, (members of TekiInfo(systemNames))
# installData -- Boolean indicating whether to install data files
# installDoc -- Boolean indicating whether to install documentation
# installExamples -- Boolean indicating whether to install examples
#
# Notes
# Installs documentation in $docPrefix/$newPackage(destDir)
# Installs tcl files, object files, data, and examples in
# $codePrefix/$newPackage(destDir)
#
#
proc TekiInstall {dirBase web codePrefix docPrefix packages archList
{installData 1} {installDoc 1} {installExamples 1}} {
global newPackage tcl_platform TekiInfo errorCode errorInfo
Debug_Enter TekiInstall
if {![file isdirectory $codePrefix]} {
TekiError "Error: Destination directory $codePrefix doesn't exist"
return
}
foreach pkg $packages {
if $web {
set srcDir $newPackage($pkg,srcURL)
} else {
set srcDir [file join $dirBase $newPackage($pkg,srcDir)]
}
set steps {
"Making directory"
"Creating pkgIndex.tcl"
"Information file"
"Tcl files"
}
if {$installData && [string length $newPackage($pkg,dataFiles)]} {
lappend steps "Data files"
}
if {$installExamples && [string length $newPackage($pkg,exampleFiles)]} {
lappend steps "Examples"
}
if {$installDoc && [string length $newPackage($pkg,docFiles)]} {
lappend steps "Documentation"
}
foreach pair $newPackage($pkg,objFiles) {
set arch [lindex $pair 0]
if {[string match "all" $archList] ||
([lsearch -exact $archList $arch] != -1)} {
lappend steps "Files for $arch"
}
}
Progress_StepInit "Installing $pkg" $steps
Undo_Add $pkg Progress_StepEnd
# Make the destination directory. If it exists, verify that
# we should replace it
set destDir [file join $codePrefix $newPackage($pkg,destDir)]
if [file isdirectory $destDir] {
set rval [TekiWarning \
"Warning: Directory $destDir already exists.
Delete will replace it
Cancel will abort the installation of this package
Abort will abort the installation of this and all remaining packages" \
1 {Delete Cancel Abort}]
if {$rval == 2} {
Undo_All $pkg
break
}
if {$rval == 1} {
Undo_All $pkg
continue
}
if [catch {file delete -force $destDir} err] {
set rval [TekiWarning \
"Warning: Couldn't delete $destDir\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages" \
0 {Cancel Abort}]
Undo_All $pkg
if {$rval == 0} {
continue
} else {
break
}
}
}
Progress_StepPrint
# Create $destDir, open $destDir/pkgIndex.tcl, and start writing it...
set fn [file join $destDir pkgIndex.tcl]
if [catch {file mkdir [file dirname $fn]} err] {
set rval [TekiWarning \
"Couldn't create target directory $destDir\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages" \
0 {Cancel Abort}]
Undo_All $pkg
if {$rval == 0} {
continue
} else {
break
}
}
Undo_Add $pkg "file delete -force \"$destDir\""
if [catch {set pkgIndex [open $fn w]} err] {
set rval [TekiWarning \
"Couldn't create pkgIndex.tcl in $destDir\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages" \
0 {Cancel Abort}]
Undo_All $pkg
if {$rval == 0} {
continue
} else {
break
}
}
Undo_Add $pkg "close $pkgIndex"
puts $pkgIndex "
# This file was automatically generated by TEKI
global tclPkgInfo
if {!\[info exists tclPkgInfo(installed)\] ||
\[lsearch \$tclPkgInfo(installed) $pkg\] == -1} {
lappend tclPkgInfo(installed) $pkg
set tclPkgInfo($pkg,codePrefix) [list $codePrefix]
set tclPkgInfo($pkg,docPrefix) [list $docPrefix]
set tclPkgInfo($pkg,installData) $installData
set tclPkgInfo($pkg,installDoc) $installDoc
set tclPkgInfo($pkg,installExamples) $installExamples
set tclPkgInfo($pkg,name) [list $newPackage($pkg,name)]
set tclPkgInfo($pkg,version) [list $newPackage($pkg,version)]
set tclPkgInfo($pkg,description) [list $newPackage($pkg,description)]
set tclPkgInfo($pkg,requires) [list $newPackage($pkg,requires)]
set tclPkgInfo($pkg,tekiFile) [list $newPackage($pkg,tekiFile)]
set tclPkgInfo($pkg,updateURL) [list $newPackage($pkg,updateURL)]
set tclPkgInfo($pkg,registerURL) [list $newPackage($pkg,registerURL)]
set tclPkgInfo($pkg,destDir) [list $newPackage($pkg,destDir)]
set tclPkgInfo($pkg,tclFiles) [list $newPackage($pkg,tclFiles)]
set tclPkgInfo($pkg,systemNames) [list $TekiInfo(systemNames)]"
Progress_StepPrint
# Copy in all the platform independent files to $destDir
# Preserve the package directory hierarchy
set infoFile $newPackage($pkg,infoFile)
if [string length $infoFile] {
if [catch {TekiCopy $srcDir/$infoFile $destDir/$infoFile} err] {
set rval [TekiWarning \
"Couldn't copying\n$infoFile\nto\n$destDir\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages
Ignore will ignore this error and continue installation" \
0 {Cancel Abort Ignore}]
if {$rval == 0} {
Undo_All $pkg
continue
}
if {$rval == 1} {
Undo_All $pkg
break
}
set f {}
} else {
set f [file join $destDir $newPackage($pkg,infoFile)]
}
} else {
set f {}
}
puts $pkgIndex " set tclPkgInfo($pkg,infoFile) [list $f]"
Progress_StepPrint
set code 2
foreach file $newPackage($pkg,tclFiles) {
if [catch {TekiCopy $srcDir/$file $destDir/$file} err] {
set code [TekiWarning \
"Error copying\n$file\nto\n$destDir\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages" \
0 {Cancel Abort}]
break;
}
}
if {$code == 0} {
Undo_All $pkg
continue
}
if {$code == 1} {
Undo_All $pkg
break
}
Progress_StepPrint
set dataFiles {}
if $installData {
set dataFiles $newPackage($pkg,dataFiles)
foreach file $dataFiles {
if [catch {TekiCopy $srcDir/$file $destDir/$file} err] {
set code [TekiWarning \
"Error copying data file\n$file\nto\n$destDir\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages
Ignore will ignore this error and continue installation" \
0 {Cancel Abort Ignore}]
if {$code != 2} {
break
}
}
}
if {$code == 0} {
Undo_All $pkg
continue
}
if {$code == 1} {
Undo_All $pkg
break
}
Progress_StepPrint
}
puts $pkgIndex " set tclPkgInfo($pkg,dataFiles) [list $dataFiles]"
set exampleFiles {}
if $installExamples {
set exampleFiles $newPackage($pkg,exampleFiles)
foreach file $exampleFiles {
if [catch {TekiCopy $srcDir/$file $destDir/$file} err] {
set code [TekiWarning \
"Error copying\n$file\nto\n$destDir\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages
Ignore will ignore this error and continue installation" \
0 {Cancel Abort Ignore}]
if {$code != 2} {
break
}
}
}
if {$code == 0} {
Undo_All $pkg
continue
}
if {$code == 1} {
Undo_All $pkg
break
}
Progress_StepPrint
}
puts $pkgIndex " set tclPkgInfo($pkg,exampleFiles) [list $exampleFiles]"
set docFiles {}
set docSrcDir $srcDir/$newPackage($pkg,docDir)
set docDestDir [file join $docPrefix $newPackage($pkg,destDir)]
if $installDoc {
#
# Make the destination directory. If it exists, verify that
# we should replace it
#
if [file isdirectory $docDestDir] {
set rval [TekiWarning \
"Warning: Directory $docDestDir already exists.
Delete will replace it
Cancel will abort the installation of this package
Abort will abort the installation of all packages" \
1 {Delete Cancel Abort}]
if {$rval == 1} {
Undo_All $pkg
continue
}
if {$rval == 2} {
Undo_All $pkg
break
}
if [catch {file delete -force $docDestDir} err] {
set code [TekiWarning \
"Error: Couldn't delete $docDestDir:\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages
Ignore will ignore this error and continue installation" \
0 {Cancel Abort Ignore}]
if {$code == 0} {
Undo_All $pkg
continue
}
if {$code == 1} {
Undo_All $pkg
break
}
}
}
# Create $docDestDir
if [catch {file mkdir $docDestDir} err] {
set code [TekiWarning \
"Error creating documentation target directory $docDestDir\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages
Ignore will ignore this error and continue installation" \
0 {Cancel Abort Ignore}]
if {$code == 0} {
Undo_All $pkg
continue
}
if {$code == 1} {
Undo_All $pkg
break
}
} else {
Undo_Add $pkg "file delete -force \"$docDestDir\""
}
# Copy all the documentation files
foreach file $newPackage($pkg,docFiles) {
if [catch {TekiCopy $docSrcDir/$file $docDestDir/$file} err] {
set code [TekiWarning \
"Error copying\n$file\nto\n$docDestDir\n$err
Cancel will abort the installation of this package
Abort will abort the installation of all packages
Ignore will ignore this error and continue installation" \
0 {Cancel Abort Ignore}]
break
}
}
if {$code == 0} {
Undo_All $pkg
continue
}
if {$code == 1} {
Undo_All $pkg
break
}
Progress_StepPrint
}
# Copy in all the platform dependent files
# If we get an error and have to abort in the middle,
# we'll throw an error to break out of the nested
# loops.
set installedArchs {}
set code [catch {
foreach pair $newPackage($pkg,objFiles) {
set system [lindex $pair 0]
#
# system is a name for the system, such as Solaris
# one Windows. $archList is either the
# string "all" or a list of these names
#
if {[string match "all" $archList] ||
([lsearch -exact $archList $system] != -1)} {
set fileList {}
lappend installedArchs $system
foreach file [lindex $pair 1] {
if [catch {TekiCopy $srcDir/$file $destDir/$file} err] {
set rval [TekiWarning \
"Error copying\n$file\nto\n$destDir\n$err\n
Cancel will abort the installation of this package
Abort will abort the installation of all packages
Ignore will ignore this error and continue installation" \
0 {Cancel Abort Ignore}]
switch $rval {
0 {
Undo_All $pkg
error {} 5; # continue
}
1 {
Undo_All $pkg
error {} 6; # break
}
2 {}
}
}
lappend fileList $file
}
Progress_StepPrint
puts $pkgIndex " set tclPkgInfo($pkg,objFiles,$system) [list $fileList]"
}
}
} err]
switch $code {
0 {}
5 continue
6 break
default {
error $err $errorInfo $errorCode
}
}
puts $pkgIndex " set tclPkgInfo($pkg,archList) [list $installedArchs]"
# Finish up!
# puts $pkgIndex " TekiPackageInit $pkg"
puts $pkgIndex "}"
set tclfilesdir "$codePrefix/$pkg"
set outstr [concat package ifneeded dp 4.0 \[list LoadLib $tclfilesdir\]]
puts $pkgIndex $outstr
puts $pkgIndex "proc LoadLib dir {"
set outstr [concat foreach file \[glob \$dir/library/*.tcl\]]
puts -nonewline $pkgIndex " $outstr"
puts $pkgIndex " {"
set outstr [concat uplevel #0 source \[list \$file\]]
puts $pkgIndex " $outstr"
puts $pkgIndex " }"
set outstr [concat uplevel #0 load \[list \$dir/$file\]]
puts $pkgIndex " $outstr"
puts $pkgIndex "}"
close $pkgIndex
Undo_Clear $pkg
Progress_StepEnd
}
TekiGetAllPkgInfo
Debug_Leave
}
#
# TekiUninstall --
#
# Uninstall all the packages passed in. Can be called with through the
# command line or the Teki GUI.
#
proc TekiUninstall {pkgList} {
global tclPkgInfo
set noWarn 0
foreach pkg $pkgList {
if {!$noWarn} {
set rval [TekiWarning "Uninstall package $pkg ?" \
0 {Yes {Yes All} Cancel}]
if {$rval == 2} {
return
}
if {$rval == 1} {
set noWarn 1
}
}
# Delete all the code/data/example files.
# These are stored under the $codePrefix directory
set codePrefix $tclPkgInfo($pkg,codePrefix)
set destDir [file join $codePrefix $tclPkgInfo($pkg,destDir)]
if [catch {file delete -force $destDir} err] {
TekiError "Error: Couldn't delete $destDir:\n$err\nAborting uninstallation"
break
}
#
# delete doc files
#
if {$tclPkgInfo($pkg,installDoc)} {
set docPrefix $tclPkgInfo($pkg,docPrefix)
set dir [file join $docPrefix $tclPkgInfo($pkg,destDir)]
if [catch {file delete -force $dir} err] {
TekiError "Error: Couldn't delete $dir:\n$err\nAborting uninstallation"
break
}
}
}
}
# ---------------------------------------------------------------------
#
# Support procedures for all extensions. The following two procedures
# are used at runtime to source/load the right files (including architecture
# dependent files). TekiPackageInit is called by the pkgIndex.tcl file
# with the package name, after the tclPkgInfo variables have been set up.
# It determines if the OS is supported, and if so, makes the right calls
# to package ifneeded. TekiPackageSetup is called when package require
# is called. It loads all the files (including architecture dependent
# files
#
#
# Predefined system names
#
set TekiInfo(systemNames) {
{Solaris SunOS 5*}
{SunOS SunOS 4*}
{HPUX HP* 9*}
{Linux Linux* 2*}
{FreeBSD FreeBSD* 2*}
{Win95/NT Win* *}
}
proc TekiPackageInit {pkg} {
global tclPkgInfo tcl_platform
set os $tcl_platform(os)
set ver $tcl_platform(osVersion)
set system {}
foreach tuple $tclPkgInfo($pkg,systemNames) {
set osPattern [lindex $tuple 1]
set verPattern [lindex $tuple 2]
if {[string match $osPattern $os] &&
[string match $verPattern $ver]} {
set system [lindex $tuple 0]
break;
}
}
if [string length $system] {
set name $tclPkgInfo($pkg,name)
set version $tclPkgInfo($pkg,version)
package ifneeded $name $version "TekiPackageSetup $pkg $system"
}
}
proc TekiPackageSetup {pkg system} {
global tclPkgInfo
set currDir [pwd]
set prefix $tclPkgInfo($pkg,codePrefix)
set destDir [file join $prefix $tclPkgInfo($pkg,destDir)]
cd $destDir
set tclFiles $tclPkgInfo($pkg,tclFiles)
if [info exists tclPkgInfo($pkg,objFiles,$system)] {
set objFiles $tclPkgInfo($pkg,objFiles,$system)
} else {
set objFiles {}
}
foreach f $tclFiles {
catch {uplevel #0 "source $f"}
}
foreach f $objFiles {
if [string match *.tcl $f] {
catch {uplevel #0 "source $f"}
} else {
catch {uplevel #0 "load $f"}
}
}
cd $currDir
}
proc TekiGetAllPkgInfo {} {
global tcl_pkgPath auto_path tclPkgInfo tcl_version tk_version
catch {unset tclPkgInfo}
set tclver tcl$tcl_version
set tclPkgInfo(installed) $tclver
set tclPkgInfo($tclver,name) Tcl
set tclPkgInfo($tclver,requires) {}
set tclPkgInfo($tclver,version) $tcl_version
set tclPkgInfo($tclver,description) "Tcl core"
set tclPkgInfo($tclver,infoFile) {}
if [info exists tk_version] {
set tkver tk$tk_version
lappend tclPkgInfo(installed) $tkver
set tclPkgInfo($tkver,name) Tk
set tclPkgInfo($tkver,requires) [list [list Tcl $tcl_version]]
set tclPkgInfo($tkver,version) $tk_version
set tclPkgInfo($tkver,description) "Tk core"
set tclPkgInfo($tkver,infoFile) {}
}
#
# Get list of all pkgIndex.tcl files
#
set fileList {}
foreach dir [concat $auto_path [list $tcl_pkgPath]] {
if {![catch {glob [file join $dir pkgIndex.tcl] [file join $dir * pkgIndex.tcl]} files]} {
set fileList [concat $files $fileList]
}
}
set code 0
foreach file $fileList {
if [catch {source $file} err] {
if {$code != 1} {
set code [TekiWarning \
"Error sourcing $file:\n $err?" 0 {Ignore {Ignore All} Abort}]
}
if {$code == 2} {
exit
}
}
}
}
# ---------------------------------------------------------------------
#
# Initialization code
#
TekiGetAllPkgInfo
if $TekiInfo(gui) {
TekiCreateUI
wm deiconify .
}
if {$tcl_version < 8.0} {
proc fcopy args {
eval unsupported0 $args
}
}
Reference in New Issue Copy Permalink