diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | doc/dejagnu.texi | 26 | ||||
| -rw-r--r-- | lib/utils.exp | 38 | ||||
| -rw-r--r-- | runtest.exp | 27 | ||||
| -rw-r--r-- | testsuite/runtest.all/utils.test | 23 |
5 files changed, 95 insertions, 26 deletions
@@ -1,3 +1,10 @@ +2018-12-04 Jacob Bachmeyer <jcb62281@gmail.com> + + * lib/utils.exp (relative_filename): New proc. + * runtest.exp: Use it. + * doc/dejagnu.texi (relative_filename procedure): Document it. + * testsuite/runtest.all/utils.test: Add tests for relative_filename. + 2018-12-03 Ben Elliston <bje@gnu.org> * dejagnu.h (TestState): Remove const char * variants of pass(), diff --git a/doc/dejagnu.texi b/doc/dejagnu.texi index d6f6881..373ef47 100644 --- a/doc/dejagnu.texi +++ b/doc/dejagnu.texi @@ -4671,6 +4671,7 @@ tool, and its version number. @menu * getdirs Procedure: getdirs procedure +* relative_filename Procedure: relative_filename procedure * find Procedure: find procedure * which Procedure: which procedure * grep Procedure: grep procedure @@ -4683,7 +4684,7 @@ tool, and its version number. * prune_system_crud Procedure: prune_system_crud procedure @end menu -@node getdirs procedure, find procedure, , Utility Procedures +@node getdirs procedure, relative_filename procedure, Utility Procedures, Utility Procedures @subsubheading getdirs Procedure @findex getdirs @@ -4712,7 +4713,26 @@ the pattern. If no directories match the pattern, then an empty list is returned. @end table -@node find procedure, which procedure, getdirs procedure, Utility Procedures +@node relative_filename procedure, find procedure, getdirs procedure, Utility Procedures +@subsubheading relative_filename Procedure +@findex relative_filename + +Return a relative file name, given a starting point. + +@quotation +@t{@b{relative_filename} @i{base} @i{destination}} +@end quotation + +@table @asis + +@item @code{base} +The starting point for relative file name traversal. + +@item @code{destination} +The absolute file name that should be reached by appending the return value to @i{base}. +@end table + +@node find procedure, which procedure, relative_filename procedure, Utility Procedures @subsubheading find Procedure @findex find @@ -5442,4 +5462,4 @@ This makes runtest exit. It is abbreviated as @emph{q}. @bye -@c LocalWords: subdirectory +@c LocalWords: subdirectory prepend prepended testsuite filename diff --git a/lib/utils.exp b/lib/utils.exp index 45319f2..0bc759f 100644 --- a/lib/utils.exp +++ b/lib/utils.exp @@ -85,6 +85,44 @@ proc getdirs { args } { } +# Given a base and a destination, return a relative file name that refers +# to the destination when used relative to the given base. +proc relative_filename { base destination } { + if { [file pathtype $base] != "absolute" } { + set base [file normalize $base] + } + if { [file pathtype $destination] != "absolute" } { + set destination [file normalize $destination] + } + + set base [file split $base] + set destination [file split $destination] + + verbose "base: \[[llength $base]\] $base" 3 + verbose "destination: \[[llength $destination]\] $destination" 3 + + set basecount [llength $base] + for {set i 0} {$i < $basecount + && [lindex $base $i] == [lindex $destination $i]} {incr i} {} + if { $i == $basecount } { + set tail [lrange $destination $i end] + } else { + set tail [lrange $destination $i end] + while { [incr i] <= $basecount } { + set tail [linsert $tail 0 ".."] + } + } + + if { [llength $tail] == 0 } { + set result "" + } else { + set result [eval file join $tail] + } + verbose "result: $result" 3 + return $result +} + + # Finds paths of all non-directory files, recursively, whose names match # a pattern. Certain directory name are not searched (see proc getdirs). # rootdir - search in this directory and its subdirectories, recursively. diff --git a/runtest.exp b/runtest.exp index b0ddfed..327131a 100644 --- a/runtest.exp +++ b/runtest.exp @@ -1771,15 +1771,8 @@ foreach current_target $target_list { # set subdir to the tail of the dirname after $srcdir, # for the driver files that want it. XXX this is silly. # drivers should get a single var, not "$srcdir/$subdir" - set subdir [file dirname $test_name] - set p [expr {[string length $srcdir] - 1}] - while {0 < $p && [string index $srcdir $p] == "/"} { - incr p -1 - } - if {[string range $subdir 0 $p] == $srcdir} { - set subdir [string range $subdir [expr {$p + 1}] end] - regsub "^/" $subdir "" subdir - } + set subdir [relative_filename $srcdir \ + [file dirname $test_name]] # XXX not the right thing to do. set runtests [list [file tail $test_name] ""] @@ -1860,20 +1853,8 @@ foreach current_target $target_list { # Get the path after the $srcdir so we know # the subdir we're in. - set subdir [file dirname $test_name] - # We used to do - # regsub $srcdir [file dirname $test_name] "" subdir - # but what if [file dirname $test_name] contains regexp - # characters? We lose. Instead... - set first [string first $srcdir $subdir] - if { $first >= 0 } { - set first [expr {$first + [string length $srcdir]}] - set subdir [string range $subdir $first end] - regsub "^/" "$subdir" "" subdir - } - if { "$srcdir" == "$subdir" || "$srcdir" == "$subdir/" } { - set subdir "" - } + set subdir [relative_filename $srcdir \ + [file dirname $test_name]] # Check to see if the range of tests is limited, # set `runtests' to a list of two elements: the script name # and any arguments ("" if none). diff --git a/testsuite/runtest.all/utils.test b/testsuite/runtest.all/utils.test index be13982..b8e05da 100644 --- a/testsuite/runtest.all/utils.test +++ b/testsuite/runtest.all/utils.test @@ -42,6 +42,29 @@ if [lib_pat_test "getdirs" "${srcdir}/runtest.all/topdir" "subdir1*subdir2" ] { puts "PASSED: getdirs toplevel, two subdirs" } +# Test relative_filename: +# +if { [relative_filename "/foo/test" "/foo/test/bar/baz" ] == "bar/baz" } { + puts "PASSED: relative_filename, simple prefix" +} else { + puts "FAILED: relative_filename, simple prefix" +} +if { [relative_filename "/foo/test" "/bar/test" ] == "../../bar/test" } { + puts "PASSED: relative_filename, up to top" +} else { + puts "FAILED: relative_filename, up to top" +} +if { [relative_filename "/tmp/foo-test" "/tmp/bar/test" ] == "../bar/test" } { + puts "PASSED: relative_filename, up one level" +} else { + puts "FAILED: relative_filename, up one level" +} +if { [relative_filename "/tmp/foo-test" "/tmp/foo-test" ] == "" } { + puts "PASSED: relative_filename, same name" +} else { + puts "FAILED: relative_filename, same name" +} + # Test find: # if [string match "*/subdir2/subfile2" "[find ${srcdir}/runtest.all/topdir/subdir2 sub*]"] { |