tools/src/infra/hosttest.exp

   1 #===============================================================================
   2 #
   3 #    hosttest.exp
   4 #
   5 #    Support for host-side testing
   6 #
   7 #===============================================================================
   8 ######COPYRIGHTBEGIN####
   9 #
  10 # ----------------------------------------------------------------------------
  11 # Copyright (C) 1998, 1999, 2000, 2001 Red Hat, Inc.
  12 #
  13 # This file is part of the eCos host tools.
  14 #
  15 # This program is free software; you can redistribute it and/or modify it
  16 # under the terms of the GNU General Public License as published by the Free
  17 # Software Foundation; either version 2 of the License, or (at your option)
  18 # any later version.
  19 #
  20 # This program is distributed in the hope that it will be useful, but WITHOUT
  21 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  22 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
  23 # more details.
  24 #
  25 # You should have received a copy of the GNU General Public License along with
  26 # this program; if not, write to the Free Software Foundation, Inc.,
  27 # 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
  28 #
  29 # ----------------------------------------------------------------------------
  30 #
  31 ######COPYRIGHTEND####
  32 #===============================================================================
  33 ######DESCRIPTIONBEGIN####
  34 #
  35 # Author(s):    bartv
  36 # Contributors: bartv
  37 # Date:         1998-11-25
  38 # Note:         Arguably this should be a loadable package
  39 #
  40 #####DESCRIPTIONEND####
  41 #===============================================================================
  42 #
  43
  44 # ----------------------------------------------------------------------------
  45 # This script gets loaded by host-side DejaGnu test harnesses to provide
  46 # various utilities for testing eCos host applications. It lives in the
  47 # host-side infrastructure directory and gets installed in
  48 # $(PREFIX)/share/dejagnu.
  49 #
  50 # The script can assume that a number of globals from the site.exp
  51 # file have been read in. These include:
  52 #     tool           - name of the tool (i.e. the package)
  53 #     srcdir         - location of the source directory
  54 #     objdir         - location of the build tree
  55 #     host_alias     - config triplet
  56 #     host_triplet   - ditto
  57 #
  58 # The generated Makefile has some additional information that is useful.
  59 #     CC             - name of the C compiler that is used
  60 #     CXX            - name of the C++ compiler
  61 #     prefix         - where everything gets installed
  62 #     OBJEXT         - either o or obj
  63 #     EXEEXT         - either nothing or .exe
  64 #     VERSION        - the version number
  65 #     CFLAGS         - flags to use when compiling C code
  66 #     CXXFLAGS       - flags to use when compiling C++ code
  67 #
  68 # Some additional variables should be present in any generated
  69 # makefiles in the eCos tree.
  70 #     INCLUDES       - header file search path
  71 #     LIBS           - libraries, search paths, ...
  72 #
  73 # hosttest_initialize
  74 #     Perform any initialization steps that are needed. Currently this
  75 #     means reading in the Makefile from the top-level of the build tree
  76 #     and figuring out the values of CC, CXX, and anything else that is
  77 #     useful. Any errors should be reported via perror and then the
  78 #     script should exit.
  79 #
  80 #     There is an optional argument, a list of additional variables which
  81 #     should be present in the makefile and whose values are desired.
  82
  83 proc hosttest_initialize { { pkg_vars {} } } {
  84
  85     # First check that this script is actually running inside DejaGnu
  86     if { [info exists ::objdir] == 0 } {
  87         puts "Variable ::objdir is not defined, is this script really running inside DejaGnu?"
  88         exit 1
  89     }
  90
  91     # The information is stored in an array hosttest_data. Make sure this
  92     # array exists.
  93     array set ::hosttest_data {}
  94
  95     # Now clear out any entries in the array
  96     foreach entry [array names ::hosttest_data] {
  97         unset ::hosttest_data($entry)
  98     }
  99
 100     # Now read in the build tree's Makefile (and not the testsuite's Makefile)
 101     set filename [file join $::objdir .. Makefile]
 102     if { [file exists $filename] == 0 } {
 103         perror "Initialization error: the build tree's Makefile $filename does not exist."
 104         exit 1
 105     }
 106     set status [ catch {
 107         set fd [open $filename r]
 108         set contents [read $fd]
 109         close $fd
 110     } message]
 111     if { $status != 0 } {
 112         perror "Error reading $filename.\n$message"
 113         exit 1
 114     }
 115
 116     # The data is available. Search it for each of the variables of
 117     # interest. Some variables are optional and are given default
 118     # values.
 119     set ::hosttest_data(CFLAGS) ""
 120     set ::hosttest_data(CXXFLAGS) ""
 121
 122     set lines [split $contents "\n"]
 123
 124     foreach var [concat { CC CXX prefix OBJEXT EXEEXT VERSION CFLAGS CXXFLAGS INCLUDES LIBS } $pkg_vars] {
 125
 126         set pattern "^$var\[ \t\]*:?=\[ \t\]* (.*)\$"
 127         set dummy ""
 128         set match ""
 129
 130         foreach line $lines {
 131             if { [regexp -- $pattern $line dummy match] == 1 } {
 132                 set ::hosttest_data($var) $match
 133                 break
 134             }
 135         }
 136         if { [info exists ::hosttest_data($var)] == 0 } {
 137             perror "Variable $var is not defined in $filename"
 138             exit 1
 139         }
 140     }
 141
 142     # If compiling with VC++ remove any cygwin-isms from the prefix
 143     if { [string match "cl*" $::hosttest_data(CC)] } {
 144         set status [catch "exec cygpath -w $::hosttest_data(prefix)" message]
 145         if { $status == 0 } {
 146             regsub -all -- {\\} $message {/} ::hosttest_data(prefix)
 147         } else {
 148             perror "Converting cygwin pathname $::hosttest_data(prefix)\n$message"
 149             exit 1
 150         }
 151     }
 152 }
 153
 154
 155 # ----------------------------------------------------------------------------
 156 # hosttest_extract_version
 157 #     Assuming there has been a call to initialize, the required information
 158 #     should be available in the hosttest_data array. The initialize
 159 #     function should have aborted if the data is not available.
 160
 161 proc hosttest_extract_version { } {
 162
 163     if { [info exists ::hosttest_data(VERSION)] == 0 } {
 164         error "No version information - host testing has not been properly initialized."
 165     }
 166
 167     if { [info exists ::objdir] == 0 } {
 168         error "Variable ::objdir is not defined, is this script really running inside DejaGnu?"
 169     }
 170     return $::hosttest_data(VERSION)
 171 }
 172
 173 # ----------------------------------------------------------------------------
 174 # hosttest_compile
 175 #    compile and link one or more source files. The arguments are:
 176 #    1) the name of the test case
 177 #    2) a list of one or more source files that need to be compiled.
 178 #       Both .c and .cxx files are supported, and the appropriate
 179 #       compiler will be used. If this list is empty then the
 180 #       code will look for a .c or a .cxx file which matches the
 181 #       name of the test executable. Source files are assumed to
 182 #       be relative to $::srcdir/$::subdir
 183 #    3) a list (possibly empty) of directories that should be in the
 184 #       include path. The build tree's directory is automatically in
 185 #       the path, as is $(PREFIX)/include. Note that the build tree
 186 #       is actually one level above objdir, on the assumption that
 187 #       objdir is the testsuite subdirectory of the real objdir.
 188 #    4) ditto for library search paths.
 189 #    5) and a list of additional libraries that should be linked.
 190 #
 191 # Currently it is not possible to pass compiler flags since those
 192 # might need translating between gcc and VC++. This may have to be
 193 # resolved.
 194 #
 195 # Currently linking is not done via libtool. This may have to change.
 196 #
 197 # The various object files and the executable are placed in a directory
 198 # testcase in the build tree, to avoid the risk of name clashes. This
 199 # directory must not exist yet. There is a separate routine hosttest_clean
 200 # which simply expunges the entire testcase directory.
 201 #
 202 # The output of a succesful compile or built is reported using
 203 # verbose at level 2. Unsuccesful compiles or builts are reported using
 204 # level 1.
 205
 206 proc hosttest_compile { name sources includes libdirs libs } {
 207
 208     # Make sure that the testcase directory does not yet exist, then
 209     # create it. This guarantees a clean system and reasonable access
 210     # permissions. Each testcase invocation should involve a call to
 211     # the clean function.
 212     set dirname [file join $::objdir "testcase"]
 213     if { [file exists $dirname] != 0 } {
 214         # An empty directory is ok.
 215         if { [llength [glob -nocomplain -- [file join $dirname "*"]]] != 0 } {
 216             error "hosttest_compile: $dirname already exists"
 217         }
 218     }
 219
 220     set status [catch { file mkdir $dirname } message]
 221     if { $status != 0 } {
 222         error "hosttest_compile: unable to create directory $dirname"
 223     }
 224
 225     # The only argument that must be valid is the test name.
 226     if { $name == "" } {
 227         error "hosttest_compile: invalid test case name"
 228     }
 229
 230     # If the list of sources is empty then look for a suitable
 231     # file in the appropriate directory.
 232     if { [llength $sources] == 0 } {
 233         set filename [file join $::srcdir $::subdir "${name}.c"]
 234         if { [file exists $filename] && [file isfile $filename] } {
 235             lappend sources [file tail $filename]
 236         } else {
 237             set filename [file join $::srcdir $::subdir "${name}.cxx"]
 238             if { [file exists $filename] && [file isfile $filename] } {
 239                 lappend sources [file tail $filename]
 240             } else {
 241                 error "hosttest_compile: no sources listed and unable to find ${name}.c or ${name}.cxx"
 242             }
 243         }
 244     }
 245
 246     # For each source file, generate a compile command line and try to execute
 247     # it. The command line takes the form:
 248     #  (CC|CXX) -c (CFLAGS|CXXFLAGS) (INCDIRS) -o xxx yyy
 249     #
 250     # It is also useful to produce a list of the object files that need to
 251     # linked later on, and to work out which tool should be invoked for
 252     # linking.
 253     set object_files {}
 254     set has_cxx_files 0
 255
 256     foreach source $sources {
 257         set commandline ""
 258         if { [file extension $source] == ".c" } {
 259             append commandline "$::hosttest_data(CC) -c $::hosttest_data(CFLAGS) "
 260         } elseif { [file extension $source] == ".cxx" } {
 261             set has_cxx_files 1
 262             append commandline "$::hosttest_data(CXX) -c $::hosttest_data(CXXFLAGS) "
 263         } else {
 264             error "hosttest_compile: files of type [file extension $source] ($source) are not yet supported."
 265         }
 266
 267         # Include path: start with the source tree. Then the build tree.
 268         # Then the makefile's INCLUDES variable.
 269         # Then any additional directories specified explicitly by the
 270         # testcase. Finish off with the prefix. Note that header files
 271         # in the prefix directory may be out of date, depending on whether
 272         # or not there has been an install recently.
 273         append commandline "-I[file join [pwd] [file dirname $::srcdir]] "
 274         append commandline "-I[file join [pwd] [file dirname $::objdir]] "
 275         append commandline "$::hosttest_data(INCLUDES) "
 276         foreach dir $includes {
 277             append commandline "-I[file join [pwd] $dir] "
 278         }
 279         append commandline "-I[file join [pwd] $::hosttest_data(prefix) include] "
 280
 281         # The output file must go into the testcase directory and have the right suffix
 282         set objfile "[file root [file tail $source]].$::hosttest_data(OBJEXT)"
 283         lappend object_files $objfile
 284         if { [string match "cl*" $::hosttest_data(CC)] } {
 285             append commandline "-Fo[file join $::objdir testcase $objfile] "
 286         } else {
 287             append commandline "-o [file join $::objdir testcase $objfile] "
 288         }
 289
 290         # Finally provide the source file.
 291         append commandline "[file join $::srcdir $::subdir $source]"
 292         verbose -log -- $commandline
 293
 294         # Time to invoke the compiler.
 295         set status [catch { set result [eval exec -keepnewline -- $commandline] } message]
 296         if { $status == 0 } {
 297             # The compile succeeded and the output is in result. Report the
 298             # output.
 299             verbose -log -- $result
 300         } else {
 301             # The compile failed and the output is in message.
 302             verbose -log -- $message
 303             error "hosttest_compile: failed to compile $source"
 304         }
 305     }
 306
 307     # At this stage all the source files have been compiled, a list of
 308     # object files has been constructed, and it is known whether or
 309     # not any of the sources were c++. Time to construct a new command
 310     # line.
 311     set commandline ""
 312     if { $has_cxx_files == 0 } {
 313         append commandline "$::hosttest_data(CC) $::hosttest_data(CFLAGS) "
 314     } else {
 315         append commandline "$::hosttest_data(CXX) $::hosttest_data(CXXFLAGS) "
 316     }
 317     set exename [file join $::objdir "testcase" "$name$::hosttest_data(EXEEXT)"]
 318
 319     # List all of the object files
 320     foreach obj $object_files {
 321         append commandline "[file join $::objdir "testcase" $obj] "
 322     }
 323
 324     # Now take care of libraries and search paths. This requires different
 325     # code for gcc and VC++.
 326
 327     if { [string match "cl*" $::hosttest_data(CC)] } {
 328         append commandline "-Fe$exename "
 329
 330         foreach lib $libs {
 331             append commandline "${lib}.lib "
 332         }
 333         append commandline "$::hosttest_data(LIBS) "
 334         append commandline "-libpath=[file join [pwd] [file dirname $::objdir]] "
 335         foreach dir $libdirs {
 336             append commandline "-libpath=[file join [pwd] $dir] "
 337         }
 338         append commandline "-libpath=[file join [pwd] $::hosttest_data(prefix) lib] "
 339     } else {
 340         append commandline "-o $exename "
 341         append commandline "-L[file join [pwd] [file dirname $::objdir]] "
 342         foreach dir $libdirs {
 343             append commandline "-L[file join [pwd] $dir] "
 344         }
 345         append commandline "-L[file join [pwd] $::hosttest_data(prefix) lib] "
 346         foreach lib $libs {
 347             append commandline "-l$lib "
 348         }
 349         append commandline "$::hosttest_data(LIBS) "
 350     }
 351
 352     # We have a command line, go for it.
 353     verbose -log -- $commandline
 354     set status [catch { set result [eval exec -keepnewline -- $commandline] } message]
 355     if { $status == 0 } {
 356         # The link has succeeded, we have an executable.
 357         verbose -log -- $result
 358     } else {
 359         # The link failed and the output is in message.
 360         # Report things are per compilation failures
 361         verbose -log -- $message
 362         error "hosttest_compile: failed to link $exename"
 363     }
 364
 365     # There should be a test executable.
 366 }
 367
 368 # ----------------------------------------------------------------------------
 369 # hosttest_clean
 370 #    Clean up a testcase directory.
 371
 372 proc hosttest_clean { } {
 373
 374     set dirname [file join $::objdir "testcase"]
 375     if { [file exists $dirname] == 0 } {
 376
 377         # Something must have gone seriously wrong during the build phase,
 378         # there is nothing there.
 379         return
 380     }
 381
 382     if { [file isdirectory $dirname] == 0 } {
 383         error "hosttest_clean: $dirname should be a directory"
 384     }
 385
 386     foreach entry [glob -nocomplain -- [file join $dirname "*"]] {
 387         set filename [file join $dirname $entry]
 388         if { [file isfile $filename] == 0 } {
 389             error "hosttest_clean: $filename is not a file"
 390         }
 391         set status [catch { file delete -force -- $filename } message]
 392         if { $status != 0 } {
 393             error "hosttest_clean: unable to delete $filename, $message"
 394         }
 395     }
 396     set status [catch { file delete -force -- $dirname } message]
 397     if { $status != 0 } {
 398         error "hosttest_clean: unable to delete directory $dirname, $message"
 399     }
 400 }
 401
 402 # ----------------------------------------------------------------------------
 403 # Run a test executable, returning the status code and the output.
 404 # The results are returned in variables. It is assumed that some test cases
 405 # will fail, so raising an exception is appropriate only if something
 406 # has gone wrong at the test harness level. The argument list
 407 # should be the name of the test case (from which the executable file name
 408 # can be derived) and a list of arguments.
 409
 410 proc hosttest_run { result_arg output_arg test args } {
 411
 412     upvar $result_arg result
 413     upvar $output_arg output
 414
 415     # Figure out the filename corresponding to the test and make
 416     # sure it exists.
 417     set filename [file join $::objdir "testcase" $test]
 418     append filename $::hosttest_data(EXEEXT)
 419     if { ([file exists $filename] == 0) || ([file isfile $filename] == 0) } {
 420         error "hosttest_run: testcase file $filename does not exist"
 421     }
 422
 423     # There is no need to worry about interacting with the program,
 424     # just exec it. It is a good idea to do this in the testcase directory,
 425     # so that any core dumps get cleaned up as well.
 426     set current_dir [pwd]
 427     set status [ catch { cd [file join $::objdir "testcase"] } message ]
 428     if { $status != 0 } {
 429         error "unable to change directory to [file join $::objdir testcase]\n$message"
 430     }
 431
 432     verbose -log -- $filename $args
 433     set status [ catch { set result [eval exec -keepnewline -- $filename $args] } output]
 434     if { $status == 0 } {
 435         # The command has succeeded. The exit code is 0 and the output
 436         # was returned by the exec.
 437         set output $result
 438         set result 0
 439     } else {
 440         # The command has failed. The exit code is 1 and the output is
 441         # already in the right place.
 442         verbose -log -- $output
 443         set result 1
 444     }
 445     set status [catch { cd $current_dir } message]
 446     if { $status != 0 } {
 447         error "unable to change directory back to $current_dir"
 448     }
 449 }
 450
 451 # ----------------------------------------------------------------------------
 452 # Given some test output, look through it for pass and fail messages.
 453 # These should result in appropriate DejaGnu pass and fail calls.
 454 # In addition, if the program exited with a non-zero status code but
 455 # did not report any failures then a special failure is reported.
 456
 457 proc hosttest_handle_output { name result output } {
 458
 459     set passes 0
 460     set fails  0
 461
 462     foreach line [split $output "\n"] {
 463
 464         # The output should be of one of the following forms:
 465         #    PASS:<message>
 466         #    FAIL:<message> Line: xx File: xx
 467         #    Whatever
 468         #
 469         # PASS and FAIL messages will be reported via DejaGnu pass and fail
 470         # calls. Everything else gets passed to verbose, so the user gets
 471         # to choose how much information gets reported.
 472
 473         set dummy   ""
 474         set match1  ""
 475         set match2  ""
 476
 477         if { [regexp -- {^PASS:<(.*)>.*$} $line dummy match1] == 1 } {
 478             pass $match1
 479             incr passes
 480         } elseif { [regexp -- {^FAIL:<(.*)>(.*)$} $line dummy match1 match2] == 1 } {
 481             fail "$match1 $match2"
 482             incr fails
 483         } else {
 484             verbose $line
 485         }
 486     }
 487
 488     if { ($result != 0) && ($fails == 0) } {
 489         fail "program terminated with non-zero exit code but did not report any failures"
 490     } elseif { ($passes == 0) && ($fails == 0) } {
 491         unresolved "test case $name did not report any passes or failures"
 492     }
 493 }
 494
 495 # ----------------------------------------------------------------------------
 496 # hosttest_run_test_with_filter
 497 #    This routines combines the compile, run and clean operations,
 498 #    plus it invokes a supplied callback to filter the output. The
 499 #    callback is passed three arguments: the test name, the exit code,
 500 #    and all of the program output.
 501
 502 proc hosttest_run_test_with_filter { name filter sources incdirs libdirs libs args } {
 503
 504     set result 0
 505     set output ""
 506
 507     set status [ catch { hosttest_compile $name $sources $incdirs $libdirs $libs } message]
 508     if { $status != 0 } {
 509         fail "unable to compile test case $name, $message"
 510         hosttest_clean
 511         return
 512     }
 513     set status [ catch { hosttest_run result output $name $args } message]
 514     if { $status != 0 } {
 515         fail "unable to run test case $name, $message"
 516         hosttest_clean
 517         return
 518     }
 519     set status [ catch { $filter $name $result $output } message]
 520     if { $status != 0 } {
 521         fail "unable to parse output from test case $name"
 522         hosttest_clean
 523         return
 524     }
 525
 526     hosttest_clean
 527 }
 528
 529 # ----------------------------------------------------------------------------
 530 # hosttest_run_simple_test
 531 #    This routine combines the compile, run, output, and clean operations.
 532 #    The arguments are the same as for compilation, plus an additional
 533 #    list for run-time parameters to the test case.
 534
 535 proc hosttest_run_simple_test { name sources incdirs libdirs libs args } {
 536
 537
 538     set result 0
 539     set output ""
 540
 541     set status [ catch { hosttest_compile $name $sources $incdirs $libdirs $libs } message]
 542     if { $status != 0 } {
 543         fail "unable to compile test case $name, $message"
 544         hosttest_clean
 545         return
 546     }
 547     set status [ catch { hosttest_run result output $name $args } message]
 548     if { $status != 0 } {
 549         fail "unable to run test case $name, $message"
 550         hosttest_clean
 551         return
 552     }
 553     set status [ catch { hosttest_handle_output $name $result $output } message]
 554     if { $status != 0 } {
 555         fail "unable to parse output from test case $name"
 556         hosttest_clean
 557         return
 558     }
 559
 560     hosttest_clean
 561 }
 562
 563 # ----------------------------------------------------------------------------
 564 # Filename translation. A particular file has been created and must now
 565 # be accessed from Tcl.
 566 #
 567 # Under Unix everything just works.
 568 #
 569 # Under Windows, well there is cygwin and there is the Windows world.
 570 # A file may have come from either. cygtclsh80 and hence DejaGnu is not
 571 # fully integrated with cygwin, for example it does not know about
 572 # cygwin mount points. There are also complications because of
 573 # volume-relative filenames.
 574 #
 575 # The code here tries a number of different ways of finding a file which
 576 # matches the name. It is possible that the result is not actually what
 577 # was intended, but hopefully this case will never arise.
 578
 579 proc hosttest_translate_existing_filename { name } {
 580
 581     if { $::tcl_platform(platform) == "unix" } {
 582         # The file should exist. It is worth checking just in case.
 583         if { [file exists $name] == 0 } {
 584             return ""
 585         } else {
 586             return $name
 587         }
 588     }
 589
 590     if { $::tcl_platform(platform) != "windows" } {
 591         perror "The testing framework does not know about platform $::tcl_platform(platform)"
 592         return ""
 593     }
 594
 595     # Always get rid of any backslashes, they just cause trouble
 596     regsub -all -- {\\} $name {/} name
 597
 598     # If the name is already valid, great.
 599     if { [file exists $name] } {
 600         return $name
 601     }
 602
 603     # OK, try to use cygwin's cygpath utility to convert it.
 604     set status [catch "exec cygpath -w $name" message]
 605     if { $status == 0 } {
 606         set cygwin_name ""
 607         regsub -all -- {\\} $message {/} cygwin_name
 608         if { [file exists $cygwin_name] } {
 609             return $cygwin_name
 610         }
 611     }
 612
 613     # Is the name volumerelative? If so work out the current volume
 614     # from the current directory and prepend this.
 615     if { [file pathtype $name] == "volumerelative" } {
 616         append fullname [string range [pwd] 0 1] $name
 617         if { [file exists $fullname] } {
 618             return $fullname
 619         }
 620     }
 621
 622     # There are other possibilities, e.g. d:xxx indicating a file
 623     # relative to the current directory on drive d:. For now such
 624     # Lovecraftian abominations are ignored.
 625     return ""
 626 }
 627
 628 # ----------------------------------------------------------------------------
 629 # Support for assertion dumps. The infrastructure allows other subsystems
 630 # to add their own callbacks which get invoked during a panic and which
 631 # can write additional output to the dump file. For example it would be
 632 # possible to output full details of the current configuration. These
 633 # routines make it easier to write test cases for such callbacks.
 634 #
 635 # hosttest_assert_check(result output)
 636 #     Make sure that the test case really triggered an assertion.
 637 #
 638 # hosttest_assert_read_dump(output)
 639 #     Identify the temporary file used for the dump, read it in, delete
 640 #     it (no point in leaving such temporaries lying around when running
 641 #     testcases) and return the contents of the file.
 642 #
 643 # hosttest_assert_extract_callback(dump title)
 644 #     Given a dump output as returned by read_dump, look for a section
 645 #     generated by a callback with the given title. Return the contents
 646 #     of the callback.
 647
 648 proc hosttest_assert_check { result output } {
 649
 650     if { $result == 0 } {
 651         return 0
 652     }
 653
 654     foreach line [split $output "\n"] {
 655         if { [string match "Assertion failure*" $line] } {
 656             return 1
 657         }
 658     }
 659     return 0
 660 }
 661
 662 # This routine assumes that assert_check has already been called.
 663 proc hosttest_assert_read_dump { output } {
 664
 665     foreach line [split $output "\n"] {
 666         set dummy ""
 667         set match ""
 668
 669         if { [regexp -nocase -- {^writing additional output to (.*)$} $line dummy match] } {
 670
 671             # The filename is in match, but it may not be directly accessible.
 672             set filename [hosttest_translate_existing_filename $match]
 673             if { $filename == "" } {
 674                 return ""
 675             }
 676             set status [ catch {
 677                 set fd   [open $filename r]
 678                 set data [read $fd]
 679                 close $fd
 680                 file delete $filename
 681             } message]
 682             if { $status != 0 } {
 683                 unresolved "Unable to process assertion dump file $filename"
 684                 unresolved "File $filename may have to be deleted manually"
 685                 return ""
 686             }
 687             return $data
 688         }
 689     }
 690     return ""
 691 }
 692
 693 # Look for the appropriate markers. Also clean up blank lines
 694 # at the start and end.
 695 proc hosttest_assert_extract_callback { dump title } {
 696
 697     set lines [split $dump "\n"]
 698     set result ""
 699
 700     while { [llength $lines] > 0 } {
 701         set line  [lindex $lines 0]
 702         set lines [lreplace $lines 0 0]
 703
 704         if { [regexp -nocase -- "^\# \{\{\{.*${title}.*\$" $line] } {
 705
 706             # Skip any blank lines at the start
 707             while { [llength $lines] > 0 } {
 708                 set line  [lindex $lines 0]
 709                 if { [regexp -- {^ *$} $line] == 0} {
 710                     break
 711                 }
 712                 set lines [lreplace $lines 0 0]
 713             }
 714
 715             # Now add any lines until the close marker.
 716             # Nested folds are not supported yet.
 717             while { [llength $lines] > 0 } {
 718                 set line  [lindex $lines 0]
 719                 set lines [lreplace $lines 0 0]
 720                 if { [regexp -nocase -- {^\# \}\}\}.*$} $line] } {
 721                     break
 722                 }
 723                 append result $line "\n"
 724             }
 725
 726             return $result
 727         }
 728     }
 729
 730     return ""
 731 }
 732
 733
 734
 735