summaryrefslogtreecommitdiffstats
path: root/tcl8.6/library/platform
diff options
context:
space:
mode:
Diffstat (limited to 'tcl8.6/library/platform')
-rw-r--r--tcl8.6/library/platform/pkgIndex.tcl3
-rw-r--r--tcl8.6/library/platform/platform.tcl397
-rw-r--r--tcl8.6/library/platform/shell.tcl241
3 files changed, 0 insertions, 641 deletions
diff --git a/tcl8.6/library/platform/pkgIndex.tcl b/tcl8.6/library/platform/pkgIndex.tcl
deleted file mode 100644
index 5970a3f..0000000
--- a/tcl8.6/library/platform/pkgIndex.tcl
+++ /dev/null
@@ -1,3 +0,0 @@
-package ifneeded platform 1.0.14 [list source [file join $dir platform.tcl]]
-package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]]
-
diff --git a/tcl8.6/library/platform/platform.tcl b/tcl8.6/library/platform/platform.tcl
deleted file mode 100644
index 35a22a3..0000000
--- a/tcl8.6/library/platform/platform.tcl
+++ /dev/null
@@ -1,397 +0,0 @@
-# -*- tcl -*-
-# ### ### ### ######### ######### #########
-## Overview
-
-# Heuristics to assemble a platform identifier from publicly available
-# information. The identifier describes the platform of the currently
-# running tcl shell. This is a mixture of the runtime environment and
-# of build-time properties of the executable itself.
-#
-# Examples:
-# <1> A tcl shell executing on a x86_64 processor, but having a
-# wordsize of 4 was compiled for the x86 environment, i.e. 32
-# bit, and loaded packages have to match that, and not the
-# actual cpu.
-#
-# <2> The hp/solaris 32/64 bit builds of the core cannot be
-# distinguished by looking at tcl_platform. As packages have to
-# match the 32/64 information we have to look in more places. In
-# this case we inspect the executable itself (magic numbers,
-# i.e. fileutil::magic::filetype).
-#
-# The basic information used comes out of the 'os' and 'machine'
-# entries of the 'tcl_platform' array. A number of general and
-# os/machine specific transformation are applied to get a canonical
-# result.
-#
-# General
-# Only the first element of 'os' is used - we don't care whether we
-# are on "Windows NT" or "Windows XP" or whatever.
-#
-# Machine specific
-# % arm* -> arm
-# % sun4* -> sparc
-# % intel -> ix86
-# % i*86* -> ix86
-# % Power* -> powerpc
-# % x86_64 + wordSize 4 => x86 code
-#
-# OS specific
-# % AIX are always powerpc machines
-# % HP-UX 9000/800 etc means parisc
-# % linux has to take glibc version into account
-# % sunos -> solaris, and keep version number
-#
-# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff
-# has to provide all possible allowed platform identifiers when
-# searching search. Ditto a solaris 2.8 platform can use solaris 2.6
-# packages. Etc. This is handled by the other procedure, see below.
-
-# ### ### ### ######### ######### #########
-## Requirements
-
-namespace eval ::platform {}
-
-# ### ### ### ######### ######### #########
-## Implementation
-
-# -- platform::generic
-#
-# Assembles an identifier for the generic platform. It leaves out
-# details like kernel version, libc version, etc.
-
-proc ::platform::generic {} {
- global tcl_platform
-
- set plat [string tolower [lindex $tcl_platform(os) 0]]
- set cpu $tcl_platform(machine)
-
- switch -glob -- $cpu {
- sun4* {
- set cpu sparc
- }
- intel -
- i*86* {
- set cpu ix86
- }
- x86_64 {
- if {$tcl_platform(wordSize) == 4} {
- # See Example <1> at the top of this file.
- set cpu ix86
- }
- }
- "Power*" {
- set cpu powerpc
- }
- "arm*" {
- set cpu arm
- }
- ia64 {
- if {$tcl_platform(wordSize) == 4} {
- append cpu _32
- }
- }
- }
-
- switch -glob -- $plat {
- cygwin* {
- set plat cygwin
- }
- windows {
- if {$tcl_platform(platform) == "unix"} {
- set plat cygwin
- } else {
- set plat win32
- }
- if {$cpu eq "amd64"} {
- # Do not check wordSize, win32-x64 is an IL32P64 platform.
- set cpu x86_64
- }
- }
- sunos {
- set plat solaris
- if {[string match "ix86" $cpu]} {
- if {$tcl_platform(wordSize) == 8} {
- set cpu x86_64
- }
- } elseif {![string match "ia64*" $cpu]} {
- # sparc
- if {$tcl_platform(wordSize) == 8} {
- append cpu 64
- }
- }
- }
- darwin {
- set plat macosx
- # Correctly identify the cpu when running as a 64bit
- # process on a machine with a 32bit kernel
- if {$cpu eq "ix86"} {
- if {$tcl_platform(wordSize) == 8} {
- set cpu x86_64
- }
- }
- }
- aix {
- set cpu powerpc
- if {$tcl_platform(wordSize) == 8} {
- append cpu 64
- }
- }
- hp-ux {
- set plat hpux
- if {![string match "ia64*" $cpu]} {
- set cpu parisc
- if {$tcl_platform(wordSize) == 8} {
- append cpu 64
- }
- }
- }
- osf1 {
- set plat tru64
- }
- }
-
- return "${plat}-${cpu}"
-}
-
-# -- platform::identify
-#
-# Assembles an identifier for the exact platform, by extending the
-# generic identifier. I.e. it adds in details like kernel version,
-# libc version, etc., if they are relevant for the loading of
-# packages on the platform.
-
-proc ::platform::identify {} {
- global tcl_platform
-
- set id [generic]
- regexp {^([^-]+)-([^-]+)$} $id -> plat cpu
-
- switch -- $plat {
- solaris {
- regsub {^5} $tcl_platform(osVersion) 2 text
- append plat $text
- return "${plat}-${cpu}"
- }
- macosx {
- set major [lindex [split $tcl_platform(osVersion) .] 0]
- if {$major > 8} {
- incr major -4
- append plat 10.$major
- return "${plat}-${cpu}"
- }
- }
- linux {
- # Look for the libc*.so and determine its version
- # (libc5/6, libc6 further glibc 2.X)
-
- set v unknown
-
- # Determine in which directory to look. /lib, or /lib64.
- # For that we use the tcl_platform(wordSize).
- #
- # We could use the 'cpu' info, per the equivalence below,
- # that however would be restricted to intel. And this may
- # be a arm, mips, etc. system. The wordsize is more
- # fundamental.
- #
- # ix86 <=> (wordSize == 4) <=> 32 bit ==> /lib
- # x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64
- #
- # Do not look into /lib64 even if present, if the cpu
- # doesn't fit.
-
- # TODO: Determine the prefixes (i386, x86_64, ...) for
- # other cpus. The path after the generic one is utterly
- # specific to intel right now. Ok, on Ubuntu, possibly
- # other Debian systems we may apparently be able to query
- # the necessary CPU code. If we can't we simply use the
- # hardwired fallback.
-
- switch -exact -- $tcl_platform(wordSize) {
- 4 {
- lappend bases /lib
- if {[catch {
- exec dpkg-architecture -qDEB_HOST_MULTIARCH
- } res]} {
- lappend bases /lib/i386-linux-gnu
- } else {
- # dpkg-arch returns the full tripled, not just cpu.
- lappend bases /lib/$res
- }
- }
- 8 {
- lappend bases /lib64
- if {[catch {
- exec dpkg-architecture -qDEB_HOST_MULTIARCH
- } res]} {
- lappend bases /lib/x86_64-linux-gnu
- } else {
- # dpkg-arch returns the full tripled, not just cpu.
- lappend bases /lib/$res
- }
- }
- default {
- return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8"
- }
- }
-
- foreach base $bases {
- if {[LibcVersion $base -> v]} break
- }
-
- append plat -$v
- return "${plat}-${cpu}"
- }
- }
-
- return $id
-}
-
-proc ::platform::LibcVersion {base _->_ vv} {
- upvar 1 $vv v
- set libclist [lsort [glob -nocomplain -directory $base libc*]]
-
- if {![llength $libclist]} { return 0 }
-
- set libc [lindex $libclist 0]
-
- # Try executing the library first. This should suceed
- # for a glibc library, and return the version
- # information.
-
- if {![catch {
- set vdata [lindex [split [exec $libc] \n] 0]
- }]} {
- regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v
- foreach {major minor} [split $v .] break
- set v glibc${major}.${minor}
- return 1
- } else {
- # We had trouble executing the library. We are now
- # inspecting its name to determine the version
- # number. This code by Larry McVoy.
-
- if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} {
- set v glibc${major}.${minor}
- return 1
- }
- }
- return 0
-}
-
-# -- platform::patterns
-#
-# Given an exact platform identifier, i.e. _not_ the generic
-# identifier it assembles a list of exact platform identifier
-# describing platform which should be compatible with the
-# input.
-#
-# I.e. packages for all platforms in the result list should be
-# loadable on the specified platform.
-
-# << Should we add the generic identifier to the list as well ? In
-# general it is not compatible I believe. So better not. In many
-# cases the exact identifier is identical to the generic one
-# anyway.
-# >>
-
-proc ::platform::patterns {id} {
- set res [list $id]
- if {$id eq "tcl"} {return $res}
-
- switch -glob -- $id {
- solaris*-* {
- if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} {
- if {$v eq ""} {return $id}
- foreach {major minor} [split $v .] break
- incr minor -1
- for {set j $minor} {$j >= 6} {incr j -1} {
- lappend res solaris${major}.${j}-${cpu}
- }
- }
- }
- linux*-* {
- if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} {
- foreach {major minor} [split $v .] break
- incr minor -1
- for {set j $minor} {$j >= 0} {incr j -1} {
- lappend res linux-glibc${major}.${j}-${cpu}
- }
- }
- }
- macosx-powerpc {
- lappend res macosx-universal
- }
- macosx-x86_64 {
- lappend res macosx-i386-x86_64
- }
- macosx-ix86 {
- lappend res macosx-universal macosx-i386-x86_64
- }
- macosx*-* {
- # 10.5+
- if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
-
- switch -exact -- $cpu {
- ix86 {
- lappend alt i386-x86_64
- lappend alt universal
- }
- x86_64 { lappend alt i386-x86_64 }
- default { set alt {} }
- }
-
- if {$v ne ""} {
- foreach {major minor} [split $v .] break
-
- # Add 10.5 to 10.minor to patterns.
- set res {}
- for {set j $minor} {$j >= 5} {incr j -1} {
- lappend res macosx${major}.${j}-${cpu}
- foreach a $alt {
- lappend res macosx${major}.${j}-$a
- }
- }
-
- # Add unversioned patterns for 10.3/10.4 builds.
- lappend res macosx-${cpu}
- foreach a $alt {
- lappend res macosx-$a
- }
- } else {
- # No version, just do unversioned patterns.
- foreach a $alt {
- lappend res macosx-$a
- }
- }
- } else {
- # no v, no cpu ... nothing
- }
- }
- }
- lappend res tcl ; # Pure tcl packages are always compatible.
- return $res
-}
-
-
-# ### ### ### ######### ######### #########
-## Ready
-
-package provide platform 1.0.14
-
-# ### ### ### ######### ######### #########
-## Demo application
-
-if {[info exists argv0] && ($argv0 eq [info script])} {
- puts ====================================
- parray tcl_platform
- puts ====================================
- puts Generic\ identification:\ [::platform::generic]
- puts Exact\ identification:\ \ \ [::platform::identify]
- puts ====================================
- puts Search\ patterns:
- puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ]
- puts ====================================
- exit 0
-}
diff --git a/tcl8.6/library/platform/shell.tcl b/tcl8.6/library/platform/shell.tcl
deleted file mode 100644
index 6eb9691..0000000
--- a/tcl8.6/library/platform/shell.tcl
+++ /dev/null
@@ -1,241 +0,0 @@
-
-# -*- 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.
-
- # 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]]
- 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 {$channel ne ""} {
- 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
generated by cgit v0.12 at 2024-08-31 13:09:59 (GMT)