Home | History | Annotate | Download | only in lib 
      1 # This file is part of ltrace.
      2 # Copyright (C) 2012, 2013 Petr Machata, Red Hat Inc.
      3 # Copyright (C) 2006 Yao Qi, IBM Corporation
      4 #
      5 # This program is free software; you can redistribute it and/or
      6 # modify it under the terms of the GNU General Public License as
      7 # published by the Free Software Foundation; either version 2 of the
      8 # License, or (at your option) any later version.
      9 #
     10 # This program is distributed in the hope that it will be useful, but
     11 # WITHOUT ANY WARRANTY; without even the implied warranty of
     12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
     13 # General Public License for more details.
     14 #
     15 # You should have received a copy of the GNU General Public License
     16 # along with this program; if not, write to the Free Software
     17 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
     18 # 02110-1301 USA
     19 
     20 # Generic ltrace test subroutines that should work for any target.  If these
     21 # need to be modified for any target, it can be done with a variable
     22 # or by passing arguments.
     23 
     24 source $objdir/env.exp
     25 
     26 if [info exists TOOL_EXECUTABLE] {
     27 	set LTRACE $TOOL_EXECUTABLE
     28 } else {
     29 	set LTRACE $objdir/../ltrace
     30 }
     31 
     32 if {[info exists VALGRIND] && ![string equal $VALGRIND {}]} {
     33 	verbose "Running under valgrind command: `$VALGRIND'"
     34 	set LTRACE "$VALGRIND $LTRACE"
     35 }
     36 
     37 set LTRACE_OPTIONS {}
     38 set LTRACE_ARGS {}
     39 set LTRACE_TEMP_FILES {}
     40 
     41 # Pre-8.5 TCL doesn't have lreverse.  The following is taken from:
     42 #  http://www2.tcl.tk/17188
     43 
     44 if {[info command lreverse] == ""} {
     45     proc lreverse l {
     46         set r {}
     47         set i [llength $l]
     48         while {[incr i -1]} {lappend r [lindex $l $i]}
     49         lappend r [lindex $l 0]
     50     }
     51 }
     52 
     53 # ltrace_compile SOURCE DEST TYPE OPTIONS
     54 #
     55 # Compile PUT(program under test) by native compiler.   ltrace_compile runs
     56 # the right compiler, and TCL captures the output, and I evaluate the output.
     57 #
     58 # SOURCE is the name of program under test, with full directory.
     59 # DEST is the name of output of compilation, with full directory.
     60 # TYPE is an enum-like variable to affect the format or result of compiler
     61 #   output.  Values:
     62 #   executable   if output is an executable.
     63 #   object       if output is an object.
     64 # OPTIONS is option to compiler in this compilation.
     65 proc ltrace_compile {source dest type options} {
     66     global LTRACE_TESTCASE_OPTIONS;
     67 
     68     if {![string equal "object" $type]} {
     69 	# Add platform-specific options if a shared library was specified using
     70 	# "shlib=librarypath" in OPTIONS.
     71 	set new_options ""
     72 	set shlib_found 0
     73 
     74 	foreach opt $options {
     75 	    if [regexp {^shlib=(.*)} $opt dummy_var shlib_name] {
     76 		if [test_compiler_info "xlc*"] {
     77 		    # IBM xlc compiler doesn't accept shared library named other
     78 		    # than .so: use "-Wl," to bypass this
     79 		    lappend source "-Wl,$shlib_name"
     80 		} else {
     81 		    lappend source $shlib_name
     82 		}
     83 
     84 		if {$shlib_found == 0} {
     85 		    set shlib_found 1
     86 
     87 		    if { ([test_compiler_info "gcc-*"]&& ([istarget "powerpc*-*-aix*"]|| [istarget "rs6000*-*-aix*"] ))} {
     88 			lappend options "additional_flags=-L${objdir}/${subdir}"
     89 		    } elseif { [istarget "mips-sgi-irix*"] } {
     90 			lappend options "additional_flags=-rpath ${objdir}/${subdir}"
     91 		    }
     92 		}
     93 
     94 	    } else {
     95 		lappend new_options $opt
     96 	    }
     97 	}
     98 
     99 	#end of for loop
    100 	set options $new_options
    101     }
    102 
    103     # dump some information for debug purpose.
    104     verbose "options are $options"
    105     verbose "source is $source $dest $type $options"
    106 
    107     # Wipe the DEST file, so that we don't end up running an obsolete
    108     # version of the binary.
    109     exec rm -f $dest
    110 
    111     set result [target_compile $source $dest $type $options];
    112     verbose "result is $result"
    113     regsub "\[\r\n\]*$" "$result" "" result;
    114     regsub "^\[\r\n\]*" "$result" "" result;
    115     if { $result != "" && [lsearch $options quiet] == -1} {
    116 	clone_output "compile failed for ltrace test, $result"
    117     }
    118     return $result;
    119 }
    120 
    121 proc get_compiler_info {binfile args} {
    122     # For compiler.c and compiler.cc
    123     global srcdir
    124 
    125     # I am going to play with the log to keep noise out.
    126     global outdir
    127     global tool
    128 
    129     # These come from compiler.c or compiler.cc
    130     global compiler_info
    131 
    132     # Legacy global data symbols.
    133     #global gcc_compiled
    134 
    135     # Choose which file to preprocess.
    136     set ifile "${srcdir}/lib/compiler.c"
    137     if { [llength $args] > 0 && [lindex $args 0] == "c++" } {
    138 	    set ifile "${srcdir}/lib/compiler.cc"
    139     }
    140 
    141     # Run $ifile through the right preprocessor.
    142     # Toggle ltrace.log to keep the compiler output out of the log.
    143     #log_file
    144     set cppout [ ltrace_compile "${ifile}" "" preprocess [list "$args" quiet] ]
    145     #log_file -a "$outdir/$tool.log"
    146 
    147     # Eval the output.
    148     set unknown 0
    149     foreach cppline [ split "$cppout" "\n" ] {
    150 	    if { [ regexp "^#" "$cppline" ] } {
    151 	      # line marker
    152 	    } elseif { [ regexp "^\[\n\r\t \]*$" "$cppline" ] } {
    153 	      # blank line
    154 	    } elseif { [ regexp "^\[\n\r\t \]*set\[\n\r\t \]" "$cppline" ] } {
    155 	    # eval this line
    156 	      verbose "get_compiler_info: $cppline" 2
    157 	      eval "$cppline"
    158 	  } else {
    159 	    # unknown line
    160 	    verbose "get_compiler_info: $cppline"
    161 	    set unknown 1
    162 	  }
    163       }
    164 
    165     # Reset to unknown compiler if any diagnostics happened.
    166     if { $unknown } {
    167 	    set compiler_info "unknown"
    168     }
    169   return 0
    170 }
    171 
    172 proc test_compiler_info { {compiler ""} } {
    173     global compiler_info
    174 
    175      if [string match "" $compiler] {
    176          if [info exists compiler_info] {
    177 	     verbose "compiler_info=$compiler_info"
    178 	     # if no arg, return the compiler_info string
    179              return $compiler_info
    180          } else {
    181              perror "No compiler info found."
    182          }
    183      }
    184 
    185     return [string match $compiler $compiler_info]
    186 }
    187 
    188 proc ltrace_compile_shlib {sources dest options} {
    189     set obj_options $options
    190     verbose "+++++++ [test_compiler_info]"
    191     switch -glob [test_compiler_info] {
    192 	"xlc-*" {
    193 	    lappend obj_options "additional_flags=-qpic"
    194 	}
    195 	"gcc-*" {
    196 	    if { !([istarget "powerpc*-*-aix*"]
    197 		   || [istarget "rs6000*-*-aix*"]) } {
    198                 lappend obj_options "additional_flags=-fpic"
    199 	    }
    200           }
    201   "xlc++-*" {
    202       lappend obj_options "additional_flags=-qpic"
    203   }
    204 
    205 	default {
    206 	    fail "Bad compiler!"
    207             }
    208     }
    209 
    210     if {![LtraceCompileObjects $sources $obj_options objects]} {
    211 	return -1
    212     }
    213 
    214     set link_options $options
    215     if { [test_compiler_info "xlc-*"] || [test_compiler_info "xlc++-*"]} {
    216 	lappend link_options "additional_flags=-qmkshrobj"
    217     } else {
    218 	lappend link_options "additional_flags=-shared"
    219     }
    220     if {[ltrace_compile "${objects}" "${dest}" executable $link_options] != ""} {
    221 	return -1
    222     }
    223 
    224     return
    225 }
    226 
    227 # WipeFiles --
    228 #
    229 #	Delete each file in the list.
    230 #
    231 # Arguments:
    232 #	files	List of files to delete.
    233 #
    234 # Results:
    235 #	Each of the files is deleted.  Files are deleted in reverse
    236 #	order, so that directories are emptied and can be deleted
    237 #	without using -force.  Returns nothing.
    238 
    239 proc WipeFiles {files} {
    240     verbose "WipeFiles: $files\n"
    241     foreach f [lreverse $files] {
    242 	file delete $f
    243     }
    244 }
    245 
    246 # LtraceTmpDir --
    247 #
    248 #	Guess what directory to use for temporary files.
    249 #	This was adapted from http://wiki.tcl.tk/772
    250 #
    251 # Results:
    252 #	A temporary directory to use.  The current directory if no
    253 #	other seems to be available.
    254 
    255 proc LtraceTmpDir {} {
    256     set tmpdir [pwd]
    257 
    258     if {[file exists "/tmp"]} {
    259 	set tmpdir "/tmp"
    260     }
    261 
    262     catch {set tmpdir $::env(TMP)}
    263     catch {set tmpdir $::env(TEMP)}
    264     catch {set tmpdir $::env(TMPDIR)}
    265 
    266     return $tmpdir
    267 }
    268 
    269 set LTRACE_TEMP_DIR [LtraceTmpDir]
    270 
    271 # LtraceTempFile --
    272 #
    273 #	Create a temporary file according to a pattern, and return its
    274 #	name.  This behaves similar to mktemp.  We don't use mktemp
    275 #	directly, because on older systems, mktemp requires that the
    276 #	array of X's be at the very end of the string, while ltrace
    277 #	temporary files need to have suffixes.
    278 #
    279 # Arguments:
    280 #	pat	Pattern to use.  See mktemp for description of its format.
    281 #
    282 # Results:
    283 #	Creates the temporary file and returns its name.  The name is
    284 #	also appended to LTRACE_TEMP_FILES.
    285 
    286 proc LtraceTempFile {pat} {
    287     global LTRACE_TEMP_FILES
    288     global LTRACE_TEMP_DIR
    289 
    290     set letters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
    291     set numLetters [string length $letters]
    292 
    293     if {![regexp -indices {(X{3,})} $pat m]} {
    294 	send_error -- "Pattern $pat contains insufficient number of X's."
    295 	return {}
    296     }
    297 
    298     set start [lindex $m 0]
    299     set end [lindex $m 1]
    300     set len [expr {$end - $start + 1}]
    301 
    302     for {set j 0} {$j < 10} {incr j} {
    303 
    304 	# First, generate a random name.
    305 
    306 	set randstr {}
    307 	for {set i 0} {$i < $len} {incr i} {
    308 	    set r [expr {int(rand() * $numLetters)}]
    309 	    append randstr [string index $letters $r]
    310 	}
    311 	set prefix [string range $pat 0 [expr {$start - 1}]]
    312 	set suffix [string range $pat [expr {$end + 1}] end]
    313 	set name [file join $LTRACE_TEMP_DIR "$prefix$randstr$suffix"]
    314 
    315 	# Now check that it's free.  This is of course racy, but this
    316 	# is a test suite, not anything used in actual production.
    317 
    318 	if {[file exists $name]} {
    319 	    continue
    320 	}
    321 
    322 	# We don't bother attempting to open the file.  Downstream
    323 	# code can do it itself.
    324 
    325 	lappend LTRACE_TEMP_FILES $name
    326 	return $name
    327     }
    328 
    329     send_error -- "Couldn't create a temporary file for pattern $pat."
    330     return
    331 }
    332 
    333 # ltraceNamedSource --
    334 #
    335 #	Create a file named FILENAME, and prime it with TEXT.  If
    336 #	REMEMBERTEMP, add the file into LTRACE_TEMP_FILES, so that
    337 #	ltraceDone (or rather WipeFiles) erases it later.
    338 #
    339 # Arguments:
    340 #	filename	Name of the file to create.
    341 #
    342 #	text	Contents of the new file.
    343 #
    344 #	rememberTemp	Whether to add filename to LTRACE_TEMP_FILES.
    345 #
    346 # Results:
    347 #	Returns $filename, which now refers to a file with contents
    348 #	given by TEXT.
    349 
    350 proc ltraceNamedSource {filename text {rememberTemp 1}} {
    351     global LTRACE_TEMP_FILES
    352 
    353     set chan [open $filename w]
    354     puts $chan $text
    355     close $chan
    356 
    357     if $rememberTemp {
    358 	lappend LTRACE_TEMP_FILES $filename
    359     }
    360 
    361     return $filename
    362 }
    363 
    364 # ltraceSource --
    365 #
    366 #	Create a temporary file with a given suffix and prime it with
    367 #	contents given in text.
    368 #
    369 # Arguments:
    370 #	suffix	Suffix of the temp file to be created.
    371 #
    372 #	text	Contents of the new file.
    373 #
    374 # Results:
    375 #	Returns file name of created file.
    376 
    377 proc ltraceSource {suffix text} {
    378     return [ltraceNamedSource \
    379 		[LtraceTempFile "lt-XXXXXXXXXX.$suffix"] $text 0]
    380 }
    381 
    382 # ltraceDir --
    383 #
    384 #	Create a temporary directory.
    385 #
    386 # Arguments:
    387 #
    388 # Results:
    389 #	Returns name of created directory.
    390 
    391 proc ltraceDir {} {
    392     set ret [LtraceTempFile "lt-XXXXXXXXXX.dir"]
    393     file mkdir $ret
    394     return $ret
    395 }
    396 
    397 # LtraceCompileObjects --
    398 #
    399 #	Compile each source file into an object file.  ltrace_compile
    400 #	is called to perform actual compilation.
    401 #
    402 # Arguments:
    403 #	sources	List of source files.
    404 #
    405 #	options	Options for ltrace_compile.
    406 #
    407 #	retName Variable where the resulting list of object names is
    408 #		to be placed.
    409 # Results:
    410 #	Returns true or false depending on whether there were any
    411 #	errors.  If it returns true, then variable referenced by
    412 #	retName contains list of object files, produced by compiling
    413 #	files in sources list.
    414 
    415 proc LtraceCompileObjects {sources options retName} {
    416     global LTRACE_TEMP_FILES
    417     upvar $retName ret
    418     set ret {}
    419 
    420     foreach source $sources {
    421 	set sourcebase [file tail $source]
    422 	set dest $source.o
    423 	lappend LTRACE_TEMP_FILES $dest
    424 	verbose "LtraceCompileObjects: $source -> $dest"
    425 	if {[ltrace_compile $source $dest object $options] != ""} {
    426 	    return false
    427 	}
    428 	lappend ret $dest
    429     }
    430 
    431     return true
    432 }
    433 
    434 # ltraceCompile --
    435 #
    436 #	This attempts to compile a binary from sources given in ARGS.
    437 #
    438 # Arguments:
    439 #	dest	A binary to be produced.  If this is called lib*.so, then
    440 #		the resulting binary will be a library, if *.pie, it
    441 #		will be a PIE, otherwise it will be an executable.  In
    442 #		theory this could also be *.o for "object" and *.i for
    443 #		"preprocess" for cases with one source file, but that
    444 #		is not supported at the moment.  The binary will be
    445 #		placed in $objdir/$subdir.
    446 #
    447 #	args	List of options and source files.
    448 #
    449 #		Options are arguments that start with a dash.  Options
    450 #		(sans the dash) are passed to ltrace_compile.
    451 #
    452 #		Source files named lib*.so are libraries.  Those are
    453 #		passed to ltrace_compile as options shlib=X.  Source
    454 #		files named *.o are objects.  The remaining source
    455 #		files are first compiled (by LtraceCompileObjects) and
    456 #		then together with other objects passed to
    457 #		ltrace_compile to produce resulting binary.
    458 #
    459 #		Any argument that is empty string prompts the function
    460 #		to fail.  This is done so that errors caused by
    461 #		ltraceSource (or similar) distribute naturally
    462 #		upwards.
    463 #
    464 # Results:
    465 #	This compiles given source files into a binary.  Full file name
    466 #	of that binary is returned.  Empty string is returned in case
    467 #	of a failure.
    468 
    469 proc ltraceCompile {dest args} {
    470     global objdir
    471     global subdir
    472 
    473     get_compiler_info {} c
    474     get_compiler_info {} c++
    475 
    476     if {[string match "lib*.so" $dest]} {
    477 	set type "library"
    478 	set extraObjOptions "additional_flags=-fpic"
    479 	set extraOptions "additional_flags=-shared"
    480     } elseif {[string match "*.pie" $dest]} {
    481 	set type "executable"
    482 	set extraObjOptions "additional_flags=-fpic"
    483 	set extraOptions "additional_flags=-pie"
    484     } else {
    485 	set type "executable"
    486 	set extraObjOptions {}
    487 	set extraOptions {}
    488     }
    489 
    490     set options {}
    491     set sources {}
    492     set objects {}
    493     foreach a $args {
    494 	if {[string match "-l*" $a]} {
    495 	    lappend options "shlib=$a"
    496 	} elseif {[string match "-?*" $a]} {
    497 	    lappend options [string range $a 1 end]
    498 	} elseif {[string match "*.so" $a]} {
    499 	    lappend options "shlib=$a"
    500 	} elseif {[string match "*.o" $a]} {
    501 	    lappend objects $a
    502 	} else {
    503 	    lappend sources $a
    504 	}
    505     }
    506 
    507     if {[string equal $dest {}]} {
    508 	set dest [LtraceTempFile "exe-XXXXXXXXXX"]
    509     } elseif {[string equal $dest ".pie"]} {
    510 	set dest [LtraceTempFile "pie-XXXXXXXXXX"]
    511     } else {
    512 	set dest $objdir/$subdir/$dest
    513     }
    514 
    515     verbose "ltraceCompile: dest $dest"
    516     verbose "             : options $options"
    517     verbose "             : sources $sources"
    518     verbose "             : objects $objects"
    519 
    520     if {![LtraceCompileObjects $sources \
    521 	      [concat $options $extraObjOptions] newObjects]} {
    522 	return {}
    523     }
    524     set objects [concat $objects $newObjects]
    525 
    526     verbose "ltraceCompile: objects $objects"
    527 
    528     if {[ltrace_compile $objects $dest $type \
    529 	     [concat $options $extraOptions]] != ""} {
    530 	return {}
    531     }
    532 
    533     return $dest
    534 }
    535 
    536 # ltraceRun --
    537 #
    538 #	Invoke command identified by LTRACE global variable with given
    539 #	ARGS.  A logfile redirection is automatically ordered by
    540 #	passing -o and a temporary file name.
    541 #
    542 # Arguments:
    543 #	args	Arguments to ltrace binary.
    544 #
    545 # Results:
    546 #	Returns name of logfile.  The "exec" command that it uses
    547 #	under the hood fails loudly if the process exits with a
    548 #	non-zero exit status, or uses stderr in any way.
    549 
    550 proc ltraceRun {args} {
    551     global LTRACE
    552     global objdir
    553     global subdir
    554 
    555     set LdPath [ld_library_path $objdir/$subdir]
    556     set logfile [ltraceSource ltrace {}]
    557 
    558     # Run ltrace.  expect will show an error if this doesn't exit with
    559     # zero exit status (i.e. ltrace fails, valgrind finds errors,
    560     # etc.).
    561 
    562     set command "exec env LD_LIBRARY_PATH=$LdPath $LTRACE -o $logfile $args"
    563     verbose $command
    564     if {[catch {eval $command}] } {
    565 	fail "test case execution failed"
    566 	send_error -- $command
    567 	send_error -- $::errorInfo
    568     }
    569 
    570     return $logfile
    571 }
    572 
    573 # ltraceDone --
    574 #
    575 #	Wipes or dumps all temporary files after a test suite has
    576 #	finished.
    577 #
    578 # Results:
    579 #	Doesn't return anything.  Wipes all files gathered in
    580 #	LTRACE_TEMP_FILES.  If SAVE_TEMPS is defined and true, the
    581 #	temporary files are not wiped, but their names are dumped
    582 #	instead.  Contents of LTRACE_TEMP_FILES are deleted in any
    583 #	case.
    584 
    585 proc ltraceDone {} {
    586     global SAVE_TEMPS
    587     global LTRACE_TEMP_FILES
    588 
    589     if {[info exists SAVE_TEMPS] && $SAVE_TEMPS} {
    590 	foreach tmp $LTRACE_TEMP_FILES {
    591 	    send_user "$tmp\n"
    592 	}
    593     } else {
    594 	WipeFiles $LTRACE_TEMP_FILES
    595     }
    596 
    597     set LTRACE_TEMP_FILES {}
    598     return
    599 }
    600 
    601 # Grep --
    602 #
    603 #	Return number of lines in a given file, matching a given
    604 #	regular expression.
    605 #
    606 # Arguments:
    607 #	logfile	File to search through.
    608 #
    609 #	re	Regular expression to match.
    610 #
    611 # Results:
    612 #	Returns number of matching lines.
    613 
    614 proc Grep {logfile re} {
    615     set count 0
    616     set fp [open $logfile]
    617     while {[gets $fp line] >= 0} {
    618 	if [regexp -- $re $line] {
    619 	    incr count
    620 	}
    621     }
    622     close $fp
    623     return $count
    624 }
    625 
    626 # ltraceMatch1 --
    627 #
    628 #	Look for a pattern in a given logfile, comparing number of
    629 #	occurences of the pattern with expectation.
    630 #
    631 # Arguments:
    632 #	logfile	The name of file where to look for patterns.
    633 #
    634 #	pattern	Regular expression pattern to look for.
    635 #
    636 #	op	Operator to compare number of occurences.
    637 #
    638 #	expect	Second operand to op, the first being number of
    639 #		occurences of pattern.
    640 #
    641 # Results:
    642 #	Doesn't return anything, but calls fail or pass depending on
    643 #	whether the patterns matches expectation.
    644 
    645 proc ltraceMatch1 {logfile pattern {op ==} {expect 1}} {
    646     set count [Grep $logfile $pattern]
    647     set msgMain "$pattern appears in $logfile $count times"
    648     set msgExpect ", expected $op $expect"
    649 
    650     if {[eval expr $count $op $expect]} {
    651 	pass $msgMain
    652     } else {
    653 	fail $msgMain$msgExpect
    654     }
    655     return
    656 }
    657 
    658 # ltraceMatch --
    659 #
    660 #	Look for series of patterns in a given logfile, comparing
    661 #	number of occurences of each pattern with expectations.
    662 #
    663 # Arguments:
    664 #	logfile	The name of file where to look for patterns.
    665 #
    666 #	patterns List of patterns to look for.  ltraceMatch1 is called
    667 #		on each of these in turn.
    668 #
    669 # Results:
    670 #
    671 #	Doesn't return anything, but calls fail or pass depending on
    672 #	whether each of the patterns holds.
    673 
    674 proc ltraceMatch {logfile patterns} {
    675     foreach pat $patterns {
    676 	eval ltraceMatch1 [linsert $pat 0 $logfile]
    677     }
    678     return
    679 }
    680 
    681 # ltraceLibTest --
    682 #
    683 #	Generate a binary, a library (liblib.so) and a config file.
    684 #	Run the binary using ltraceRun, passing it -F to load the
    685 #	config file.
    686 #
    687 # Arguments:
    688 #	conf	Contents of ltrace config file.
    689 #
    690 #	cdecl	Contents of header file.
    691 #
    692 #	libcode	Contents of library implementation file.
    693 #
    694 #	maincode	Contents of function "main".
    695 #
    696 #	params	Additional parameters to pass to ltraceRun.
    697 #
    698 # Results:
    699 #
    700 #	Returns whatever ltraceRun returns.
    701 
    702 proc ltraceLibTest {conf cdecl libcode maincode {params ""}} {
    703     set conffile [ltraceSource conf $conf]
    704     set lib [ltraceCompile liblib.so [ltraceSource c [concat $cdecl $libcode]]]
    705     set bin [ltraceCompile {} $lib \
    706 		 [ltraceSource c \
    707 		      [concat $cdecl "int main(void) {" $maincode "}"]]]
    708 
    709     return [eval [concat "ltraceRun -F $conffile " $params "-- $bin"]]
    710 }
    711 
    712 #
    713 # ltrace_options OPTIONS_LIST
    714 # Pass ltrace commandline options.
    715 #
    716 proc ltrace_options { args } {
    717 
    718 	global LTRACE_OPTIONS
    719 	set LTRACE_OPTIONS $args
    720 }
    721 
    722 #
    723 # ltrace_args ARGS_LIST
    724 # Pass ltrace'd program its own commandline options.
    725 #
    726 proc ltrace_args { args } {
    727 
    728 	global LTRACE_ARGS
    729 	set LTRACE_ARGS $args
    730 }
    731 
    732 #
    733 # handle run-time library paths
    734 #
    735 proc ld_library_path { args } {
    736 
    737 	set ALL_LIBRARY_PATHS { }
    738 	if [info exists LD_LIBRARY_PATH] {
    739 		lappend ALL_LIBRARY_PATHS $LD_LIBRARY_PATH
    740 	}
    741 	global libelf_LD_LIBRARY_PATH
    742 	if {[string length $libelf_LD_LIBRARY_PATH] > 0} {
    743 		lappend ALL_LIBRARY_PATHS $libelf_LD_LIBRARY_PATH
    744 	}
    745 	global elfutils_LD_LIBRARY_PATH
    746 	if {[string length $elfutils_LD_LIBRARY_PATH] > 0} {
    747 		lappend ALL_LIBRARY_PATHS $elfutils_LD_LIBRARY_PATH
    748 	}
    749 	global libunwind_LD_LIBRARY_PATH
    750 	if {[string length $libunwind_LD_LIBRARY_PATH] > 0} {
    751 		lappend ALL_LIBRARY_PATHS $libunwind_LD_LIBRARY_PATH
    752 	}
    753 	lappend ALL_LIBRARY_PATHS $args
    754 	join $ALL_LIBRARY_PATHS ":"
    755 }
    756 
    757 #
    758 # ltrace_runtest LD_LIBRARY_PATH BIN FILE
    759 # Trace the execution of BIN and return result.
    760 #
    761 # BIN is program-under-test.
    762 # LD_LIBRARY_PATH is the env for program-under-test to run.
    763 # FILE is to save the output from ltrace with default name $BIN.ltrace.
    764 # Retrun output from ltrace.
    765 #
    766 proc ltrace_runtest { args } {
    767 
    768 	global LTRACE
    769 	global LTRACE_OPTIONS
    770 	global LTRACE_ARGS
    771 
    772 	verbose "LTRACE = $LTRACE"
    773 
    774 	set LD_LIBRARY_PATH_ [ld_library_path [lindex $args 0]]
    775 	set BIN [lindex $args 1]
    776 
    777 	# specify the output file, the default one is $BIN.ltrace
    778 	if [llength $args]==3 then {
    779 		set file [lindex $args 2]
    780 	} else {
    781 		set file $BIN.ltrace
    782 	}
    783 
    784 	# Remove the file first.  If ltrace fails to overwrite it, we
    785 	# would be comparing output to an obsolete run.
    786 	exec rm -f $file
    787 
    788 	# append this option to LTRACE_OPTIONS.
    789 	lappend LTRACE_OPTIONS "-o"
    790 	lappend LTRACE_OPTIONS "$file"
    791 	verbose "LTRACE_OPTIONS = $LTRACE_OPTIONS"
    792 	set command "exec sh -c {export LD_LIBRARY_PATH=$LD_LIBRARY_PATH_; \
    793 		$LTRACE $LTRACE_OPTIONS $BIN $LTRACE_ARGS;exit}"
    794 	#ltrace the PUT.
    795 	if {[catch $command output]} {
    796 	    fail "test case execution failed"
    797 	    send_error -- $command
    798 	    send_error -- $::errorInfo
    799 	}
    800 
    801 	# return output from ltrace.
    802 	return $output
    803 }
    804 
    805 #
    806 # ltrace_verify_output FILE_TO_SEARCH PATTERN MAX_LINE
    807 # Verify the ltrace output by comparing the number of PATTERN in
    808 # FILE_TO_SEARCH with INSTANCE_NO.  Do not specify INSTANCE_NO if
    809 # instance number is ignored in this test.
    810 # Reutrn:
    811 #      0 = number of PATTERN in FILE_TO_SEARCH inqual to INSTANCE_NO.
    812 #      1 = number of PATTERN in FILE_TO_SEARCH qual to INSTANCE_NO.
    813 #
    814 proc ltrace_verify_output { file_to_search pattern {instance_no 0} {grep_command "grep"}} {
    815 
    816 	# compute the number of PATTERN in FILE_TO_SEARCH by grep and wc.
    817 	catch "exec sh -c {$grep_command \"$pattern\" $file_to_search | wc -l ;exit}" output
    818 	verbose "output = $output"
    819 
    820 	if [ regexp "syntax error" $output ] then {
    821 		fail "Invalid regular expression $pattern"
    822         } elseif { $instance_no == 0 } then {
    823 		if { $output == 0 } then {
    824 			fail "Fail to find $pattern in $file_to_search"
    825 		} else {
    826 			pass "$pattern in $file_to_search"
    827 		}
    828 	} elseif { $output >= $instance_no } then {
    829 		pass "$pattern in $file_to_search for $output times"
    830 	} else {
    831 		fail "$pattern in $file_to_search for $output times, should be $instance_no"
    832 	}
    833 }
    834