add Directory::relative::to

CHANGELOG

@@ -1 +1,7 @@
+1.1000   2022-05-12
+
+- add Directory::relative::to which provides the same functionality
+  but returning fully-qualified directory names instead of sticking
+  them in @INC
+
 1.0000   2020-02-20   First release

MANIFEST

@@ -21,3 +21,4 @@ t/fakesvncheckout/trunk/t/svn-checkout.t
 t/fakesvncheckout/trunk/.svn/entries
 MANIFEST.SKIP
 t/fakesvncheckout/trunk/lib/placeholder
+lib/Directory/relative/to.pm

lib/Directory/relative/to.pm

@@ -0,0 +1,131 @@
+package Directory::relative::to;
+
+use strict;
+use warnings;
+
+use lib::relative::to ();
+
+use Cwd;
+use Exporter 'import';
+
+our @EXPORT_OK = qw(relative_dir);
+our $VERSION = '1.1000';
+
+=head1 NAME
+
+Directory::relative::to
+
+=head1 DESCRIPTION
+
+Find paths relative to something else
+
+=head1 SYNOPSIS
+
+Both of these will look up through the parent directories of the file that
+contains this code until it finds the root of a git repository, then return
+the absolute paths of the 'lib' and 't/lib' directories in that repository.
+
+    use Directory::relative::to (relative_dir);
+
+    my @dirs = relative_dir( GitRepository => qw(lib t/lib) );
+
+or:
+
+    use Directory::relative::to;
+
+    my @dirs = Directory::relative::to->relative_dir(
+        ParentContaining => '.git/config' => qw(lib t/lib)
+    );
+
+Yes, it's practically identical to how you'd invoke C<lib::relative::to>.
+This module is just a very thin wrapper around that.
+
+=head1 WHY?
+
+Just like how I got fed up with Sam for the reasons explained in
+L<lib::relative::to> I have a new colleague who wrote:
+
+    use FindBin qw($Bin);
+    ...
+    my $fixture_path = "$Bin/../../fixtures";
+
+That string of repeated C<../>s is an abomination unto the Lord.
+
+=head1 FUNCTIONS
+
+=head2 relative_dir
+
+Can be invoked either as a class method or can I<optionally> be exported
+and called as a normal function.
+
+This takes the several arguments, the first of which is the name of a
+C<lib::relative::to> plugin, the remainder being arguments to that plugin.
+In general the argument list will take the form:
+
+=over
+
+=item plugin_name
+
+=item plugin_configuration
+
+=item list_of_directories
+
+=back
+
+Note that under the bonnet this function uses L<lib::relative::to>'s undocumented private functions.
+
+It normally returns a list of fully-qualified directory names,
+but if there is only one directory to be returned and you call
+it in scalar context you will get a scalar name.
+
+If there aer multiple directory names but you use scalar
+context that is a fatal error.
+
+=cut
+
+sub relative_dir {
+    shift if($_[0] eq __PACKAGE__);
+    my($plugin, @plugin_args) = @_;
+
+    # l::r::to needs to know where *this code* is being called
+    # from instead of from where *it* is called.
+    $lib::relative::to::called_from = Cwd::abs_path((caller(0))[1]);
+    my @results = lib::relative::to->_load_plugin($plugin)
+                                   ->_find(@plugin_args);
+
+    # this isn't done on function entry cos we might want to
+    # throw exceptions because the user did something silly
+    return if(!defined(wantarray));
+
+    if(@results > 1 && !wantarray) {
+        die(__PACKAGE__.": Multiple results but you wanted a scalar\n");
+    }
+
+    return wantarray ? @results : $results[0];
+}
+
+1;
+
+=head1 BUGS
+
+I only have access to Unix machines for development and debugging. There may be
+bugs lurking that affect users of exotic platforms like Amiga, Windows, and
+VMS. I welcome patches, preferably in the form of a pull request. Ideally any
+patches will be accompanied by tests, and those tests will either skip or pass
+on Unix.
+
+=head1 AUTHOR, COPYRIGHT and LICENCE
+
+Copyright 2022 David Cantrell E<lt>david@cantrell.org.ukE<gt>.
+
+This software is free-as-in-speech as well as free-as-in-beer, and may be used,
+distributed, and modified under the terms of either the GNU General Public
+Licence version 2 or the Artistic Licence. It's up to you which one you use.
+The full text of the licences can be found in the files GPL2.txt and
+ARTISTIC.txt, respectively.
+
+=head1 CONSPIRACY
+
+This software is also free-as-in-mason.
+
+=cut

lib/lib/relative/to.pm

@@ -8,7 +8,7 @@ use File::Spec;
 
 use lib ();
 
-our $VERSION = '1.0000';
+our $VERSION = '1.1000';
 our $called_from;
 
 sub import {
@@ -19,6 +19,7 @@ sub import {
     return unless($class eq __PACKAGE__);
 
     $called_from = Cwd::abs_path((caller(0))[1]);
+
     lib->import(
         $class->_load_plugin($plugin)
               ->_find(@plugin_args)
@@ -50,13 +51,13 @@ lib::relative::to
 
 =head1 DESCRIPTION
 
-Add a path to C<@INC> that is relative to something else
+Add paths to C<@INC> that is relative to something else
 
 =head1 SYNOPSIS
 
 Both of these will look up through the parent directories of the file that
 contains this code until it finds the root of a git repository, then add the
-'lib' directory in that repository's root to C<@INC>.
+'lib' and 't/lib' directories in that repository's root to C<@INC>.
 
     use lib::relative::to
         GitRepository => qw(lib t/lib);
@@ -120,7 +121,7 @@ In general the argument list takes the form:
 
 =back
 
-and the plugin will use the C<plugin_argument> to add C<list_of_directories> to
+and the plugin will use the C<plugin_configuration> to add C<list_of_directories> to
 C<@INC>. In the L</SYNOPSIS> above you can see that
 L<ParentContaining|lib::relative::to::ParentContaining> and
 L<GitRepository|lib::relative::to::GitRepository> are plugins, that

t/fakegitrepo/t/git-repo.t

@@ -38,6 +38,8 @@ use Test::More;
 
 use lib::relative::to GitRepository => 'lib';
 
+use Directory::relative::to qw(relative_dir);
+
 my $lookfor = abs_path(File::Spec->catdir(
     cwd(),
     qw(t fakegitrepo lib)
@@ -49,4 +51,10 @@ ok(
     "Found '$lookfor' in \@INC"
 ) || diag('@INC contains ['.join(', ', @INC).']');
 
+is_deeply(
+    [relative_dir( GitRepository => 'lib' )],
+    [$lookfor],
+    "relative_dir() returns the correct directories"
+);
+
 done_testing();

t/fakehgrepo/t/hg-repo.t

@@ -6,17 +6,66 @@ use File::Spec;
 
 use lib::relative::to HgRepository => 'lib';
 
+# No import, we test class method invocation in this file.
+# We also test returning multiple dirs in this file, but don't
+# bother in the others, and likewise test that @INC isn't polluted, and that scalar/list sensitivity matters.
+
+use Directory::relative::to;
+
 use Test::More;
+use Test::Exception;
 
-my $lookfor = abs_path(File::Spec->catdir(
-    cwd(),
-    qw(t fakehgrepo lib)
-));
+my @lookfor = map {
+    my $l = $_;
+    $l =~ s/\//\\/g if($l =~ /^[A-Z]:\//);
+    $l;
+} (
+    abs_path(File::Spec->catdir(
+        cwd(),
+        qw(t fakehgrepo lib)
+    )),
+    abs_path(File::Spec->catdir(
+        cwd(),
+        qw(t fakehgrepo t)
+    ))
+);
 
-$lookfor =~ s/\//\\/g if($lookfor =~ /^[A-Z]:\//);;
 ok(
-    (grep { $_ eq $lookfor } @INC),
-    "Found '$lookfor' in \@INC"
+    (grep { $_ eq $lookfor[0] } @INC),
+    "Found '$lookfor[0]' in \@INC"
 ) || diag('@INC contains ['.join(', ', @INC).']');
 
+my $count = 0;
+$count++ foreach(grep { $_ eq $lookfor[0] } @INC);
+ok($count == 1, "$lookfor[0] was added to \@INC once");
+
+is_deeply(
+    [Directory::relative::to->relative_dir( HgRepository => qw(lib t) )],
+    \@lookfor,
+    "Directory::relative::to->relative_dir returns the correct directories"
+);
+
+$count = 0;
+$count++ foreach(grep { $_ eq $lookfor[0] } @INC);
+ok($count == 1, "$lookfor[0] was not added to \@INC again");
+
+is(
+    scalar(Directory::relative::to->relative_dir( HgRepository => 'lib' )),
+    $lookfor[0],
+    "in scalar context relative_dir can return a single item"
+);
+
+throws_ok {
+    scalar(Directory::relative::to->relative_dir( HgRepository => qw(lib t) ))
+} qr/Multiple results/, "scalar context, multiple results == EXPLOSM";
+
+is(
+    do {
+        Directory::relative::to->relative_dir( HgRepository => qw(lib t) );
+        "i like pie"
+    },
+    "i like pie",
+    "in void context relative_dir doesn't care"
+);
+
 done_testing();

t/fakesvncheckout/trunk/t/svn-checkout.t

@@ -6,6 +6,8 @@ use File::Spec;
 
 use lib::relative::to SvnCheckout => 'lib';
 
+use Directory::relative::to qw(relative_dir);
+
 use Test::More;
 
 my $lookfor = abs_path(File::Spec->catdir(
@@ -19,4 +21,10 @@ ok(
     "Found '$lookfor' in \@INC"
 ) || diag('@INC contains ['.join(', ', @INC).']');
 
+is_deeply(
+    [relative_dir( SvnCheckout => 'lib' )],
+    [$lookfor],
+    "relative_dir() returns the correct directories"
+);
+
 done_testing();

t/parentcontaining-failure.t

@@ -6,9 +6,16 @@ use Test::Exception;
 
 use lib::relative::to;
 
+use Directory::relative::to qw(relative_dir);
+
 throws_ok {
     lib::relative::to->import(ParentContaining => '!/@/#/\\/', 'hlagh')
 } qr/in any parent directory.*parentcontaining-failure.t/, "caught failure" ||
 note($@);
 
+throws_ok {
+    relative_dir(ParentContaining => '!/@/#/\\/', 'hlagh')
+} qr/in any parent directory.*parentcontaining-failure.t/, "caught failure in Directory::relative::to" ||
+note($@);
+
 done_testing();

t/use.t

@@ -11,10 +11,14 @@ use_ok('lib::relative::to::HgRepository');
 use_ok('lib::relative::to::GitRepository');
 use_ok('lib::relative::to::ParentContaining');
 use_ok('lib::relative::to');
+use_ok('Directory::relative::to');
 
 # and now try to use something ridiculous
 throws_ok {
     lib::relative::to->import('ZZZ::NonExistentPlugin');
-} qr/Can't locate/, "non-existent plugins can't be loaded";
+} qr/Can't locate/, "non-existent plugins can't be loaded by l::r::to";
+throws_ok {
+    Directory::relative::to->relative_dir('ZZZ::NonExistentPlugin');
+} qr/Can't locate/, "... and D::r::to throws the right error as well";
 
 done_testing();