Add files via upload

This commit is contained in:
MatMasIt 2021-06-17 01:30:50 +02:00 committed by GitHub
parent 01e0e57dbc
commit f1f1415eb2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 8716 additions and 0 deletions

View File

@ -0,0 +1,397 @@
# -*- 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
}

View File

@ -0,0 +1,241 @@
# -*- 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

1210
windowsAgent/dist/tcl8/8.5/msgcat-1.6.1.tm vendored Normal file

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

3427
windowsAgent/dist/tcl8/8.6/http-2.9.0.tm vendored Normal file

File diff suppressed because it is too large Load Diff