sid/config/unix.exp

   1 # unix.exp - Test driver for the SID component testsuite.  -*- Tcl -*-
   2
   3 # Copyright (C) 1999, 2000 Red Hat.
   4 # This file is part of SID and is licensed under the GPL.
   5 # See the file COPYING.SID for conditions for redistribution.
   6
   7 ############################################################################
   8 # Utility routines for sid test cases
   9
  10 proc sid_config_component_etc_test { file pfx type sfx } {
  11     global prefix
  12     set f [open $file "w"]
  13     puts $f "$pfx"
  14     puts $f "load [sid_find_file libtclapi.la] tcl_bridge_library"
  15     puts $f "new bridge-tcl tester"
  16     puts $f "new $type real-victim"
  17     puts $f "set tester load! [sid_find_file tester.tcl]"
  18     puts $f "set tester hexify? yes-please-and-thanks"
  19     puts $f "relate tester victim real-victim"
  20     puts $f "relate tester real-victim real-victim"
  21     puts $f "connect-pin main perform-activity -> tester command-io!"
  22     puts $f "connect-pin main perform-activity -> tester !event"
  23     puts $f "$sfx"
  24     verbose "Created sid configuration file $file without tracing"
  25     close $f
  26 }
  27
  28 proc sid_config_component_etc_test_with_tracing { file pfx type sfx } {
  29     global prefix
  30     set f [open $file "w"]
  31     puts $f "$pfx"
  32     puts $f "load [sid_find_file libtclapi.la] tcl_bridge_library"
  33     puts $f "new bridge-tcl tester"
  34     puts $f "new sid-api-trace wrapper"
  35     puts $f "new $type real-victim"
  36     puts $f "set tester load! [sid_find_file tester.tcl]"
  37     puts $f "set tester hexify? yes-please-and-thanks"
  38     puts $f "relate tester victim wrapper"
  39     puts $f "relate tester real-victim real-victim"
  40     puts $f "relate wrapper victim real-victim"
  41     puts $f "set wrapper victim-trace? 1"
  42     puts $f "connect-pin main perform-activity -> tester command-io!"
  43     puts $f "connect-pin main perform-activity -> tester !event"
  44     puts $f "connect-pin main perform-activity -> wrapper !event"
  45     puts $f "$sfx"
  46     verbose "Created sid configuration file $file with tracing"
  47     close $f
  48 }
  49
  50
  51 proc sid_config_component_test_with_tracing { file pfx type } {
  52     sid_config_component_etc_test_with_tracing $file $pfx $type ""
  53 }
  54
  55 proc sid_config_component_test { file pfx type } {
  56     sid_config_component_etc_test $file $pfx $type ""
  57 }
  58
  59
  60 # Start up a SID executable.  If TOOL_OPTIONS includes the substring
  61 # "static", then use a statically linked sid program, built using
  62 # mksidconf.  Otherwise use the plain main/dynamic "sid" frontend.
  63 # In this case, TOOL_OPTIONS also better include "install", since
  64 # mksid currently only works on the install tree.
  65
  66 proc sid_start {file} {
  67     global spawn_id
  68     global TOOL_OPTIONS
  69     global prefix
  70     global srcdir
  71     global victim
  72     global env
  73     verbose "starting sid" 2
  74
  75     if {[string match "*install*" $TOOL_OPTIONS]} then {
  76         # testing install tree
  77         # rely on compiled-in SID_EXEC_PREFIX to find parts
  78     } else {
  79         # testing build tree
  80         set env(SID_LIBRARY_PATH) [join [glob "../*" "$srcdir/../*"] ":"]
  81         # srcdir=/..../sid/component/testsuite
  82         set tcl_library "$srcdir/../../../tcl/library"
  83         global host_os
  84         switch -glob $host_os {
  85           {cygwin*} { set tcl_library [exec cygpath -w $tcl_library] }
  86         }
  87         set env(TCL_LIBRARY) $tcl_library
  88     }
  89
  90     if {[string match "*static*" $TOOL_OPTIONS]} then {
  91         set mksidconf [sid_find_file "mksidconf"]
  92         system $mksidconf -static $file
  93         regsub "(.*).conf" $file {./\1} sid
  94         regsub "(.*).conf" $file {\1.sconf} file
  95     } else {
  96         set sid [sid_find_file "sid" "sid.exe"]
  97     }
  98
  99     set pid [spawn $sid $file]
 100
 101     global timeout
 102     set last_timeout $timeout
 103     set timeout 30
 104     expect {
 105         timeout { perror "timeout while starting [list $sid $file]"; return 0}
 106         eof { perror "eof while starting [list $sid $file]"; return 0}
 107         -re "tester.ready" }
 108     set timeout $last_timeout
 109
 110     set victim [sid_cmd "set relationships(victim)"]
 111     verbose "victim component: $victim" 2
 112     return $pid
 113 }
 114
 115
 116 proc sid_stop {} {
 117     global spawn_id
 118     verbose "closing down sid" 2
 119     catch {close -slave}
 120     catch {exec "kill" [exp_pid]}
 121     wait
 122     return 1
 123 }
 124
 125
 126
 127 # generate a printworthy subset of argument
 128 proc prettyprint { cmd } {
 129     regsub -all {[^ -~]} $cmd {.} cmdpretty
 130     return [list $cmdpretty]
 131 }
 132
 133
 134 proc sid_cmd { cmd } {
 135     global spawn_id
 136     global expect_out
 137     global test
 138
 139     if [catch { exp_pid }] then {
 140         unresolved "$test - spawned sid process already gone"
 141         return
 142     }
 143
 144     # wait for prompt
 145     global timeout
 146     set last_timeout $timeout
 147     set timeout 3
 148     set ok 1
 149     expect {
 150         timeout { unresolved "$test - timeout before [prettyprint $cmd]"; set ok 0 }
 151         eof { unresolved "$test - eof before [prettyprint $cmd]"; set ok 0 }
 152         "command>"
 153     }
 154     set timeout $last_timeout
 155     if {! $ok} then { return "" }
 156
 157     # encode string
 158     binary scan $cmd H* encoded
 159
 160     set iterations [expr [string length $encoded] / 64]
 161     for {set i 0} {$i < $iterations} {incr i} {
 162         set first [expr $i * 64]
 163         set last [expr $first + 63]
 164         send "[string range $encoded $first $last]+\n"
 165     }
 166     set first [expr $i * 64]
 167     send "[string range $encoded $first end]\n"
 168
 169     expect {
 170         timeout { fail "$test - timeout after [prettyprint $cmd]" ; return "" }
 171         eof { fail "$test - eof after [prettyprint $cmd]"; return "" }
 172         -re "(ERROR:\[^\n\]*)" {
 173             fail "$test - [prettyprint $expect_out(1,string)] after [prettyprint $cmd]"
 174             return ""
 175         }
 176         -re "result>>(\[0-9a-f\]*)<<result" {
 177             set result $expect_out(1,string)
 178         }
 179         -re "split>>(\[0-9a-f\]*)<<split" {
 180             set result $expect_out(1,string)
 181             while {1} {
 182                 expect {
 183                     timeout { fail "$test - timeout3" ; return "" }
 184                     eof { fail "$test - eof3" ; return "" }
 185                     -re "split>>(\[0-9a-f\]*)<<split" {
 186                         append result $expect_out(1,string)
 187                     }
 188                     -re "split-end" { break }
 189                 }
 190             }
 191         }
 192     }
 193     # undo encoding in tester.tcl
 194     set decoded [binary format H* $result]
 195     verbose "result $decoded" 3
 196     return $decoded
 197 }
 198
 199
 200 # call a command; ignore result (but assert that it's not an ERROR.)
 201 proc sid_assert_success {cmd} {
 202     global test
 203     set result [sid_cmd $cmd]
 204     if [string match "*ERROR*" $result] then { fail $test } else { pass $test }
 205 }
 206
 207 # call a command; assert match on return value
 208 proc sid_assert_matches {cmd pattern} {
 209     global test
 210     set result [sid_cmd $cmd]
 211     if [string match $pattern $result] then { pass $test } else { fail $test }
 212 }
 213
 214 proc sid_assert_equals {cmd number} {
 215     global test
 216     set result [sid_cmd $cmd]
 217     if {$result == $number} then { pass $test } else { fail $test }
 218 }
 219
 220 # call a command; assert match on list result
 221 proc sid_assert_includes_all {cmd patterns} {
 222     global test
 223     set result [sid_cmd $cmd]
 224     foreach pat $patterns {
 225         if {[string first $pat $result] == -1} then {fail $test ; return }
 226     }
 227     pass $test
 228 }
 229
 230 # call a command; assert match on list result
 231 proc sid_assert_includes_none {cmd patterns} {
 232     global test
 233     set result [sid_cmd $cmd]
 234     foreach pat $patterns {
 235         if {[string first $pat $result] != -1} then {fail $test ; return }
 236     }
 237     pass $test
 238 }
 239
 240
 241 # Find a file somewhere in the build or install directory hierarchy.
 242 # Decide where to look based on TOOL_OPTIONS variable (the --tool_opts=VALUE
 243 # option from $RUNTESTFLAGS).  If that includes the substring "install", use
 244 # the install directory tree ($prefix etc.) to find the given file.  If the
 245 # variable is unset or set not to "install", use the build & source directories
 246 # instead.
 247 proc sid_find_file {args} {
 248     global TOOL_OPTIONS
 249     global prefix
 250     global srcdir
 251     if {[string match "*install*" $TOOL_OPTIONS]} then {
 252         set bases [list "$prefix"]
 253     } else {
 254         # try to get to the build and source directory
 255         set bases [list "../.." "$srcdir/../.."]
 256     }
 257     set files {}
 258     foreach base $bases {
 259         foreach file $args {
 260             verbose "looking for $file under $base" 2
 261             if {[llength $files] > 0} then { break }
 262             set files [concat $files [glob -nocomplain -- $base/$file $base/*/$file $base/*/*/$file $base/*/*/*/$file]]
 263         }
 264     }
 265     verbose -log "found $files" 2
 266     switch [llength $files] {
 267         0 { perror "No matches for $args under $bases" }
 268         1 { return $files }
 269         default { return [lindex $files 0] }
 270     }
 271 }
 272
 273
 274 # These routines don't really belong in unix.exp, but until there's
 275 # another file.
 276 # These were derived from find_gas,etc. in libgloss.exp.
 277 # There's no real heuristic that will work, so for now go with something
 278 # simple: use dejagnu's tool_root_dir.
 279
 280 proc sid_find_gas { toolchain_prefix } {
 281     global toolchain_root_dirs
 282     if { [info exists toolchain_root_dirs($toolchain_prefix)]
 283     && [file exists $toolchain_root_dirs($toolchain_prefix)/gas/as-new] } {
 284         return $toolchain_root_dirs($toolchain_prefix)/gas/as-new
 285     }
 286     return ${toolchain_prefix}-as
 287 }
 288
 289 proc sid_find_ld { toolchain_prefix } {
 290     global toolchain_root_dirs
 291     if { [info exists toolchain_root_dirs]
 292     && [file exists $toolchain_root_dirs($toolchain_prefix)/ld/ld-new] } {
 293         return $toolchain_root_dirs($toolchain_prefix)/ld/ld-new
 294     }
 295     return ${toolchain_prefix}-ld
 296 }
 297
 298
 299 proc sid_find_gcc { toolchain_prefix } {
 300     global toolchain_root_dirs
 301     if { [info exists toolchain_root_dirs]
 302     && [file exists $toolchain_root_dirs($toolchain_prefix)/gcc/xgcc] } {
 303         return "$toolchain_root_dirs($toolchain_prefix)/gcc/xgcc -B$toolchain_root_dirs($toolchain_prefix)/gcc/"
 304     }
 305     return ${toolchain_prefix}-gcc
 306 }
 307
 308 proc sid_find_sid {} {
 309     return [sid_find_file "sid" "sid.exe"]
 310 }
 311
 312
 313 proc sid_find_sid_bsp { toolchain_prefix } {
 314     # ignore toolchain_prefix.
 315     return [sid_find_file "configrun-sid"]
 316 }
 317
 318
 319 ############################################################################
 320 # Routines automatically called by runtest
 321
 322 # sidcomp_version -- print and return version number
 323 proc sidcomp_version {} {
 324     puts "version?"
 325     set version 0.1
 326     clone_output "sidcomp test $version\n"
 327 }
 328
 329 # sidcomp_exit -- quit and cleanup
 330 proc sidcomp_exit {} {
 331     # Do nothing.
 332 }
 333
 334 # sidcomp_start -- start the test bucket
 335 proc sidcomp_start {} {
 336     global TOOL_OPTIONS host_triplet crappy_tcl
 337     if {[info exists TOOL_OPTIONS]} then { } else { set TOOL_OPTIONS "build" }
 338     source "../../config/info.tcl"
 339
 340     # tcl on some platforms can't handle passing large strings between
 341     # the expect and the sid processes without corruption.  Set crappy_tcl
 342     # for these
 343     switch -glob $host_triplet {
 344         *-*-solaris* { set crappy_tcl 1 }
 345         default { set crappy_tcl 0 }
 346     }
 347 }
 348
 349
 350 ############################################################################
 351 # Do these things during test suite startup.
 352
 353 sidcomp_start