summaryrefslogtreecommitdiffstats
path: root/library/platform/shell.tcl
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2009-10-23 19:22:23 (GMT)
committerandreas_kupries <akupries@shaw.ca>2009-10-23 19:22:23 (GMT)
commit2cf3aa02dee40bb7023ecf5a2b50f52bb193ba74 (patch)
tree06a53eaf276d5dce4aec2fd1af20345898c44e43 /library/platform/shell.tcl
parent6e5f5cf6aa1b14b180e83744d92fa4639c49a587 (diff)
downloadtcl-2cf3aa02dee40bb7023ecf5a2b50f52bb193ba74.zip
tcl-2cf3aa02dee40bb7023ecf5a2b50f52bb193ba74.tar.gz
tcl-2cf3aa02dee40bb7023ecf5a2b50f52bb193ba74.tar.bz2
* library/platform/pkgIndex.tcl: Backported the platform packages
* library/platform/platform.tcl: from head and8.5 into the 8.4 * library/platform/shell.tcl: branch. Updated makefiles to install * unix/Makfile.in: the packages. * win/Makefile.in:
Diffstat (limited to 'library/platform/shell.tcl')
-rw-r--r--library/platform/shell.tcl238
1 files changed, 238 insertions, 0 deletions
diff --git a/library/platform/shell.tcl b/library/platform/shell.tcl
new file mode 100644
index 0000000..407e639
--- /dev/null
+++ b/library/platform/shell.tcl
@@ -0,0 +1,238 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Overview
+
+# Higher-level commands which invoke the functionality of this package
+# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a
+# repository as while the tcl shell executing packages uses the same
+# platform in general as a repository application there can be
+# differences in detail (i.e. 32/64 bit builds).
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require platform
+namespace eval ::platform::shell {}
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+# -- platform::shell::generic
+
+proc ::platform::shell::generic {shell} {
+ # Argument is the path to a tcl shell.
+
+ CHECK $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]]
+
+ if {$out} {file delete -force $base}
+ return $arch
+}
+
+# -- platform::shell::identify
+
+proc ::platform::shell::identify {shell} {
+ # Argument is the path to a tcl shell.
+
+ CHECK $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]]
+
+ if {$out} {file delete -force $base}
+ return $arch
+}
+
+# -- platform::shell::platform
+
+proc ::platform::shell::platform {shell} {
+ # Argument is the path to a tcl shell.
+
+ CHECK $shell
+
+ set code {}
+ lappend code {puts $tcl_platform(platform)}
+ lappend code {exit 0}
+
+ return [RUN $shell [join $code \n]]
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper commands.
+
+proc ::platform::shell::CHECK {shell} {
+ if {![file exists $shell]} {
+ return -code error "Shell \"$shell\" does not exist"
+ }
+ if {![file executable $shell]} {
+ return -code error "Shell \"$shell\" is not executable (permissions)"
+ }
+ return
+}
+
+proc ::platform::shell::LOCATE {bv ov} {
+ upvar 1 $bv base $ov out
+
+ # Locate the platform package for injection into the specified
+ # shell. We are using package management to find it, whereever it
+ # is, instead of using hardwired relative paths. This allows us to
+ # install the two packages as TMs without breaking the code
+ # here. If the found package is wrapped we copy the code somewhere
+ # where the spawned shell will be able to read it.
+
+ # Note: This code depends on the form of the 'provide' command
+ # generated by tm.tcl. Keep them in sync. See Bug 2255235.
+ set pl [package ifneeded platform [package require platform]]
+ set base [lindex $pl end]
+
+ set out 0
+ if {[lindex [file system $base]] ne "native"} {
+ set temp [TEMP]
+ file copy -force $base $temp
+ set base $temp
+ set out 1
+ }
+ return
+}
+
+proc ::platform::shell::RUN {shell code} {
+ set c [TEMP]
+ set cc [open $c w]
+ puts $cc $code
+ close $cc
+
+ set e [TEMP]
+
+ set code [catch {
+ exec $shell $c 2> $e
+ } res]
+
+ file delete $c
+
+ if {$code} {
+ 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
+}
+
+proc ::platform::shell::TEMP {} {
+ set prefix platform
+
+ # This code is copied out of Tcllib's fileutil package.
+ # (TempFile/tempfile)
+
+ set tmpdir [DIR]
+
+ set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
+ set nrand_chars 10
+ set maxtries 10
+ set access [list RDWR CREAT EXCL TRUNC]
+ set permission 0600
+ set channel ""
+ set checked_dir_writable 0
+ set mypid [pid]
+ for {set i 0} {$i < $maxtries} {incr i} {
+ set newname $prefix
+ for {set j 0} {$j < $nrand_chars} {incr j} {
+ append newname [string index $chars \
+ [expr {int(rand()*62)}]]
+ }
+ set newname [file join $tmpdir $newname]
+ if {[file exists $newname]} {
+ after 1
+ } else {
+ if {[catch {open $newname $access $permission} channel]} {
+ if {!$checked_dir_writable} {
+ set dirname [file dirname $newname]
+ if {![file writable $dirname]} {
+ return -code error "Directory $dirname is not writable"
+ }
+ set checked_dir_writable 1
+ }
+ } else {
+ # Success
+ close $channel
+ return [file normalize $newname]
+ }
+ }
+ }
+ if {[string compare $channel ""]} {
+ return -code error "Failed to open a temporary file: $channel"
+ } else {
+ return -code error "Failed to find an unused temporary file name"
+ }
+}
+
+proc ::platform::shell::DIR {} {
+ # This code is copied out of Tcllib's fileutil package.
+ # (TempDir/tempdir)
+
+ global tcl_platform env
+
+ set attempdirs [list]
+
+ foreach tmp {TMPDIR TEMP TMP} {
+ if { [info exists env($tmp)] } {
+ lappend attempdirs $env($tmp)
+ }
+ }
+
+ switch $tcl_platform(platform) {
+ windows {
+ lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"
+ }
+ macintosh {
+ set tmpdir $env(TRASH_FOLDER) ;# a better place?
+ }
+ default {
+ lappend attempdirs \
+ [file join / tmp] \
+ [file join / var tmp] \
+ [file join / usr tmp]
+ }
+ }
+
+ lappend attempdirs [pwd]
+
+ foreach tmp $attempdirs {
+ if { [file isdirectory $tmp] && [file writable $tmp] } {
+ return [file normalize $tmp]
+ }
+ }
+
+ # Fail if nothing worked.
+ return -code error "Unable to determine a proper directory for temporary files"
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide platform::shell 1.1.4