relative_root

Author: dkechag

agg

@@ -23,7 +23,7 @@ or to check whether specific tests can run successfully under Test2::Aggregate.
  --prove,            -p      : Force prove (default is yath/Test2 if installed).
  --verbose,          -v      : Verbose (passed to yath/prove)
  --absolute,         -a      : Use absolute paths in generated files. Disabled with -r.
- --root <s>          -r <s>  : Define a custom root dir (default is current dir).
+ --root <s>          -r <s>  : Define a custom root dir.
  --include <s>,      -I <s>  : Library paths to include.
  --test_warnings,    -w      : Fail tests on warnings.
  --test_bundle <s>,  -t      : Test bundle (def: Test2::V0 or Test::More if -p). Can be comma-separated list.
@@ -71,15 +71,15 @@ pod2usage({-verbose => 1, -output => \*STDOUT, -noperldoc => 1})
 
 Test2::Aggregate::Helper::setup_options(\%opt);
 
-my $file = $opt{out} ? path($opt{out}.'.t') : Path::Tiny->tempfile(
+$opt{file} = $opt{out} ? path($opt{out}.'.t') : Path::Tiny->tempfile(
     TEMPLATE => "aggXXXXXX",
     SUFFIX   => '.t',
     UNLINK   => 0
 );
 
-print "Writing output to $file\n" if $opt{verbose};
+print "Writing output to $opt{file}\n" if $opt{verbose};
 
 my $code = Test2::Aggregate::Helper::generate_code(\%opt, @ARGV);
-$file->spew_utf8($code);
+$opt{file}->spew_utf8($code);
 
-exec(Test2::Aggregate::Helper::create_command(\%opt, $file));
+exec(Test2::Aggregate::Helper::create_command(\%opt, $opt{file}));

lib/Test2/Aggregate.pm

@@ -3,6 +3,7 @@ package Test2::Aggregate;
 use strict;
 use warnings;
 
+use File::Basename;
 use File::Find;
 use File::Path;
 use Path::Tiny;
@@ -84,6 +85,7 @@ have less issues with L<Test2::Suite> (see notes).
         absolute      => 0,                   # optional
         bail_on_fail  => 0,                   # optional, requires Test2::Plugin::BailOnFail
         no_dot        => 0,                   # optional
+        relative_root => 0,                   # optional
         allow_errors  => 0,                   # optional
         pre_eval      => $code_to_eval,       # optional
         dry_run       => 0,                   # optional
@@ -135,9 +137,14 @@ Applied after C<exclude>.
 
 =item * C<root> (optional)
 
-If defined, must be a valid root directory that will prefix all C<dirs> and
-C<lists> items. You may want to set it to C<'./'> if you want dirs relative
-to the current directory and the dot is not in your C<@INC>.
+If defined, must be a valid root directory that will prefix all C<dirs> and C<lists>
+items. You may want to set it to C<'./'> if you want dirs relative to the current
+directory and the dot is not in your C<@INC>.
+
+=item * C<relative_root> (optional)
+
+Set to true if you want your root to be relative to the caller script's directory
+(based on C<$0>). It is ignored if you use an absolute root path.
 
 =item * C<load_modules> (optional)
 
@@ -289,19 +296,22 @@ sub run_tests {
 
     @dirs = @{$args{dirs}} if $args{dirs};
     $args{root} .= '/' unless !$args{root} || $args{root} =~ m#/$#;
+    $args{root} = dirname($0) . "/$args{root}"
+        if $args{relative_root} && $args{root} && $args{root} !~ m#^/#;
 
     if ($args{root} && ! -e $args{root}) {
         warn "Root '$args{root}' does not exist, no tests are loaded."
     } else {
         foreach my $file (@{$args{lists}}) {
             push @dirs,
-              map { /^\s*(?:#|$)/ ? () : $_ }
-              split(/\r?\n/, _read_file($args{root}.$file, $args{slurp_param}));
+                map {/^\s*(?:#|$)/ ? () : $_}
+                split(/\r?\n/,
+                _read_file($args{root}, $file, $args{slurp_param}));
         }
 
         find(
             sub {push @tests, $File::Find::name if /\.t$/},
-            grep {-e} map {$args{root} . $_} @dirs
+            grep {-e} map {_check_abs_path($args{root}, $_)} @dirs
         )
             if @dirs;
     }
@@ -353,11 +363,21 @@ sub run_tests {
     return $args{stats};
 }
 
+sub _check_abs_path {
+    my $root = shift;
+    my $path = shift;
+    # Can't use path() below as it removes ./ which is needed for absolute option
+    $path = "$root$path" unless !$root || substr($path, 0, 1) eq '/';
+    return $path;
+}
+
 sub _read_file {
+    my $root  = shift;
     my $path  = shift;
     my $param = shift;
-    my $file  = path($path);
-    return $param ? $file->slurp_utf8 : $file->slurp($param);
+    my $file  = path(_check_abs_path($root, $path));
+
+    return $param ? $file->slurp($param) : $file->slurp_utf8;
 }
 
 sub _process_run_order {
@@ -412,6 +432,7 @@ sub _run_tests {
         foreach my $test (@$tests) {
             my $test_nm =
                 $args->{absolute} ? $test : _test_name($test, $args->{root});
+
             warn  "$test_nm->Test2::Aggregate\n" if $args->{test_warnings};
 
             $stats{$test_nm}{test_no} = $count unless $stats{$test_nm}{test_no};
@@ -730,6 +751,13 @@ You would call it with something like C<--exclude-lists=t/aggregate/*.lst>, and
 the tests listed will be excluded (you will have them running aggregated through
 their own C<.t> files using L<Test2::Aggregate>).
 
+=head1 WINDOWS SUPPORT
+
+Only filesystems with the C</> separator are supported, simply because the author
+does not expect Windows users (many test suites don't work under StrawberryPerl
+etc). However, if you want Windows filesystems to be supported it should be simple
+enough, so just ask.
+
 =head1 AUTHOR
 
 Dimitrios Kechagias, C<< <dkechag at cpan.org> >>

t/dirs.t

@@ -1,7 +1,7 @@
 use Test2::V0;
 use Test2::Aggregate;
 
-plan(5);
+plan(7);
 
 my $root = (grep {/^\.$/i} @INC) ? undef : './';
 
@@ -23,3 +23,12 @@ Test2::Aggregate::run_tests(
     reverse      => 1,
     root         => $root
 );
+
+Test2::Aggregate::run_tests(
+    dirs          => ['xt/aggregate'],
+    load_modules  => ['Test2::V0'],
+    package       => 1,
+    reverse       => 1,
+    root          => '../',
+    relative_root => 1
+);

t/warn.t

@@ -37,8 +37,9 @@ like(
             slow => 1
         );
         Test2::Aggregate::run_tests(
-            dirs => ['xt/aggregate'],
-            root => '/xx/',
+            dirs          => ['xt/aggregate'],
+            root          => '/xx/',
+            relative_root => 1
         );
     },
     [qr/Root .* does not exist/],
@@ -86,7 +87,7 @@ done_testing;
 
 sub check_output {
     my $run  = shift;
-    my $abs  = shift;
+    my $abs  = shift || 0;
     my $msg  = shift;
     my $r    = shift || $root || '';
     my %warn = ();
@@ -111,6 +112,6 @@ sub check_output {
                 'pass_perc' => 100
             }
         },
-        "Correct output - $msg"
+        "Correct output - abs:$abs $msg"
     );
 }