OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [rtos/] [ecos-2.0/] [tools/] [src/] [infra/] [hosttest.exp] - Blame information for rev 600

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 26 unneback
#===============================================================================
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:
466
        #    FAIL: 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
 

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.