/usr/share/tcltk/tcl8.5/vtk/TestSetGet.tcl is in tcl-vtk 5.8.0-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | for {set i 0} {$i < [expr $argc - 1]} {incr i} {
if {[lindex $argv $i] == "-A"} {
set auto_path "$auto_path [lindex $argv [expr $i +1]]"
}
}
package require vtk
vtkTimerLog timer
vtkObject a
a GlobalWarningDisplayOff
a Delete
set exceptions {
vtkLODProp3D-GetPickLODID
vtkObject-GetSuperClassName
vtkPropAssembly-GetBounds
vtkRenderWindow-GetEventPending
vtkSQLiteDatabase-GetQueryInstance
vtkMySQLDatabase-GetQueryInstance
vtkPostgreSQLDatabase-GetQueryInstance
vtkODBCDatabase-GetQueryInstance
vtkUniformVariables-GetCurrentName
vtkXOpenGLRenderWindow-GetEventPending
vtkXMesaRenderWindow-GetEventPending
vtkMPICommunicator-GetWorldCommunicator
vtkMPICommunicator-GetLocalProcessId
vtkMPICommunicator-GetNumberOfProcesses
vtkMPICommunicator-GetMPIComm
vtkOpenGLScalarsToColorsPainter-GetTextureSizeLimit
vtkScalarsToColorsPainter-GetTextureSizeLimit
vtkMesaScalarsToColorsPainter-GetTextureSizeLimit
}
proc TestOne {cname} {
global exceptions
$cname b
puts "Testing Class $cname"
set methods [b ListMethods]
# look for a Get Set pair
set len [llength $methods]
for {set i 0} {$i < $len} {incr i} {
if {[regsub {^Get([A-za-z0-9]*)} [lindex $methods $i] {\1} name]} {
if {($i == $len - 1) || ($i < $len - 1 && [lindex $methods [expr $i + 1]] != "with")} {
if {[lsearch $exceptions "$cname-[lindex $methods $i]"] == -1} {
# invoke the GetMethod
puts " Invoking Get$name"
set tmp [b Get$name]
# find matching set method
for {set j 0} {$j < $len} {incr j} {
if {[regexp "^Set$name" [lindex $methods $j]]} {
if {$j < $len - 3 && [lindex $methods [expr $j + 2]] == "1"} {
puts " Invoking Set$name"
catch {b Set$name $tmp}
}
if {$j < $len - 3 && [lindex $methods [expr $j + 2]] > 1} {
puts " Invoking Set$name"
catch {eval b Set$name $tmp}
}
}
}
}
}
}
}
puts "Testing DescribeMethods Class $cname"
# $object DescribeMethods with no arguments returns a list of methods for the object.
# $object DescribeMethods <MethodName> returns a list containing the following:
# MethodName {arglist} {description} {c++ signature} DefiningSuperclass
set Methods [b DescribeMethods]
# Find the Get methods
foreach GetMethod [lsearch -inline -all -glob $Methods Get*] {
# See how many arguments it requires, and only test get methods with 0 arguments
if { [llength [lindex [b DescribeMethods $GetMethod] 1]] > 0 } { continue }
# check the exceptions list
if {[lsearch $exceptions "$cname-$GetMethod"] != -1} { continue }
puts " Invoking $GetMethod"
set tmp [b $GetMethod]
set SetMethodSearch Set[string range $GetMethod 3 end]
foreach SetMethod [lsearch -inline -all $Methods $SetMethodSearch] {
puts " Invoking $SetMethod"
catch { eval b $SetMethod $tmp }
catch { b $SetMethod $tmp }
}
}
# Test the PrintRevisions method.
b PrintRevisions
b Delete
}
set classExceptions {
vtkCommand
vtkFileOutputWindow
vtkIndent
vtkOutputWindow
vtkParallelFactory
vtkPlanes
vtkProjectedPolyDataRayBounder
vtkRayCaster
vtkTimeStamp
vtkTkImageViewerWidget
vtkTkImageWindowWidget
vtkTkRenderWidget
vtkImageDataToTkPhoto
vtkViewRays
vtkWin32OutputWindow
vtkWin32ProcessOutputWindow
vtkXMLFileOutputWindow
}
proc rtSetGetTest { fileid } {
global classExceptions
set totalTime 0.0
# for every class
set all [lsort [info command vtk*]]
foreach a $all {
if {[lsearch $classExceptions $a] == -1} {
# test some set get methods
timer StartTimer
TestOne $a
timer StopTimer
set elapsedTime [timer GetElapsedTime]
set totalTime [expr $totalTime + $elapsedTime]
if { $elapsedTime > 1.0 } {
puts "Elapsed Time: $elapsedTime and took longer than 1 second."
} else {
puts "Elapsed Time: $elapsedTime"
}
puts "Total Elapsed Time: $totalTime"
}
}
}
# All tests should end with the following...
puts "CTEST_FULL_OUTPUT (Avoid ctest truncation of output)"
rtSetGetTest stdout
timer Delete
exit
|