File Coverage

lib/Path/Extended/File.pm
Criterion Covered Total %
statement 158 173 91.3
branch 75 90 83.3
condition 24 34 70.5
subroutine 33 33 100.0
pod 19 19 100.0
total 309 349 88.5


line stmt bran cond sub pod time code
1             package Path::Extended::File;
2              
3 27     27   11957 use strict;
  27         47  
  27         1078  
4 27     27   142 use warnings;
  27         51  
  27         1441  
5 27     27   141 use base qw( Path::Extended::Entity );
  27         49  
  27         34061  
6 27     27   29665 use IO::Handle;
  27         230542  
  27         1432  
7 27     27   236 use Sub::Install;
  27         55  
  27         245  
8              
9             sub _initialize {
10 170     170   427 my ($self, @args) = @_;
11              
12 170         1466 my $file = File::Spec->catfile( @args );
13 170         2335 $self->{_stringify_absolute} = 1; # always true for ::Extended::File
14 170         350 $self->{is_dir} = 0;
15 170         619 $self->_set_path($file);
16             }
17              
18             sub basename {
19 18     18 1 77 my $self = shift;
20 18         98 require File::Basename;
21 18         746 return File::Basename::basename( $self->{abs_path} );
22             }
23              
24             sub open {
25 116     116 1 1449 my ($self, $mode) = @_;
26              
27 116 100       454 $self->close if $self->is_open;
28              
29 116   100     291 $mode ||= 'r';
30              
31 116         139 my $fh;
32 116 100       335 if ( $mode =~ /:/ ) {
33             open $fh, $mode, $self->_absolute
34 5 50       34 or do { $self->log( error => "Can't open $self: $!" ); return; };
  0         0  
  0         0  
35             }
36             else {
37             open $fh, IO::Handle::_open_mode_string($mode), $self->{abs_path}
38 111 50       668 or do { $self->log( error => "Can't open $self: $!" ); return; };
  0         0  
  0         0  
39             }
40              
41 116 100 100     10643 return $fh if $self->{_compat} && defined wantarray;
42              
43 105         238 $self->{handle} = $fh;
44              
45 105         322 $self;
46             }
47              
48 4     4 1 17 sub openr { shift->open('r') }
49 54     54 1 176 sub openw { shift->open('w') }
50              
51             sub sysopen {
52 2     2 1 3 my $self = shift;
53              
54 2 100       7 $self->close if $self->is_open;
55              
56             CORE::sysopen my $fh, $self->_absolute, @_
57 2 50       42 or do { $self->log( error => "Can't open $self: $!" ); return; };
  0         0  
  0         0  
58              
59 2         5 $self->{handle} = $fh;
60              
61 2         8 $self;
62             }
63              
64             sub close {
65 120     120 1 596 my $self = shift;
66              
67 120 100       472 if ( my $fh = delete $self->{handle} ) {
68 107         2639 CORE::close $fh;
69             }
70             }
71              
72             sub binmode {
73 4     4 1 8 my $self = shift;
74              
75 4 100       15 return unless $self->is_open;
76              
77 3         8 my $fh = $self->{handle};
78              
79 3 50       9 if ( @_ ) {
80 0         0 CORE::binmode $fh, shift;
81             }
82             else {
83 3         11 CORE::binmode $fh;
84             }
85             }
86              
87             BEGIN {
88 27     27   17974 my @io_methods = qw(
89             print printf say getline getlines read sysread write syswrite
90             autoflush flush printflush getc ungetc truncate blocking
91             eof fileno error sync fcntl ioctl
92             );
93              
94 27         86 foreach my $method (@io_methods) {
95             Sub::Install::install_sub({
96             as => $method,
97             code => sub {
98 96 100   96   3087 return unless $_[0]->is_open; shift->{handle}->$method(@_);
  86         1816  
99             },
100 594         26587 });
101             }
102             }
103              
104 2 100   2 1 10 sub lock_ex { return unless $_[0]->is_open; shift->_lock }
  1         5  
105 2 100   2 1 11 sub lock_sh { return unless $_[0]->is_open; shift->_lock('share') }
  1         7  
106              
107             sub _lock {
108 2     2   5 my ($self, $mode) = @_;
109              
110 2         6 my $fh = $self->{handle};
111              
112 2         22 require Fcntl;
113 2 100 66     40 flock $fh, ( $mode && $mode eq 'share' )
114             ? Fcntl::LOCK_SH()
115             : Fcntl::LOCK_EX();
116             }
117              
118             sub seek {
119 2     2 1 480 my ($self, $pos, $whence) = @_;
120              
121 2 100       8 return unless $self->is_open;
122              
123 1         4 my $fh = $self->{handle};
124              
125 1         12 seek $fh, $pos, $whence;
126             }
127              
128             sub sysseek {
129 2     2 1 7 my ($self, $pos, $whence) = @_;
130              
131 2 100       8 return unless $self->is_open;
132              
133 1         3 my $fh = $self->{handle};
134              
135 1         10 sysseek $fh, $pos, $whence;
136             }
137              
138             sub tell {
139 2     2 1 437 my $self = shift;
140              
141 2 100       14 return unless $self->is_open;
142              
143 1         3 my $fh = $self->{handle};
144              
145 1         6 tell $fh;
146             }
147              
148             sub slurp {
149 18     18 1 2547 my ($self, @args) = @_;
150              
151 18 100 66     110 my $options = ( @args == 1 and ref $args[0] eq 'HASH' )
152             ? $args[0]
153             : { @args };
154              
155 18   100     91 my $iomode = $options->{iomode} || 'r';
156 18         54 $self->open($iomode);
157 18 50       57 unless ( $self->is_open ) {
158 0         0 $self->log( warn => "Can't read", $self->{abs_path}, $! );
159 0         0 return;
160             }
161              
162 18 100       58 $self->binmode if $options->{binmode};
163 18         23 my @callbacks;
164             my $callback = sub {
165 25     25   47 my $line = shift;
166 25         41 for my $subr (@callbacks) { $line = $subr->(local $_ = $line) }
  12         70  
167 25         118 $line;
168 18         81 };
169 18 100       54 if ( $options->{chomp} ) {
170 3     7   13 push @callbacks, sub { my $line = shift; chomp $line; $line };
  7         11  
  7         16  
  7         24  
171             }
172 18 100       42 if ( $options->{decode} ) {
173 2         14 require Encode;
174             push @callbacks, sub {
175 2     2   11 Encode::decode( $options->{decode}, shift )
176 2         9 };
177             }
178 18 100       49 if ( $options->{callback} ) {
179 2         4 push @callbacks, $options->{callback};
180             }
181 18         21 my $filter;
182 18 100       53 if ( my $rule = $options->{filter} ) {
183 2         21 $filter = qr/$rule/;
184             }
185 18 50       46 $options->{ignore_return_value} = 1 if !defined wantarray;
186              
187             # shortcut
188 18 100 66     88 if (!@callbacks and !$filter and !wantarray) {
      66        
189 7         9 my $got = do { local $/; $self->getline };
  7         24  
  7         31  
190 7         371 $self->close;
191 7         77 return $got;
192             }
193              
194 11         18 my @lines;
195 11         40 while( defined (my $line = $self->getline )) {
196 25         867 $line = $callback->($line);
197 25 100 100     106 next if $filter && $line !~ /$filter/;
198 22 50       98 push @lines, $line unless $options->{ignore_return_value};
199             }
200 11         371 $self->close;
201 11 100       143 return wantarray ? @lines : join '', @lines;
202             }
203              
204             sub grep { # just a spoonful of sugar
205 2     2 1 3063 my ($self, $rule, @args) = @_;
206              
207 2 50 33     11 my $options = ( @args == 1 and ref $args[0] eq 'HASH' )
208             ? $args[0]
209             : { @args };
210              
211 2         6 $options->{filter} = $rule;
212              
213 2         7 $self->slurp($options);
214             }
215              
216             sub save {
217 32     32 1 203 my ($self, $content, @args) = @_;
218              
219 32 100 66     174 my $options = ( @args == 1 and ref $args[0] eq 'HASH' )
220             ? $args[0]
221             : { @args };
222              
223 32 100       100 if ( $options->{mkdir} ) {
224 5         38 $self->parent->mkdir;
225             }
226 32 50 33     243 my $mode = $options->{mode} || $options->{append} ? '>>' : '>';
227 32         131 $self->open($mode);
228 32 50       111 unless ( $self->is_open ) {
229 0         0 $self->log( warn => "Can't save", $self->_absolute, $! );
230 0         0 return;
231             }
232              
233 32 50       101 if ( $options->{lock} ) {
234 0 0       0 unless ( $self->lock_ex ) {
235 0         0 $self->log( warn => "Can't lock", $self->{abs_path}, $! );
236 0         0 return;
237             }
238             }
239 32 100       89 $self->binmode if $options->{binmode};
240              
241 32         45 my @callbacks;
242             my $callback = sub {
243 32     32   55 my $line = shift;
244 32         73 for my $subr (@callbacks) { $line = $subr->(local $_ = $line) }
  4         51  
245             $line
246 32         157 };
  32         223  
247 32 100       226 if ( $options->{encode} ) {
248 2         1090 require Encode;
249             push @callbacks, sub {
250 2     2   13 Encode::encode( $options->{encode}, shift )
251 2         14310 };
252             }
253 32 100       105 if ( $options->{callback} ) {
254 2         5 push @callbacks, $options->{callback};
255             }
256              
257             $self->print(
258 32         78 map { $callback->($_) }
  0         0  
259 32 50       113 ref $content eq 'ARRAY' ? @{ $content } : $content
260             );
261 32         450 $self->close;
262              
263 32 100       166 if ( $options->{mtime} ) {
264 1         5 $self->mtime( $options->{mtime} );
265             }
266              
267 32         240 $self;
268             }
269              
270             sub touch {
271 53     53 1 145 my $self = shift;
272              
273 53 100       185 if ( $self->exists ) {
274 1         10 $self->mtime(time);
275             }
276             else {
277 52 50       167 $self->openw or return;
278 52         255 $self->close;
279             }
280 53         241 $self;
281             }
282              
283 24   66 24 1 688 sub size { return -s ( $_[0]->{handle} || $_[0]->{abs_path} ) }
284              
285             sub mtime {
286 6     6 1 634 my $self = shift;
287              
288 6 100       23 return unless $self->exists;
289              
290 5 100       24 if ( @_ ) {
291 3         8 my $mtime = shift;
292 3         14 utime $mtime, $mtime, $self->_absolute;
293             }
294             else {
295 2         18 return $self->stat->mtime;
296             }
297             }
298              
299 2     2 1 1503 sub remove { shift->unlink(@_) }
300              
301             1;
302              
303             __END__