File Coverage

blib/lib/IO/All/File.pm
Criterion Covered Total %
statement 122 137 89.0
branch 38 58 65.5
condition 7 15 46.6
subroutine 28 31 90.3
pod 11 18 61.1
total 206 259 79.5


line stmt bran cond sub pod time code
1 56     56   435 use strict; use warnings;
  56     56   135  
  56         1503  
  56         307  
  56         135  
  56         2240  
2             package IO::All::File;
3              
4 56     56   21050 use IO::All::Filesys -base;
  56         174  
  56         634  
5 56     56   428 use IO::All -base;
  56         142  
  56         479  
6 56     56   27040 use IO::File;
  56         104328  
  56         7043  
7 56     56   32363 use File::Copy ();
  56         118044  
  56         81010  
8              
9             #===============================================================================
10             const type => 'file';
11             field tied_file => undef;
12              
13             #===============================================================================
14             sub file {
15 336     336 1 767 my $self = shift;
16 336         705 bless $self, __PACKAGE__;
17             # should we die here if $self->name is already set and there are args?
18 336 100 100     2520 if (@_ && @_ > 1) {
    100          
19 9         55 $self->name( $self->_spec_class->catfile( @_ ) )
20             } elsif (@_) {
21 307         1148 $self->name($_[0])
22             }
23 336         1309 return $self->_init;
24             }
25              
26             sub file_handle {
27 0     0 0 0 my $self = shift;
28 0         0 bless $self, __PACKAGE__;
29 0 0       0 $self->_handle(shift) if @_;
30 0         0 return $self->_init;
31             }
32              
33             #===============================================================================
34             sub assert_filepath {
35 4     4 0 13 my $self = shift;
36 4 50       25 my $name = $self->pathname
37             or return;
38 4         11 my $directory;
39 4         26 (undef, $directory) = File::Spec->splitpath($self->pathname);
40 4         39 $self->_assert_dirpath($directory);
41             }
42              
43             sub assert_open_backwards {
44 8     8 0 17 my $self = shift;
45 8 100       25 return if $self->is_open;
46 2         17 require File::ReadBackwards;
47 2         22 my $file_name = $self->pathname;
48 2 50       19 my $io_handle = File::ReadBackwards->new($file_name)
49             or $self->throw("Can't open $file_name for backwards:\n$!");
50 2         214 $self->io_handle($io_handle);
51 2         17 $self->is_open(1);
52             }
53              
54             sub _assert_open {
55 215     215   418 my $self = shift;
56 215 100       606 return if $self->is_open;
57 101 50       467 $self->mode(shift) unless $self->mode;
58 101         338 $self->open;
59             }
60              
61             sub assert_tied_file {
62 6     6 0 12 my $self = shift;
63 6   66     23 return $self->tied_file || do {
64             eval {require Tie::File};
65             $self->throw("Tie::File required for file array operations:\n$@")
66             if $@;
67             my $array_ref = do { my @array; \@array };
68             my $name = $self->pathname;
69             my @options = $self->_rdonly ? (mode => O_RDONLY) : ();
70             push @options, (recsep => $self->separator);
71             tie @$array_ref, 'Tie::File', $name, @options;
72             $self->throw("Can't tie 'Tie::File' to '$name':\n$!")
73             unless tied @$array_ref;
74             $self->tied_file($array_ref);
75             };
76             }
77              
78             sub open {
79 116     116 1 246 my $self = shift;
80 116         393 $self->is_open(1);
81 116 100       596 $self->assert_filepath if $self->_assert;
82 116         343 my ($mode, $perms) = @_;
83 116 100       395 $self->mode($mode) if defined $mode;
84 116 100       429 $self->mode('<') unless defined $self->mode;
85 116 50       374 $self->perms($perms) if defined $perms;
86 116         362 my @args = ($self->mode);
87 116 50       495 push @args, $self->perms if defined $self->perms;
88 116 50 0     487 if (defined $self->pathname) {
    0          
89 116         779 $self->io_handle(IO::File->new);
90 116 100       402 $self->io_handle->open($self->pathname, @args)
91             or $self->throw($self->open_msg);
92             }
93             elsif (defined $self->_handle and
94             not $self->io_handle->opened
95             ) {
96             # XXX Not tested
97 0         0 $self->io_handle->fdopen($self->_handle, @args);
98             }
99 115         9713 $self->set_lock;
100 115         661 $self->_set_binmode;
101             }
102              
103 0     0 1 0 sub exists { -f shift->pathname }
104              
105             my %mode_msg = (
106             '>' => 'output',
107             '<' => 'input',
108             '>>' => 'append',
109             );
110             sub open_msg {
111 1     1 0 55 my $self = shift;
112 1 50       4 my $name = defined $self->pathname
113             ? " '" . $self->pathname . "'"
114             : '';
115             my $direction = defined $mode_msg{$self->mode}
116 1 50       4 ? ' for ' . $mode_msg{$self->mode}
117             : '';
118 1         21 return qq{Can't open file$name$direction:\n$!};
119             }
120              
121             #===============================================================================
122             sub copy {
123 1     1 1 13 my ($self, $new) = @_;
124              
125 1 50       6 File::Copy::copy($self->name, $new)
126             or die "failed to copy $self to $new: $!";
127 1         332 $self->file($new)
128             }
129              
130             sub close {
131 126     126 1 15778 my $self = shift;
132 126 100       394 return unless $self->is_open;
133 120         436 $self->is_open(0);
134 120         383 my $io_handle = $self->io_handle;
135 120         635 $self->unlock;
136 120         432 $self->io_handle(undef);
137 120         473 $self->mode(undef);
138 120 100       446 if (my $tied_file = $self->tied_file) {
139 3 100       17 if (ref($tied_file) eq 'ARRAY') {
140 1         14 untie @$tied_file;
141             }
142             else {
143 2         34 untie %$tied_file;
144             }
145 3         71 $self->tied_file(undef);
146 3         34 return 1;
147             }
148 117 50       852 $io_handle->close(@_)
149             if defined $io_handle;
150 117         4948 return $self;
151             }
152              
153             sub empty {
154 1     1 1 4 my $self = shift;
155 1         5 -z $self->pathname;
156             }
157              
158             sub filepath {
159 1     1 1 2 my $self = shift;
160 1         8 my ($volume, $path) = $self->splitpath;
161 1         48 return File::Spec->catpath($volume, $path, '');
162             }
163              
164             sub getline_backwards {
165 8     8 0 18 my $self = shift;
166 8         27 $self->assert_open_backwards;
167 8         29 return $self->io_handle->readline;
168             }
169              
170             sub getlines_backwards {
171 1     1 0 4 my $self = shift;
172 1         3 my @lines;
173 1         4 while (defined (my $line = $self->getline_backwards)) {
174 3         133 push @lines, $line;
175             }
176 1         34 return @lines;
177             }
178              
179             sub head {
180 2     2 1 3 my $self = shift;
181 2   100     8 my $lines = shift || 10;
182 2         3 my @return;
183 2         6 $self->close;
184              
185             LINES:
186 2         7 while ($lines--) {
187 15 50       33 if (defined (my $l = $self->getline)) {
188 15         36 push @return, $l;
189             }
190             else {
191 0         0 last LINES;
192             }
193             }
194              
195 2         7 $self->close;
196 2 50       25 return wantarray ? @return : join '', @return;
197             }
198              
199             sub tail {
200 0     0 1 0 my $self = shift;
201 0   0     0 my $lines = shift || 10;
202 0         0 my @return;
203 0         0 $self->close;
204 0         0 while ($lines--) {
205 0   0     0 unshift @return, ($self->getline_backwards or last);
206             }
207 0         0 $self->close;
208 0 0       0 return wantarray ? @return : join '', @return;
209             }
210              
211             sub touch {
212 2     2 1 3 my $self = shift;
213 2 100       13 return $self->SUPER::touch(@_)
214             if -e $self->pathname;
215 1 50       12 return $self if $self->is_open;
216 1         7 my $mode = $self->mode;
217 1         4 $self->mode('>>')->open->close;
218 1         4 $self->mode($mode);
219 1         4 return $self;
220             }
221              
222             sub unlink {
223 3     3 1 3697 my $self = shift;
224 3         19 unlink $self->pathname;
225             }
226              
227             #===============================================================================
228             sub _overload_table {
229 63     63   128 my $self = shift;
230             (
231 63         305 $self->SUPER::_overload_table(@_),
232             'file > file' => '_overload_file_to_file',
233             'file < file' => '_overload_file_from_file',
234             '${} file' => '_overload_file_as_scalar',
235             '@{} file' => '_overload_file_as_array',
236             '%{} file' => '_overload_file_as_dbm',
237             )
238             }
239              
240             sub _overload_file_to_file {
241 2     2   14 require File::Copy;
242 2         9 File::Copy::copy($_[1]->pathname, $_[2]->pathname);
243 2         698 $_[2];
244             }
245              
246             sub _overload_file_from_file {
247 2     2   11 require File::Copy;
248 2         7 File::Copy::copy($_[2]->pathname, $_[1]->pathname);
249 2         467 $_[1];
250             }
251              
252             sub _overload_file_as_array {
253 6     6   26 $_[1]->assert_tied_file;
254             }
255              
256             sub _overload_file_as_dbm {
257 5 50   5   34 $_[1]->dbm
258             unless $_[1]->isa('IO::All::DBM');
259 5         18 $_[1]->_assert_open;
260             }
261              
262             sub _overload_file_as_scalar {
263 10     10   68 my $scalar = $_[1]->scalar;
264 10         92 return \$scalar;
265             }
266              
267             1;