PATCH: add relative_file_name procedure to encapsulate logic for "subdir" variable

[Jacob Bachmeyer]

This is part of my ongoing efforts to improve DejaGnu's integration with 
Automake.  I think that "relative_file_name" could be a useful utility 
procedure and will be able to fill any remaining gaps when subdir is 
eventually deprecated.  This also replaces two slightly different ways 
of deriving what should be the same value.

Equivalence:
   (near)    $subdir == [relative_file_name [testsuite file -source 
-top] [testsuite file -source -test]]
   (exact)   $subdir == [relative_file_name $srcdir [testsuite file 
-source -test]]

(Note that "testsuite file" is not yet written; see 
<URL:http://lists.gnu.org/archive/html/dejagnu/2018-11/msg00023.html> 
for an explanation of the "testsuite file" call.)

----
ChangeLog entries:
        * runtest.exp: Use new relative_file_name procedure.

        * doc/dejagnu.texi (relative_file_name procedure): Add.
        * lib/utils.exp (relative_file_name): Add.
        * testsuite/runtest.all/utils.test: Add tests for relative_file_name.
----
patch:
----
diff --git a/doc/dejagnu.texi b/doc/dejagnu.texi
index d6f6881..d1bf585 100644
--- a/doc/dejagnu.texi
+++ b/doc/dejagnu.texi
@@ -4671,6 +4671,7 @@ tool, and its version number.

@menu
* getdirs Procedure: getdirs procedure
+* relative_file_name Procedure: relative_file_name 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

address@hidden getdirs procedure, find procedure, , Utility Procedures
address@hidden getdirs procedure, relative_file_name 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

address@hidden find procedure, which procedure, getdirs procedure, Utility 
Procedures
address@hidden relative_file_name procedure, find procedure, getdirs procedure, 
Utility Procedures
address@hidden relative_file_name Procedure
address@hidden relative_file_name
+
+Return a relative file name, given a starting point.
+
address@hidden
address@hidden@b{relative_file_name} @i{base} @i{destination}}
address@hidden quotation
+
address@hidden @asis
+
address@hidden @code{base}
+The starting point for relative file name traversal.
+
address@hidden @code{destination}
+The absolute file name that should be reached by appending the return value to 
@i{base}.
address@hidden table
+
address@hidden find procedure, which procedure, relative_file_name procedure, 
Utility Procedures
@subsubheading find Procedure
@findex find

diff --git a/lib/utils.exp b/lib/utils.exp
index 45319f2..8cf095b 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_file_name { 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..0cd5a34 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_file_name $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_file_name $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..00bccee 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_file_name:
+#
+if { [relative_file_name "/foo/test" "/foo/test/bar/baz" ] == "bar/baz" } {
+    puts "PASSED: relative_file_name, simple prefix"
+} else {
+    puts "FAILED: relative_file_name, simple prefix"
+}
+if { [relative_file_name "/foo/test" "/bar/test" ] == "../../bar/test" } {
+    puts "PASSED: relative_file_name, up to top"
+} else {
+    puts "FAILED: relative_file_name, up to top"
+}
+if { [relative_file_name "/tmp/foo-test" "/tmp/bar/test" ] == "../bar/test" } {
+    puts "PASSED: relative_file_name, up one level"
+} else {
+    puts "FAILED: relative_file_name, up one level"
+}
+if { [relative_file_name "/tmp/foo-test" "/tmp/foo-test" ] == "" } {
+    puts "PASSED: relative_file_name, same name"
+} else {
+    puts "FAILED: relative_file_name, same name"
+}
+
# Test find:
#
if [string match "*/subdir2/subfile2" "[find ${srcdir}/runtest.all/topdir/subdir2 
sub*]"] {
----


-- Jacob