tcl-vtk 5.8.0-17.5 / usr / share / tcltk / tcl8.5 / vtk / TestSetGet.tcl

This file is indexed.

/usr/share/tcltk/tcl8.5/vtk/TestSetGet.tcl is in tcl-vtk 5.8.0-17.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

APT Browse - Built by Thomas Orozco.