File Coverage

blib/lib/File/Symlink/Relative.pm

Criterion	Covered	Total	%
statement	28	28	100.0
branch	1	2	50.0
condition	2	5	40.0
subroutine	9	9	100.0
pod	1	1	100.0
total	41	45	91.1

package File::Symlink::Relative;

use 5.008001;

use strict;
use warnings;

# OK, the following is probably paranoia. But if Perl 7 decides to
# change this particular default I'm ready. Unless they eliminate $].
no if $] ge '5.020', feature => qw{ signatures };

use Carp;
use Exporter qw{ import };
use File::Spec;

our $VERSION = '0.004_01';

our @EXPORT_OK = qw{
    symlink_r
    SYMLINK_SUPPORTED
};
our @EXPORT = qw{ symlink_r };	## no critic (ProhibitAutomaticExportation)
our %EXPORT_TAGS = (
    all	=> \@EXPORT_OK,
);

{
    local $@ = undef;

    # This is true if and only if symbolic links are supported by the
    # underlying operating system. The check is from
    #     perldoc -f symlink
    # in Perl 5.30.2.

    use constant SYMLINK_SUPPORTED => eval { symlink '', ''; 1 } || 0;
}

sub symlink_r ($$) {	## no critic (ProhibitSubroutinePrototypes)
    my ( $source, $target ) = @_;
    my ( $tgt_device, $tgt_dir ) = File::Spec->splitpath( $target );
    defined $tgt_device
	and '' ne $tgt_device
	and $tgt_dir = File::Spec->catdir( $tgt_device, $tgt_dir );
    my $relative = File::Spec->abs2rel( $source, $tgt_dir );
    return symlink $relative, $target;
}

1;

__END__