* 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.

Signed-off-by: Ben Elliston <bje@gnu.org>

ChangeLog

@@ -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(),

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

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.

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).

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*]"] {