Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

80 lines (62 sloc) 2.149 kb
#
# tcllauncher.tcl - tcl code that tcllauncher uses to do its thing
#
package require Tclx
#
# this is the code that gets called when Tcl launches because the
# tcllauncher "version" of Tcl jimmies the command line to make it
# so.
#
# this routine must now figure out what to do to launch the app
#
#
proc main {{argv ""}} {
set prog [info nameofexecutable]
# have we been invoked as a shell? If so, prog is empty, get it from
# the SHELL environment variable
if {$prog == ""} {
set prog $::env(SHELL)
}
set path [file split $prog]
set shortName [lindex $path end]
#
# tcllauncher cannot be invoked directly as "tcllauncher" -- it must be
# aliased to some other name
#
if {$shortName == "tcllauncher"} {
puts stderr "tcllauncher cannot be invoked as \"tcllauncher\"; it must be copied or linked as some other name"
exit 255
}
# if the last dir in the chain is "bin", swap in "lib/tcllauncher" in
# its place and tag a ".tcl" onto the end of the path name.
#
# otherwise just look in the same directory where the instance of the
# tcllauncher was found.
#
#puts stderr "path '$path', prog '$prog', shortName '$shortName'"
if {[lindex $path end-1] == "bin"} {
# this version looks for ../lib/tcllauncher/$shortName.tcl`
#set path [eval file join [lreplace $path end-1 end-1 lib tcllauncher]]
# this version looks for ../lib/$shortName/main.tcl
set ::launchdir [eval file join [lreplace $path end-1 end lib $shortName]]
set path [eval file join $::launchdir main.tcl]
} else {
set path $prog.tcl
}
if {![file readable $path]} {
puts stderr "$shortName: can't read '$path' (tcllauncher)"
exit 254
}
set ::argv0 $shortName
set initialArgv $argv
# ok now source in the file we (tcllauncher) figured out is the one
if {[catch {uplevel #0 source $path} catchResult] == 1} {
append ::errorInfo "\n from tcllauncher running \"[string trim "$::argv0 $initialArgv"]\""
puts stderr $::errorInfo
exit 255
}
exit 0
}
if {!$tcl_interactive} {
main $argv
}
Jump to Line
Something went wrong with that request. Please try again.