1# The file tests the tcl_platform variable 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright (c) 1999 by Scriptics Corporation 8# 9# See the file "license.terms" for information on usage and redistribution 10# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11# 12# RCS: @(#) 13 14if {[lsearch [namespace children] ::tcltest] == -1} { 15 package require tcltest 16 namespace import -force ::tcltest::* 17} 18 19testConstraint testWinCPUID [llength [info commands testwincpuid]] 20 21test platform-1.1 {TclpSetVariables: tcl_platform} { 22 interp create i 23 i eval {catch {unset tcl_platform(debug)}} 24 i eval {catch {unset tcl_platform(threaded)}} 25 i eval {catch {unset tcl_platform(tip,268)}} 26 i eval {catch {unset tcl_platform(tip,280)}} 27 set result [i eval {lsort [array names tcl_platform]}] 28 interp delete i 29 set result 30} {byteOrder machine os osVersion platform user wordSize} 31 32# Test assumes twos-complement arithmetic, which is true of virtually 33# everything these days. Note that this does *not* use wide(), and 34# this is intentional since that could make Tcl's numbers wider than 35# the machine-integer on some platforms... 36test platform-2.1 {tcl_platform(wordSize) indicates size of native word} { 37 set result [expr {1 << (8 * $tcl_platform(wordSize) - 1)}] 38 # Result must be the largest bit in a machine word, which this checks 39 # without assuming how wide the word really is 40 list [expr {$result < 0}] [expr {$result ^ ($result - 1)}] 41} {1 -1} 42 43# On Windows, test that the CPU ID works 44 45test platform-3.1 {CPU ID on Windows } \ 46 -constraints testWinCPUID \ 47 -body { 48 set cpudata [testwincpuid 0] 49 binary format iii \ 50 [lindex $cpudata 1] \ 51 [lindex $cpudata 3] \ 52 [lindex $cpudata 2] 53 } \ 54 -match regexp \ 55 -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$} 56 57# cleanup 58::tcltest::cleanupTests 59return 60 61# Local Variables: 62# mode: tcl 63# End: 64