# The file tests the tcl_platform variable and platform package.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2.5
source [file join [file dirname [info script]] tcltests.tcl]
namespace eval ::tcl::test::platform {
namespace import ::tcltest::testConstraint
namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
# This is not how [variable] works. See TIP 276.
#variable ::tcl_platform
namespace upvar :: tcl_platform tcl_platform
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.0 {tcl_platform(engine)} {
set tcl_platform(engine)
} {Tcl}
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize}
# Test assumes twos-complement arithmetic, which is true of virtually
# everything these days. Note that this does *not* use wide(), and
# this is intentional since that could make Tcl's numbers wider than
# the machine-integer on some platforms...
test platform-2.1 {tcl_platform(wordSize) indicates size of native word} {
set result [expr {int(1 << (8 * $tcl_platform(wordSize) - 1))}]
# Result must be the largest bit in a machine word, which this checks
# without assuming how wide the word really is
list [expr {$result < 0}] [expr {$result ^ int($result - 1)}]
} {1 -1}
# On Windows/UNIX, test that the CPU ID works
test platform-3.1 {CPU ID on Windows/UNIX} \
-constraints testCPUID \
-body {
set cpudata [testcpuid 0]
binary format iii \
[lindex $cpudata 1] \
[lindex $cpudata 3] \
[lindex $cpudata 2]
} \
-match regexp \
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
# The platform package makes very few promises, but does promise that the
# format of string it produces consists of two non-empty words separated by a
# hyphen.
package require platform
test platform-4.1 {format of platform::identify result} -constraints notValgrind -match regexp -body {
# [identify] may attempt to [exec] dpkg-architecture, which may not exist,
# in which case fork will not be followed by exec, and valgrind will issue
# "still reachable" reports.
platform::identify
} -result {^([^-]+-)+[^-]+$}
test platform-4.2 {format of platform::generic result} -match regexp -body {
platform::generic
} -result {^([^-]+-)+[^-]+$}
test platform-5.0 {format of platform::generic result} -setup {
set old_machine $::tcl_platform(machine)
set old_os $::tcl_platform(os)
set old_wordsize $::tcl_platform(wordSize)
set old_version $tcl_platform(osVersion)
set ::tcl_platform(machine) arm
set ::tcl_platform(os) Darwin
set ::tcl_platform(wordSize) 8
} -body {
set res {}
set l {macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 macosx10.8-x86_64 macosx10.7-x86_64 macosx10.6-x86_64 macosx10.5-x86_64 macosx-arm macosx-x86_64 tcl}
foreach v {20.0 21.0 22.0 23.0 24.0 25.0 26.0} {
set ::tcl_platform(osVersion) $v
set id [platform::identify]
set l [linsert $l 0 [string range $id 0 end-4]-x86_64]
set l [linsert $l 0 $id]
lappend res $id
lappend res [expr {($l eq [platform::patterns $id]) ? 1 : [platform::patterns $id]}]
}
set res
} -cleanup {
set ::tcl_platform(machine) $old_machine
set ::tcl_platform(os) $old_os
set ::tcl_platform(wordSize) $old_wordsize
set ::tcl_platform(osVersion) $old_version
unset res l old_machine old_os old_wordsize old_version
} -result {macos11-arm 1 macos12-arm 1 macos13-arm 1 macos14-arm 1 macos15-arm 1 macos26-arm 1 macos27-arm 1}
test platform-5.1 {format of platform::patterns macos26-x86_64} -body {
platform::patterns macos26-x86_64
} -result {macos26-x86_64 macos15-x86_64 macos14-x86_64 macos13-x86_64 macos12-x86_64 macos11-x86_64 macosx10.15-x86_64 macosx10.14-x86_64 macosx10.14-i386-x86_64 macosx10.13-x86_64 macosx10.13-i386-x86_64 macosx10.12-x86_64 macosx10.12-i386-x86_64 macosx10.11-x86_64 macosx10.11-i386-x86_64 macosx10.10-x86_64 macosx10.10-i386-x86_64 macosx10.9-x86_64 macosx10.9-i386-x86_64 macosx10.8-x86_64 macosx10.8-i386-x86_64 macosx10.7-x86_64 macosx10.7-i386-x86_64 macosx10.6-x86_64 macosx10.6-i386-x86_64 macosx10.5-x86_64 macosx10.5-i386-x86_64 macosx-x86_64 macosx-i386-x86_64 tcl}
test platform-5.2 {format of platform::patterns macos26-arm} -body {
platform::patterns macos26-arm
} -result {macos26-arm macos26-x86_64 macos15-arm macos15-x86_64 macos14-arm macos14-x86_64 macos13-arm macos13-x86_64 macos12-arm macos12-x86_64 macos11-arm macos11-x86_64 macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 macosx10.8-x86_64 macosx10.7-x86_64 macosx10.6-x86_64 macosx10.5-x86_64 macosx-arm macosx-x86_64 tcl}
# cleanup
cleanupTests
}
namespace delete ::tcl::test::platform
return
# Local Variables:
# mode: tcl
# End: