Ben Elliston wrote:
On Mon, Dec 03, 2018 at 11:29:47PM -0600, Jacob Bachmeyer wrote:
In other words, it probably should remain as "relative_file_name",
since "realpath_relative" implies a different (and more extensive
operation) as I see it. At the least, "realpath_relative" would
apply "file normalize" to both arguments unconditionally, even
though this could produce surprising results in some situations
involving edge cases with symlinks. Those edge cases would also be
hard to debug, since users bit by them may not realize that symlinks
are involved in the problem. As a pure utility procedure,
"realpath" and variants could be useful, but could be dangerous to
call from the core due to this sensitivity to the filesystem that
this patch lacks.
Thanks for thinking about the suggestion -- I agree. I'm happy with
that, but can we use 'filename' without an underscore? It's a very
common convention and one less character to type. ;-)
While the GNU Coding Standards suggest using "file name" specifically; a
quick grep shows that DejaGnu already has proc unix_clean_filename and
no procedures that use "file_name" in their names, so consistency
suggests that the change should be made. A revised patch follows.
I do not see a difference either way as far as typing less:
relativ<M-/> is the same either way for me. :-)
----
ChangeLog entries:
* runtest.exp: Use new relative_filename procedure.
* doc/dejagnu.texi (relative_filename procedure): Add.
* lib/utils.exp (relative_filename): Add.
* testsuite/runtest.all/utils.test: Add tests for relative_filename.
----
patch:
----
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*]"] {
----
-- Jacob
_______________________________________________
DejaGnu mailing list
DejaGnu@gnu.org
https://lists.gnu.org/mailman/listinfo/dejagnu
