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


line stmt bran cond sub pod time code
1             package File::Symlink::Relative;
2              
3 2     2   18806 use 5.008001;
  2         14  
4              
5 2     2   11 use strict;
  2         4  
  2         39  
6 2     2   9 use warnings;
  2         4  
  2         84  
7              
8             # OK, the following is probably paranoia. But if Perl 7 decides to
9             # change this particular default I'm ready. Unless they eliminate $].
10 2     2   717 no if $] ge '5.020', feature => qw{ signatures };
  2         18  
  2         13  
11              
12 2     2   317 use Carp;
  2         4  
  2         154  
13 2     2   13 use Exporter qw{ import };
  2         3  
  2         79  
14 2     2   12 use File::Spec;
  2         4  
  2         287  
15              
16             our $VERSION = '0.004';
17              
18             our @EXPORT_OK = qw{
19             symlink_r
20             SYMLINK_SUPPORTED
21             };
22             our @EXPORT = qw{ symlink_r }; ## no critic (ProhibitAutomaticExportation)
23             our %EXPORT_TAGS = (
24             all => \@EXPORT_OK,
25             );
26              
27             {
28             local $@ = undef;
29              
30             # This is true if and only if symbolic links are supported by the
31             # underlying operating system. The check is from
32             # perldoc -f symlink
33             # in Perl 5.30.2.
34              
35 2   50 2   14 use constant SYMLINK_SUPPORTED => eval { symlink '', ''; 1 } || 0;
  2         4  
  2         3  
36             }
37              
38             sub symlink_r ($$) { ## no critic (ProhibitSubroutinePrototypes)
39 1     1 1 899 my ( $source, $target ) = @_;
40 1         35 my ( $tgt_device, $tgt_dir ) = File::Spec->splitpath( $target );
41 1 50 33     11 defined $tgt_device
42             and '' ne $tgt_device
43             and $tgt_dir = File::Spec->catdir( $tgt_device, $tgt_dir );
44 1         85 my $relative = File::Spec->abs2rel( $source, $tgt_dir );
45 1         59 return symlink $relative, $target;
46             }
47              
48             1;
49              
50             __END__