File Coverage

blib/lib/IO/All/Link.pm
Criterion Covered Total %
statement 31 41 75.6
branch 7 18 38.8
condition n/a
subroutine 7 9 77.7
pod 3 5 60.0
total 48 73 65.7


line stmt bran cond sub pod time code
1 5     5   1705 use strict; use warnings;
  5     5   9  
  5         182  
  5         22  
  5         6  
  5         219  
2             package IO::All::Link;
3              
4 5     5   1173 use IO::All::File -base;
  5         7  
  5         53  
5              
6             const type => 'link';
7              
8             sub link {
9 9     9 1 7 my $self = shift;
10 9         17 bless $self, __PACKAGE__;
11 9 50       46 $self->name(shift) if @_;
12 9         23 $self->_init;
13             }
14              
15             sub readlink {
16 3     3 1 5 my $self = shift;
17 3         7 $self->_constructor->(CORE::readlink($self->name));
18             }
19              
20             sub symlink {
21 0     0 0 0 my $self = shift;
22 0         0 my $target = shift;
23 0 0       0 $self->assert_filepath if $self->_assert;
24 0         0 CORE::symlink($target, $self->pathname);
25             }
26              
27             sub AUTOLOAD {
28 2     2   11 my $self = shift;
29 2         2 our $AUTOLOAD;
30 2         12 (my $method = $AUTOLOAD) =~ s/.*:://;
31 2         5 my $target = $self->target;
32 2 50       4 unless ($target) {
33 0         0 $self->throw("Can't call $method on symlink");
34 0         0 return;
35             }
36 2         8 $target->$method(@_);
37             }
38              
39             sub target {
40 2     2 0 3 my $self = shift;
41 2 100       11 return *$self->{target} if *$self->{target};
42 1         1 my %seen;
43 1         1 my $link = $self;
44 1         2 my $new;
45 1         2 while ($new = $link->readlink) {
46 1 50       4 my $type = $new->type or return;
47 1 50       4 last if $type eq 'file';
48 1 50       3 last if $type eq 'dir';
49 0 0       0 return unless $type eq 'link';
50 0 0       0 return if $seen{$new->name}++;
51 0         0 $link = $new;
52             }
53 1         156 *$self->{target} = $new;
54             }
55              
56 0     0 1   sub exists { -l shift->pathname }
57              
58             1;