diff options
Diffstat (limited to 'library/platform/shell.tcl')
| -rw-r--r-- | library/platform/shell.tcl | 31 |
1 files changed, 25 insertions, 6 deletions
diff --git a/library/platform/shell.tcl b/library/platform/shell.tcl index 3c2981c..d37cdcd 100644 --- a/library/platform/shell.tcl +++ b/library/platform/shell.tcl @@ -1,3 +1,4 @@ + # -*- tcl -*- # ### ### ### ######### ######### ######### ## Overview @@ -26,8 +27,14 @@ proc ::platform::shell::generic {shell} { LOCATE base out set code {} + # Forget any pre-existing platform package, it might be in + # conflict with this one. + lappend code {package forget platform} + # Inject our platform package lappend code [list source $base] + # Query and print the architecture lappend code {puts [platform::generic]} + # And done lappend code {exit 0} set arch [RUN $shell [join $code \n]] @@ -45,8 +52,14 @@ proc ::platform::shell::identify {shell} { LOCATE base out set code {} + # Forget any pre-existing platform package, it might be in + # conflict with this one. + lappend code {package forget platform} + # Inject our platform package lappend code [list source $base] + # Query and print the architecture lappend code {puts [platform::identify]} + # And done lappend code {exit 0} set arch [RUN $shell [join $code \n]] @@ -77,7 +90,7 @@ proc ::platform::shell::CHECK {shell} { return -code error "Shell \"$shell\" does not exist" } if {![file executable $shell]} { - return -code error "Shell \"$shell\" is not executable" + return -code error "Shell \"$shell\" is not executable (permissions)" } return } @@ -92,8 +105,12 @@ proc ::platform::shell::LOCATE {bv ov} { # here. If the found package is wrapped we copy the code somewhere # where the spawned shell will be able to read it. + # This code is brittle, it needs has to adapt to whatever changes + # are made to the TM code, i.e. the provide statement generated by + # tm.tcl + set pl [package ifneeded platform [package require platform]] - foreach {cmd base} $pl break + set base [lindex $pl end] set out 0 if {[lindex [file system $base]] ne "native"} { @@ -118,12 +135,14 @@ proc ::platform::shell::RUN {shell code} { } res] file delete $c - file delete $e if {$code} { - return -code error "Shell \"$shell\" is not executable" + append res \n[read [set chan [open $e r]]][close $chan] + file delete $e + return -code error "Shell \"$shell\" is not executable ($res)" } + file delete $e return $res } @@ -168,7 +187,7 @@ proc ::platform::shell::TEMP {} { } } } - if {[string compare $channel ""]} { + if {$channel != ""} { return -code error "Failed to open a temporary file: $channel" } else { return -code error "Failed to find an unused temporary file name" @@ -219,4 +238,4 @@ proc ::platform::shell::DIR {} { # ### ### ### ######### ######### ######### ## Ready -package provide platform::shell 1.1.1 +package provide platform::shell 1.1.4 |