File Coverage

lib/File/DataClass/IO.pm
Criterion Covered Total %
statement 543 544 100.0
branch 229 272 85.6
condition 134 167 80.8
subroutine 139 139 100.0
pod 105 105 100.0
total 1150 1227 94.2


line stmt bran cond sub pod time code
1             package File::DataClass::IO;
2              
3 7     7   497163 use 5.010001;
  7         20  
4              
5 7     7   26 use Cwd qw( );
  7         7  
  7         93  
6 7     7   23 use English qw( -no_match_vars );
  7         5  
  7         46  
7 7     7   2223 use Fcntl qw( :flock :seek );
  7         8  
  7         855  
8 7     7   33 use File::Basename ( );
  7         8  
  7         103  
9 7     7   23 use File::Copy ( );
  7         8  
  7         153  
10 7         653 use File::DataClass::Constants qw( EXCEPTION_CLASS FALSE LOCK_BLOCKING
11             LOCK_NONBLOCKING NO_UMASK_STACK NUL
12 7     7   1657 PERMS STAT_FIELDS TILDE TRUE );
  7         13  
13 7         517 use File::DataClass::Functions qw( ensure_class_loaded first_char is_arrayref
14             is_coderef is_hashref is_member is_mswin
15 7     7   2147 is_ntfs thread_id throw );
  7         12  
16 7     7   34 use File::Spec ( );
  7         6  
  7         113  
17 7     7   22 use File::Spec::Functions qw( curdir updir );
  7         9  
  7         261  
18 7     7   3498 use IO::Dir;
  7         95783  
  7         319  
19 7     7   46 use IO::File;
  7         13  
  7         844  
20 7     7   43 use IO::Handle;
  7         12  
  7         242  
21 7     7   25 use List::Util qw( first );
  7         9  
  7         1966  
22 7     7   26 use Scalar::Util qw( blessed );
  7         9  
  7         263  
23 7     7   26 use Sub::Install qw( install_sub );
  7         8  
  7         67  
24 7     7   676 use Type::Utils qw( enum );
  7         9  
  7         66  
25 7     7   3043 use Unexpected::Functions qw( InvocantUndefined PathNotFound Unspecified );
  7         11  
  7         60  
26 7         43 use Unexpected::Types qw( ArrayRef Bool CodeRef Int Maybe Object
27 7     7   1768 PositiveInt RegexpRef SimpleStr Str );
  7         10  
28 7     7   6839 use Moo;
  7         9  
  7         54  
29              
30 7     7   2624 use namespace::clean -except => [ 'meta' ];
  7         9  
  7         68  
31 1019     1019   24374 use overload '""' => sub { $_[ 0 ]->as_string },
32 1912     1912   10769 'bool' => sub { $_[ 0 ]->as_boolean },
33 7     7   4575 'fallback' => TRUE;
  7         9  
  7         62  
34              
35             my $IO_LOCK = enum 'IO_Lock' => [ FALSE, LOCK_BLOCKING, LOCK_NONBLOCKING ];
36             my $IO_MODE = enum 'IO_Mode' => [ qw( a a+ r r+ w w+ ) ];
37             my $IO_TYPE = enum 'IO_Type' => [ qw( dir file ) ];
38              
39             # Attribute constructors
40             my $_build_dir_pattern = sub {
41 124     124   1566 my $cd = curdir; my $ud = updir; qr{ \A (?: \Q${cd}\E | \Q${ud}\E ) \z }mx;
  124         126  
  124         2152  
42             };
43              
44             my $_catfile = sub {
45             return File::Spec->catfile( map { defined( $_ ) ? $_ : NUL } @_ );
46             };
47              
48             my $_expand_tilde = sub {
49             (my $path = $_[ 0 ]) =~ m{ \A ([~] [^/\\]*) .* }mx;
50              
51             my ($dir) = glob( $1 ); $path =~ s{ \A ([~] [^/\\]*) }{$dir}mx;
52              
53             return $path;
54             };
55              
56             my $_coerce_name = sub {
57             my $name = shift;
58              
59             not defined $name and return;
60             is_coderef $name and $name = $name->();
61             blessed $name and $name = "${name}";
62             is_arrayref $name and $name = $_catfile->( @{ $name } );
63             first_char $name eq TILDE and $name = $_expand_tilde->( $name );
64             curdir eq $name and $name = Cwd::getcwd();
65             CORE::length $name > 1 and $name =~ s{ [/\\] \z }{}mx;
66             return $name;
67             };
68              
69             # Public attributes
70             has 'autoclose' => is => 'lazy', isa => Bool, default => TRUE ;
71             has 'have_lock' => is => 'rwp', isa => Bool, default => FALSE ;
72             has 'io_handle' => is => 'rwp', isa => Maybe[Object] ;
73             has 'is_open' => is => 'rwp', isa => Bool, default => FALSE ;
74             has 'mode' => is => 'rwp', isa => $IO_MODE | PositiveInt,
75             default => 'r' ;
76             has 'name' => is => 'rwp', isa => SimpleStr, default => NUL,
77             coerce => $_coerce_name, lazy => TRUE ;
78             has '_perms' => is => 'rwp', isa => PositiveInt, default => PERMS,
79             init_arg => 'perms' ;
80             has 'reverse' => is => 'lazy', isa => Bool, default => FALSE ;
81             has 'sort' => is => 'lazy', isa => Bool, default => TRUE ;
82             has 'type' => is => 'rwp', isa => Maybe[$IO_TYPE] ;
83              
84             # Private attributes
85             has '_assert' => is => 'rw', isa => Bool, default => FALSE ;
86             has '_atomic' => is => 'rw', isa => Bool, default => FALSE ;
87             has '_atomic_infix' => is => 'rw', isa => SimpleStr, default => 'B_*' ;
88             has '_backwards' => is => 'rw', isa => Bool, default => FALSE ;
89             has '_block_size' => is => 'rw', isa => PositiveInt, default => 1024 ;
90             has '_chomp' => is => 'rw', isa => Bool, default => FALSE ;
91             has '_deep' => is => 'rw', isa => Bool, default => FALSE ;
92             has '_dir_pattern' => is => 'lazy', isa => RegexpRef,
93             builder => $_build_dir_pattern ;
94             has '_filter' => is => 'rw', isa => Maybe[CodeRef] ;
95             has '_layers' => is => 'ro', isa => ArrayRef[SimpleStr],
96 588     588   80073 builder => sub { [] } ;
97             has '_lock' => is => 'rw', isa => $IO_LOCK, default => FALSE ;
98             has '_no_follow' => is => 'rw', isa => Bool, default => FALSE ;
99             has '_separator' => is => 'rw', isa => Str, default => $RS ;
100             has '_umask' => is => 'ro', isa => ArrayRef[Int],
101 588     588   52558 builder => sub { [] } ;
102              
103             # Construction
104             my @ARG_NAMES = qw( name mode perms );
105              
106             my $_clone_one_of_us = sub {
107             my ($self, $params) = @_;
108              
109             $self->autoclose; $self->reverse; $self->sort; # Force evaluation
110              
111             my $clone = { %{ $self }, %{ $params // {} } };
112             my $perms = delete $clone->{_perms}; $clone->{perms} //= $perms;
113              
114             return $clone;
115             };
116              
117             my $_constructor = sub {
118             my $self = shift; return (blessed $self)->new( @_ );
119             };
120              
121             my $_inline_args = sub {
122             my $n = shift; return (map { $ARG_NAMES[ $_ ] => $_[ $_ ] } 0 .. $n - 1);
123             };
124              
125             my $_is_one_of_us = sub {
126             return (blessed $_[ 0 ]) && $_[ 0 ]->isa( __PACKAGE__ );
127             };
128              
129             sub BUILDARGS { # Differentiate constructor method signatures
130 591     591 1 61994 my $class = shift; my $n = 0; $n++ while (defined $_[ $n ]);
  591         668  
  591         2126  
131              
132             return ( $n == 0 ) ? { io_handle => IO::Handle->new }
133             : $_is_one_of_us->( $_[ 0 ] ) ? $_clone_one_of_us->( @_ )
134 2         31 : is_hashref( $_[ 0 ] ) ? { %{ $_[ 0 ] } }
135             : ( $n == 1 ) ? { $_inline_args->( 1, @_ ) }
136 591 100       1453 : is_hashref( $_[ 1 ] ) ? { name => $_[ 0 ], %{ $_[ 1 ] } }
  345 100       5670  
    100          
    100          
    100          
    100          
    100          
137             : ( $n == 2 ) ? { $_inline_args->( 2, @_ ) }
138             : ( $n == 3 ) ? { $_inline_args->( 3, @_ ) }
139             : { @_ };
140             }
141              
142             sub BUILD {
143 590     590 1 29463 my $self = shift; my $handle = $self->io_handle;
  590         1079  
144              
145 590 100 100     8420 not $self->name and $handle and $self->_set_is_open( $handle->opened );
146              
147 590         15388 return;
148             }
149              
150             sub clone {
151 2 100   2 1 338 my ($self, @args) = @_; blessed $self or throw 'Clone is an object method';
  2         12  
152              
153 1         5 return $self->$_constructor( $self, @args );
154             }
155              
156             sub DEMOLISH {
157 589     589 1 110743 my ($self, $gd) = @_;
158              
159 589 50       1049 $gd and return; # uncoverable branch true
160 589 100       7326 $self->_atomic ? $self->delete : $self->close;
161 589         7308 return;
162             }
163              
164             sub import {
165 14     14   58 my ($class, @wanted) = @_; my $package = caller;
  14         34  
166              
167             (not defined $wanted[ 0 ] or $wanted[ 0 ] eq 'io')
168             and install_sub { into => $package, as => 'io', code => sub (;@) {
169 233     233   76482 return $class->new( @_ );
170 14 100 100     226 } };
171              
172 14         119818 return;
173             }
174              
175             # Private functions
176             my $_should_include_path = sub {
177             return (not defined $_[ 0 ] or (map { $_[ 0 ]->() } ($_[ 1 ]))[ 0 ]);
178             };
179              
180             # Private methods
181             my $_all_file_contents = sub {
182             my $self = shift; $self->is_open or $self->assert_open;
183              
184             local $RS = undef; my $content = $self->io_handle->getline;
185              
186             $self->error_check; $self->autoclose and $self->close;
187              
188             return $content;
189             };
190              
191             my $_find; $_find = sub {
192             my ($self, $files, $dirs, $level) = @_; my (@all, $io);
193              
194             my $filter = $self->_filter; my $follow = not $self->_no_follow;
195              
196             defined $level or $level = $self->_deep ? 0 : 1;
197              
198             while ($io = $self->next) {
199             my $is_dir = $io->is_dir; defined $is_dir or next;
200              
201             (($files and not $is_dir) or ($dirs and $is_dir))
202             and $_should_include_path->( $filter, $io ) and push @all, $io;
203              
204             $is_dir and ($follow or not $io->is_link) and $level != 1
205             and push @all, $io->$_find( $files, $dirs, $level ? $level - 1 : 0 );
206             }
207              
208             not $self->sort and return @all;
209              
210             return $self->reverse ? sort { $b->name cmp $a->name } @all
211             : sort { $a->name cmp $b->name } @all;
212             };
213              
214             my $_get_atomic_path = sub {
215             my $self = shift; my $path = $self->filepath; my $file;
216              
217             my $infix = $self->_atomic_infix; my $tid = thread_id;
218              
219             $infix =~ m{ \%P }mx and $infix =~ s{ \%P }{$PID}gmx;
220             $infix =~ m{ \%T }mx and $infix =~ s{ \%T }{$tid}gmx;
221              
222             if ($infix =~ m{ \* }mx) {
223             my $name = $self->filename; ($file = $infix) =~ s{ \* }{$name}mx;
224             }
225             else { $file = $self->filename.$infix }
226              
227             return $path ? $_catfile->( $path, $file ) : $file;
228             };
229              
230             my $_init = sub {
231             my ($self, $type, $name) = @_;
232              
233             $self->_set_io_handle( undef );
234             $self->_set_is_open ( FALSE );
235             $self->_set_name ( $name ) if ($name);
236             $self->_set_mode ( 'r' );
237             $self->_set_type ( $type );
238              
239             return $self;
240             };
241              
242             my $_mkdir_perms = sub { # Take file perms and add execute if read is true
243             my $perms = $_[ 1 ] || $_[ 0 ]->_perms;
244              
245             return (($perms & oct '0444') >> 2) | $perms;
246             };
247              
248             my $_push_layer = sub {
249             my ($self, $layer) = @_; $layer //= NUL;
250              
251             is_member $layer, $self->_layers and return FALSE;
252             push @{ $self->_layers }, $layer;
253             return TRUE;
254             };
255              
256             my $_sane_binmode = sub {
257             my ($self, $layer) = @_;
258              
259             blessed $self->io_handle eq 'File::ReadBackwards' and return;
260              
261 2     2   13 return $layer ? CORE::binmode( $self->io_handle, $layer )
  2         3  
  2         14  
262             : CORE::binmode( $self->io_handle );
263             };
264              
265             my $_throw = sub {
266             my $self = shift; eval { $self->unlock }; throw @_;
267             };
268              
269             my $_umask_pop = sub {
270             my $self = shift; my $perms = $self->_umask->[ -1 ];
271              
272             (defined $perms and $perms != NO_UMASK_STACK) or return umask;
273              
274             umask pop @{ $self->_umask };
275             return $perms;
276             };
277              
278             my $_umask_push = sub {
279             my ($self, $perms) = @_; $perms or return umask;
280              
281             my $first = $self->_umask->[ 0 ];
282              
283             defined $first and $first == NO_UMASK_STACK and return umask;
284              
285             $perms ^= oct '0777'; push @{ $self->_umask }, umask $perms;
286              
287             return $perms;
288             };
289              
290             my $_untainted_perms = sub {
291             my $self = shift; $self->exists or return;
292             my $stat = $self->stat // {};
293             my $mode = $stat->{mode} // NUL;
294             my $perms = $mode =~ m{ \A (\d+) \z }mx ? $1 : 0;
295              
296             return $perms & oct '07777';
297             };
298              
299             my $_assert_open_backwards = sub {
300             my ($self, @args) = @_; $self->is_open and return;
301              
302             ensure_class_loaded 'File::ReadBackwards';
303              
304             $self->_set_io_handle( File::ReadBackwards->new( $self->name, @args ) )
305             or $self->$_throw( 'File [_1] cannot open backwards: [_2]',
306             [ $self->name, $OS_ERROR ] );
307             $self->_set_is_open( TRUE );
308             $self->_set_mode( 'r' );
309             $self->set_lock;
310             $self->set_binmode;
311             return;
312             };
313              
314             my $_init_type_from_fs = sub {
315             my $self = shift;
316              
317             CORE::length $self->name or $self->$_throw( Unspecified, [ 'path name' ] );
318              
319             return -f $self->name ? $self->file : -d _ ? $self->dir : undef;
320             };
321              
322             my $_open_args = sub {
323             my ($self, $mode, $perms) = @_;
324              
325             CORE::length $self->name or $self->$_throw( Unspecified, [ 'path name' ] );
326              
327             my $pathname = $self->_atomic && !$self->is_reading( $mode )
328             ? $self->$_get_atomic_path : $self->name;
329              
330             $perms = $self->$_untainted_perms || $perms || $self->_perms;
331              
332             return ($pathname, $self->_set_mode( $mode ), $self->_set__perms( $perms ));
333             };
334              
335             my $_open_dir = sub {
336             my ($self, $path) = @_;
337              
338             $self->_assert and $self->assert_dirpath( $path );
339             $self->_set_io_handle( IO::Dir->new( $path ) )
340             or $self->$_throw( 'Directory [_1] cannot open', [ $path ] );
341             $self->_set_is_open( TRUE );
342             return $self;
343             };
344              
345             my $_open_file = sub {
346             my ($self, $path, $mode, $perms) = @_;
347              
348             $self->_assert and $self->assert_filepath; $self->$_umask_push( $perms );
349              
350             unless ($self->_set_io_handle( IO::File->new( $path, $mode ) )) {
351             $self->$_umask_pop;
352             $self->$_throw( 'File [_1] cannot open', [ $path ] );
353             }
354              
355             $self->$_umask_pop;
356             # TODO: Not necessary on normal systems
357             $self->is_writing and CORE::chmod $perms, $path;
358             $self->_set_is_open( TRUE );
359             $self->set_lock;
360             $self->set_binmode;
361             return $self;
362             };
363              
364             my $_print = sub {
365             my ($self, @args) = @_;
366              
367             for (@args) {
368             print {$self->io_handle} $_
369             or $self->$_throw( 'IO error: [_1]', [ $OS_ERROR ] );
370             }
371              
372             return $self;
373             };
374              
375             my $_rename_atomic = sub {
376             my $self = shift; my $path = $self->$_get_atomic_path; -f $path or return;
377              
378             File::Copy::move( $path, $self->name ) and return;
379              
380             is_ntfs or $self->$_throw( 'Path [_1] move to [_2] failed: [_3]',
381             [ $path, $self->name, $OS_ERROR ] );
382              
383             # Try this instead on ntfs
384             warn 'NTFS: Path '.$self->name." move failure: ${OS_ERROR}\n";
385             eval { unlink $self->name }; my $os_error;
386             File::Copy::copy( $path, $self->name ) or $os_error = $OS_ERROR;
387             eval { unlink $path };
388             $os_error and $self->$_throw( 'Path [_1] copy to [_2] failed: [_3]',
389             [ $path, $self->name, $os_error ] );
390             return;
391             };
392              
393             my $_close_and_rename = sub { # This creates a race condition
394             # uncoverable subroutine
395             my $self = shift; # uncoverable statement
396              
397             my $handle; $self->unlock;
398              
399             if ($handle = $self->io_handle) { $handle->close; delete $self->{io_handle} }
400              
401             $self->_atomic and $self->$_rename_atomic;
402              
403             return $self;
404             };
405              
406             my $_getline_backwards = sub {
407             my ($self, @args) = @_; $self->$_assert_open_backwards( @args );
408              
409             return $self->io_handle->readline;
410             };
411              
412             my $_println = sub {
413             return shift->$_print( map { m{ [\n] \z }mx ? ($_) : ($_, "\n") } @_ );
414             };
415              
416             my $_rename_and_close = sub { # This does not create a race condition
417             my $self = shift; my $handle;
418              
419             $self->_atomic and $self->$_rename_atomic; $self->unlock;
420              
421             if ($handle = $self->io_handle) { $handle->close; delete $self->{io_handle} }
422              
423             return $self;
424             };
425              
426             my $_getlines_backwards = sub {
427             my $self = shift; my (@lines, $line);
428              
429             while (defined ($line = $self->$_getline_backwards)) { push @lines, $line }
430              
431             return @lines;
432             };
433              
434             # Public methods
435             sub abs2rel {
436 48     48 1 632 return File::Spec->abs2rel( $_[ 0 ]->name, $_[ 1 ] );
437             }
438              
439             sub absolute {
440 4 100   4 1 18 my ($self, $base) = @_; $base and $base = $_coerce_name->( $base );
  4         11  
441              
442 4 100       53 $self->_set_name
443             ( (CORE::length $self->name) ? $self->rel2abs( $base ) : $base );
444 4         182 return $self;
445             }
446              
447             sub all {
448 69     69 1 261 my ($self, $level) = @_;
449              
450 69 100       164 $self->is_dir and return $self->$_find( TRUE, TRUE, $level );
451              
452 59         205 return $self->$_all_file_contents;
453             }
454              
455             sub all_dirs {
456 10     10 1 56 return $_[ 0 ]->$_find( FALSE, TRUE, $_[ 1 ] );
457             }
458              
459             sub all_files {
460 8     8 1 57 return $_[ 0 ]->$_find( TRUE, FALSE, $_[ 1 ] );
461             }
462              
463             sub append {
464 3     3 1 27 my ($self, @args) = @_;
465              
466 3 100 100     14 if ($self->is_open and not $self->is_reading) { $self->seek( 0, SEEK_END ) }
  1         4  
467 2         3 else { $self->assert_open( 'a' ) }
468              
469 3         9 return $self->$_print( @args );
470             }
471              
472             sub appendln {
473 3     3 1 8 my ($self, @args) = @_;
474              
475 3 100 100     17 if ($self->is_open and not $self->is_reading) { $self->seek( 0, SEEK_END ) }
  1         5  
476 2         5 else { $self->assert_open( 'a' ) }
477              
478 3         9 return $self->$_println( @args );
479             }
480              
481             sub as_boolean {
482 1912 100 100 1912 1 24712 return ((CORE::length $_[ 0 ]->name) || $_[ 0 ]->io_handle) ? TRUE : FALSE;
483             }
484              
485             sub as_string {
486 1019 100   1019 1 918 my $self = shift; CORE::length $self->name and return $self->name;
  1019         13617  
487              
488 1 50       18 return defined $self->io_handle ? $self->io_handle.NUL : NUL;
489             }
490              
491             sub assert {
492 3     3 1 2918 my ($self, $cb) = @_;
493              
494 3 100       9 if ($cb) {
495 2         3 local $_ = $self;
496 2 100       4 $cb->() or throw 'Path [_1] assertion failure', [ $self->name ];
497             }
498 1         21 else { $self->_assert( TRUE ) }
499              
500 2         65 return $self;
501             }
502              
503             sub assert_dirpath {
504 8     8 1 20 my ($self, $dir_name) = @_;
505              
506 8 100       18 $dir_name or return; -d $dir_name and return $dir_name;
  5 100       75  
507              
508 4         9 my $perms = $self->$_mkdir_perms; $self->$_umask_push( oct '07777' );
  4         9  
509              
510 4 100       86 unless (CORE::mkdir( $dir_name, $perms )) {
511 2         8 ensure_class_loaded 'File::Path';
512 2         609 File::Path::make_path( $dir_name, { mode => $perms } );
513             }
514              
515 3         9 $self->$_umask_pop;
516              
517             # uncoverable branch true
518 3 50       24 -d $dir_name or $self->$_throw( 'Path [_1] cannot create: [_2]',
519             [ $dir_name, $OS_ERROR ] );
520 3         7 return $dir_name;
521             }
522              
523             sub assert_filepath {
524 7     7 1 47 my $self = shift; my $dir;
  7         9  
525              
526 7 100       90 CORE::length $self->name or $self->$_throw( Unspecified, [ 'path name' ] );
527              
528 6         107 (undef, $dir) = File::Spec->splitpath( $self->name );
529              
530 6         82 $self->assert_dirpath( $dir );
531 6         13 return $self;
532             }
533              
534             sub assert_open {
535 667   100 667 1 2905 return $_[ 0 ]->open( $_[ 1 ] // 'r', $_[ 2 ] );
536             }
537              
538             sub atomic {
539 34     34 1 577 $_[ 0 ]->_atomic( TRUE ); return $_[ 0 ];
  34         701  
540             }
541              
542             sub atomic_infix {
543 2 100   2 1 23 defined $_[ 1 ] and $_[ 0 ]->_atomic_infix( $_[ 1 ] ); return $_[ 0 ];
  2         41  
544             }
545              
546             sub atomic_suffix {
547 2 100   2 1 404 defined $_[ 1 ] and $_[ 0 ]->_atomic_infix( $_[ 1 ] ); return $_[ 0 ];
  2         34  
548             }
549              
550             sub backwards {
551 2     2 1 34 $_[ 0 ]->_backwards( TRUE ); return $_[ 0 ];
  2         35  
552             }
553              
554             sub basename {
555 2 100   2 1 10 my ($self, @suffixes) = @_; CORE::length $self->name or return;
  2         24  
556              
557 1         18 return File::Basename::basename( $self->name, @suffixes );
558             }
559              
560             sub binary {
561 3     3 1 25 my $self = shift;
562              
563 3 100 100     7 $self->$_push_layer( ':raw' ) and $self->is_open and $self->$_sane_binmode;
564              
565 3         10 return $self;
566             }
567              
568             sub binmode {
569 7     7 1 12 my ($self, $layer) = @_;
570              
571 7 100 100     13 $self->$_push_layer( $layer )
572             and $self->is_open and $self->$_sane_binmode( $layer );
573              
574 7         24 return $self;
575             }
576              
577             sub block_size {
578 4 100   4 1 49 defined $_[ 1 ] and $_[ 0 ]->_block_size( $_[ 1 ] ); return $_[ 0 ];
  4         735  
579             }
580              
581             sub buffer {
582 163     163 1 117 my $self = shift;
583              
584 163 100       217 if (@_) {
585 2 100       9 my $buffer_ref = ref $_[ 0 ] ? $_[ 0 ] : \$_[ 0 ];
586              
587 2 100       4 defined ${ $buffer_ref } or ${ $buffer_ref } = NUL;
  1         4  
  2         7  
588 2         4 $self->{buffer} = $buffer_ref;
589 2         5 return $self;
590             }
591              
592 161 100       201 exists $self->{buffer} or $self->{buffer} = do { my $x = NUL; \$x };
  1         3  
  1         3  
593              
594 161         753 return $self->{buffer};
595             }
596              
597             sub canonpath {
598 2     2 1 34 return File::Spec->canonpath( $_[ 0 ]->name );
599             }
600              
601             sub catdir {
602 3     3 1 8 my ($self, @args) = @_; return $self->child( @args )->dir;
  3         10  
603             }
604              
605             sub catfile {
606 5     5 1 14 my ($self, @args) = @_; return $self->child( @args )->file;
  5         14  
607             }
608              
609             sub child {
610 10     10 1 18 my ($self, @args) = @_;
611              
612 10 100       26 my $params = (is_hashref $args[ -1 ]) ? pop @args : {};
613 10 100       144 my $args = [ grep { defined and CORE::length } $self->name, @args ];
  26         115  
614              
615 10         27 return $self->$_constructor( $args, $params );
616             }
617              
618             sub chmod {
619 4     4 1 1260 my ($self, $perms) = @_;
620              
621 4   100     20 $perms //= $self->_perms; # uncoverable condition false
622 4         74 CORE::chmod $perms, $self->name;
623 4         98 return $self;
624             }
625              
626             sub chomp {
627 5     5 1 109 $_[ 0 ]->_chomp( TRUE ); return $_[ 0 ];
  5         754  
628             }
629              
630             sub chown {
631 4     4 1 5217 my ($self, $uid, $gid) = @_;
632              
633 4 100 100     28 (defined $uid and defined $gid)
634             or $self->$_throw( Unspecified, [ 'user or group id' ] );
635              
636 2 50       41 1 == CORE::chown $uid, $gid, $self->name
637             or $self->$_throw( 'Path [_1 chown failed to [_2]/[_3]',
638             [ $self->name, $uid, $gid ] );
639 2         102 return $self;
640             }
641              
642             sub clear {
643 35     35 1 32 ${ $_[ 0 ]->buffer } = NUL; return $_[ 0 ];
  35         43  
  35         38  
644             }
645              
646             sub close {
647 892 100   892 1 12069 my $self = shift; $self->is_open or return $self;
  892         2208  
648              
649 273 50       588 if (is_ntfs) { # uncoverable branch true
650 0         0 $self->$_close_and_rename; # uncoverable statement
651 273         520 } else { $self->$_rename_and_close }
652              
653 273         6730 $self->_set_io_handle( undef );
654 273         7069 $self->_set_is_open ( FALSE );
655 273         6670 $self->_set_mode ( 'r' );
656 273         3638 return $self;
657             }
658              
659             sub copy {
660 4     4 1 69 my ($self, $to) = @_;
661              
662 4 50       12 $to or $self->$_throw( Unspecified, [ 'copy to' ] );
663              
664 4 100 100     42 (blessed $to and $to->isa( __PACKAGE__ ))
665             or $to = $self->$_constructor( $to );
666              
667 4 50       60 File::Copy::copy( $self->name, $to->pathname )
668             or $self->$_throw( 'Cannot copy [_1] to [_2]',
669             [ $self->name, $to->pathname ] );
670              
671 4         1141 return $to;
672             }
673              
674             sub cwd {
675 1     1 1 6 my $self = shift; return $self->$_constructor( Cwd::getcwd(), @_ );
  1         9  
676             }
677              
678             sub deep {
679 10     10 1 183 $_[ 0 ]->_deep( TRUE ); return $_[ 0 ];
  10         222  
680             }
681              
682             sub delete {
683 21     21 1 137 my $self = shift; my $path = $self->$_get_atomic_path;
  21         45  
684              
685 21 100 100     332 $self->_atomic and -f $path and unlink $path;
686              
687 21         493 return $self->close;
688             }
689              
690             sub delete_tmp_files {
691 2   100 2 1 480 my ($self, $tmplt) = @_; $tmplt //= '%6.6d....';
  2         11  
692              
693 2         12 my $pat = sprintf $tmplt, $PID;
694              
695 2         6 while (my $entry = $self->next) {
696 48 50       308 $entry->filename =~ m{ \A $pat \z }mx and unlink $entry->pathname;
697             }
698              
699 2         6 return $self->close;
700             }
701              
702             sub digest { # Robbed from Path::Tiny
703 4     4 1 6 my ($self, @args) = @_; my $n = 0; $n++ while (defined $args[ $n ]);
  4         5  
  4         14  
704              
705             my $args = ( $n == 0) ? { algorithm => 'SHA-256' }
706             : (is_hashref $args[ 0 ]) ? { algorithm => 'SHA-256',
707 1         6 %{ $args[ 0 ] } }
708             : ( $n == 1) ? { algorithm => $args[ 0 ] }
709             : { algorithm => $args[ 0 ],
710 4 100       15 %{ $args[ 1 ] } };
  1 100       3  
    100          
711              
712 4         12 ensure_class_loaded 'Digest'; my $digest = Digest->new( $args->{algorithm} );
  4         99  
713              
714 4 100       3298 if ($args->{block_size}) {
715 2         6 $self->binmode( ':unix' )->lock->block_size( $args->{block_size} );
716              
717 2         6 while ($self->read) { $digest->add( ${ $self->buffer } ); $self->clear; }
  20         16  
  20         24  
  20         27  
718             }
719 2         8 else { $digest->add( $self->binmode( ':unix' )->lock->all ) }
720              
721 4         54 return $digest;
722             }
723              
724             sub dir {
725 172     172 1 2876 return shift->$_init( 'dir', @_ );
726             }
727              
728             sub dirname {
729 5 50   5 1 75 return CORE::length $_[ 0 ]->name ? File::Basename::dirname( $_[ 0 ]->name )
730             : NUL;
731             }
732              
733             sub encoding {
734 4     4 1 14 my ($self, $encoding) = @_;
735              
736 4 100       14 $encoding or $self->$_throw( Unspecified, [ 'encoding value' ] );
737 3 50 33     13 $self->$_push_layer( ":encoding($encoding)" )
738             and $self->is_open and $self->$_sane_binmode( ":encoding($encoding)" );
739 3         6 return $self;
740             }
741              
742             sub error_check {
743 147     147 1 140 my $self = shift;
744              
745 147 50 33     1107 $self->io_handle->can( 'error' )
746             and $self->io_handle->error
747             and $self->$_throw( 'IO error: [_1]', [ $OS_ERROR ] );
748              
749 147         158 return $self;
750             }
751              
752             sub exists {
753 1079 100 100 1079 1 15935 return (CORE::length $_[ 0 ]->name && -e $_[ 0 ]->name) ? TRUE : FALSE;
754             }
755              
756             sub fdopen {
757 1     1 1 22 my ($self, $fd, $mode) = @_;
758              
759 1         7 $self->io_handle->fdopen( $fd, $mode );
760 1         38 $self->_set_is_open( $self->io_handle->opened );
761 1         41 $self->_set_mode( $mode );
762 1         28 $self->_set_name( NUL );
763 1         78 $self->_set_type( undef );
764 1         18 return $self;
765             }
766              
767             sub file {
768 240     240 1 4027 return shift->$_init( 'file', @_ );
769             }
770              
771             sub filename {
772 504     504 1 533 my $self = shift; my $file;
  504         394  
773              
774 504         6993 (undef, undef, $file) = File::Spec->splitpath( $self->name );
775              
776 504         7504 return $file;
777             }
778              
779             sub filepath {
780 111     111 1 159 my $self = shift; my ($volume, $dir) = File::Spec->splitpath( $self->name );
  111         1538  
781              
782 111         2046 return File::Spec->catpath( $volume, $dir, NUL );
783             }
784              
785             sub filter {
786 33 50   33 1 955 defined $_[ 1 ] and $_[ 0 ]->_filter( $_[ 1 ] ); return $_[ 0 ];
  33         430  
787             }
788              
789             sub getline {
790 19     19 1 28 my ($self, $separator) = @_;
791              
792 19 100       293 $self->_backwards and return $self->$_getline_backwards;
793              
794 18         134 my $line; $self->assert_open;
  18         29  
795              
796 18   66     24 { local $RS = $separator // $self->_separator; # uncoverable condition false
  18         262  
797 18         363 $line = $self->io_handle->getline;
798 18 50 66     652 defined $line and $self->_chomp and CORE::chomp $line;
799             }
800              
801 18         122 $self->error_check;
802 18 100       58 defined $line and return $line;
803 1 50       26 $self->autoclose and $self->close;
804 1         3 return;
805             }
806              
807             sub getlines {
808 7     7 1 609 my ($self, $separator) = @_;
809              
810 7 100       87 $self->_backwards and return $self->$_getlines_backwards;
811              
812 6         599 my @lines; $self->assert_open;
  6         12  
813              
814 6   66     12 { local $RS = $separator // $self->_separator; # uncoverable condition false
  6         90  
815 6         149 @lines = $self->io_handle->getlines;
816              
817 6 100       579 if ($self->_chomp) { CORE::chomp for @lines }
  5         88  
818             }
819              
820 6         21 $self->error_check;
821 6 100       52 scalar @lines and return (@lines);
822 1 50       16 $self->autoclose and $self->close;
823 1         5 return ();
824             }
825              
826             sub head {
827 2   100 2 1 15 my ($self, $lines) = @_; my @res; $lines //= 10; $self->close;
  2         3  
  2         9  
  2         5  
828              
829 2         6 while ($lines--) {
830 13 50       20 defined (my $l = $self->getline) or last; push @res, $l;
  13         29  
831             }
832              
833 2         4 $self->close;
834 2 50       22 return wantarray ? @res : join NUL, @res;
835             }
836              
837             sub hexdigest {
838 4     4 1 16 my ($self, @args) = @_; return $self->digest( @args )->hexdigest;
  4         9  
839             }
840              
841             sub is_absolute {
842 2     2 1 49 return File::Spec->file_name_is_absolute( $_[ 0 ]->name );
843             }
844              
845             sub is_dir {
846 674 100   674 1 2516 my $self = shift; CORE::length $self->name or return FALSE;
  674         9407  
847              
848 672 100 100     4596 $self->type or $self->$_init_type_from_fs or return FALSE;
849              
850 671 100       3677 return $self->type eq 'dir' ? TRUE : FALSE;
851             }
852              
853             sub is_empty {
854 43     43 1 60 my $self = shift; my $name = $self->name; my $empty;
  43         632  
  43         208  
855              
856 43 100       78 $self->exists or $self->$_throw( PathNotFound, [ $name ] );
857 40 100       1324 $self->is_file and return -z $name ? TRUE : FALSE;
    100          
858 2 50       5 $empty = $self->next ? FALSE : TRUE; $self->close;
  2         3  
859 2         8 return $empty;
860             }
861              
862             *empty = \&is_empty; # Deprecated
863              
864             sub is_executable {
865 3 100 100 3 1 1313 return (CORE::length $_[ 0 ]->name) && -x $_[ 0 ]->name ? TRUE : FALSE;
866             }
867              
868             sub is_file {
869 42 100   42 1 61 my $self = shift; CORE::length $self->name or return FALSE;
  42         581  
870              
871 41 100 100     351 $self->type or $self->$_init_type_from_fs or return FALSE;
872              
873 40 100       590 return $self->type eq 'file' ? TRUE : FALSE;
874             }
875              
876             sub is_link {
877 463 100 100 463 1 6941 return (CORE::length $_[ 0 ]->name) && -l $_[ 0 ]->name ? TRUE : FALSE;
878             }
879              
880             sub is_readable {
881 2 100 66 2 1 38 return (CORE::length $_[ 0 ]->name) && -r $_[ 0 ]->name ? TRUE : FALSE;
882             }
883              
884             sub is_reading {
885 96   66 96 1 592 my $mode = $_[ 1 ] // $_[ 0 ]->mode; return first { $_ eq $mode } qw( r r+ );
  61     61   448  
  61         303  
886             }
887              
888             sub is_writable {
889 5 100 66 5 1 103 return (CORE::length $_[ 0 ]->name) && -w $_[ 0 ]->name ? TRUE : FALSE;
890             }
891              
892             sub is_writing {
893 140   66 140 1 657 my $mode = $_[ 1 ] // $_[ 0 ]->mode;
894              
895 140     489   708 return first { $_ eq $mode } qw( a a+ w w+ );
  489         1857  
896             }
897              
898             sub iterator {
899 5     5 1 43 my ($self, $args) = @_;
900              
901 5 50       15 $self->is_dir
902             or $self->$_throw( "Path [_1] is not a directory", [ $self->name ] );
903              
904 5         12 my @dirs = ( $self );
905 5         68 my $filter = $self->_filter;
906 5   100     84 my $deep = $args->{recurse} // $self->_deep;
907 5   100     84 my $follow = $args->{follow_symlinks} // not $self->_no_follow;
908              
909             return sub {
910 40     40   590 while (@dirs) {
911 51         314 while (defined (my $path = $dirs[ 0 ]->next)) {
912 44 100 100     113 $deep and $path->is_dir and ($follow or not $path->is_link)
      100        
      66        
913             and unshift @dirs, $path;
914 44 100       158 $_should_include_path->( $filter, $path ) and return $path;
915             }
916              
917 15         159 shift @dirs;
918             }
919              
920 4         10 return;
921 5         49 };
922             }
923              
924             sub length {
925 53     53 1 163 return CORE::length ${ $_[ 0 ]->buffer };
  53         55  
926             }
927              
928             sub lock {
929 70   100 70 1 1470 $_[ 0 ]->_lock( $_[ 1 ] // LOCK_BLOCKING ); return $_[ 0 ];
  70         3623  
930             }
931              
932             sub mkdir {
933 2   33 2 1 29 my ($self, $perms) = @_; $perms ||= $self->$_mkdir_perms;
  2         9  
934              
935 2         5 $self->$_umask_push( oct '07777' );
936              
937 2         29 CORE::mkdir( $self->name, $perms );
938              
939 2         143 $self->$_umask_pop;
940              
941 2 50       39 -d $self->name or $self->$_throw( 'Path [_1] cannot create: [_2]',
942             [ $self->name, $OS_ERROR ] );
943 2         34 return $self;
944             }
945              
946             sub mkpath {
947 1   33 1 1 7 my ($self, $perms) = @_; $perms ||= $self->$_mkdir_perms;
  1         6  
948              
949 1         3 $self->$_umask_push( oct '07777' ); ensure_class_loaded 'File::Path';
  1         4  
950              
951 1         81 File::Path::make_path( $self->name, { mode => $perms } );
952              
953 1         345 $self->$_umask_pop;
954              
955 1 50       22 -d $self->name or $self->$_throw( 'Path [_1] cannot create: [_2]',
956             [ $self->name, $OS_ERROR ] );
957 1         19 return $self;
958             }
959              
960             sub move {
961 3     3 1 28 my ($self, $to) = @_;
962              
963 3 50       9 $to or $self->$_throw( Unspecified, [ 'move to' ] );
964              
965 3 100 100     29 (blessed $to and $to->isa( __PACKAGE__ ))
966             or $to = $self->$_constructor( $to );
967              
968 3 50       44 File::Copy::move( $self->name, $to->pathname )
969             or $self->$_throw( 'Cannot move [_1] to [_2]',
970             [ $self->name, $to->pathname ] );
971              
972 3         229 return $to;
973             }
974              
975             sub next {
976 457 100   457 1 2142 my $self = shift; defined (my $name = $self->read_dir) or return;
  457         644  
977              
978 333         4807 my $io = $self->$_constructor( [ $self->name, $name ], {
979             reverse => $self->reverse, sort => $self->sort } );
980              
981 333 100       5520 defined $self->_filter and $io->filter( $self->_filter );
982              
983 333         2480 return $io;
984             }
985              
986             sub no_follow {
987 2     2 1 31 $_[ 0 ]->_no_follow( TRUE ); return $_[ 0 ];
  2         36  
988             }
989              
990             sub open {
991 669   66 669 1 1053 my ($self, $mode, $perms) = @_; $mode //= $self->mode;
  669         1008  
992              
993 669 100 100     1930 $self->is_open
994             and first_char $mode eq first_char $self->mode
995             and return $self;
996 263 50 100     583 $self->is_open
      50        
      66        
      33        
997             and 'r' eq first_char $mode
998             and '+' eq (substr $self->mode, 1, 1) || NUL
999             and $self->seek( 0, SEEK_SET )
1000             and return $self;
1001 263 100       655 $self->type or $self->$_init_type_from_fs; $self->type or $self->file;
  262 100       990  
1002 262 100       523 $self->is_open and $self->close;
1003              
1004 262 100       425 return $self->is_dir
1005             ? $self->$_open_dir ( $self->$_open_args( $mode, $perms ) )
1006             : $self->$_open_file( $self->$_open_args( $mode, $perms ) );
1007             }
1008              
1009             sub parent {
1010 3   100 3 1 12 my ($self, $count) = @_; my $parent = $self; $count ||= 1;
  3         3  
  3         9  
1011              
1012 3         86 $parent = $self->$_constructor( $parent->dirname ) while ($count--);
1013              
1014 3         39 return $parent;
1015             }
1016              
1017             sub pathname {
1018 11     11 1 191 return $_[ 0 ]->name;
1019             }
1020              
1021             sub perms {
1022 11 50   11 1 1992 defined $_[ 1 ] and $_[ 0 ]->_set__perms( $_[ 1 ] ); return $_[ 0 ];
  11         454  
1023             }
1024              
1025             sub print {
1026 43     43 1 1422 return shift->assert_open( 'w' )->$_print( @_ );
1027             }
1028              
1029             sub println {
1030 16     16 1 507 return shift->assert_open( 'w' )->$_println( @_ );
1031             }
1032              
1033             sub read {
1034 38     38 1 400 my ($self, @args) = @_; $self->assert_open;
  38         48  
1035              
1036             my $length = @args || $self->is_dir
1037             ? $self->io_handle->read( @args )
1038 38 50 33     121 : $self->io_handle->read( ${ $self->buffer },
  38         46  
1039             $self->_block_size, $self->length );
1040              
1041 38         289 $self->error_check;
1042              
1043 38   66     134 return $length || $self->autoclose && $self->close && 0;
1044             }
1045              
1046             sub read_dir {
1047 458 100   458 1 314 my $self = shift; $self->type or $self->dir; $self->assert_open;
  458         921  
  458         595  
1048              
1049 457 50 66     956 $self->is_link and $self->_no_follow and $self->close and return;
      33        
1050              
1051 457         21046 my $dir_pat = $self->_dir_pattern; my $name;
  457         3304  
1052              
1053 457 100       785 if (wantarray) {
1054 1         6 my @names = grep { $_ !~ $dir_pat } $self->io_handle->read;
  7         27  
1055              
1056 1         3 $self->close; return @names;
  1         5  
1057             }
1058              
1059 456   100     850 while (not defined $name or $name =~ $dir_pat) {
1060 704 100       4143 unless (defined ($name = $self->io_handle->read)) {
1061 123         892 $self->close; return;
  123         517  
1062             }
1063             }
1064              
1065 333         3889 return $name;
1066             }
1067              
1068             sub rel2abs {
1069 4     4 1 31 my ($self, $base) = @_;
1070              
1071 4 100       52 return File::Spec->rel2abs( $self->name, defined $base ? "${base}" : undef );
1072             }
1073              
1074             sub relative {
1075 47     47 1 600 $_[ 0 ]->_set_name( $_[ 0 ]->abs2rel ); return $_[ 0 ];
  47         1889  
1076             }
1077              
1078             sub reset {
1079 1     1 1 3 my $self = shift; $self->close;
  1         4  
1080              
1081 1         13 $self->_assert( FALSE ); $self->_atomic( FALSE ); $self->_chomp ( FALSE );
  1         31  
  1         28  
1082 1         32 $self->_deep ( FALSE ); $self->_lock ( FALSE ); $self->_no_follow( FALSE );
  1         59  
  1         34  
1083 1         23 return $self;
1084             }
1085              
1086             sub rmdir {
1087 2     2 1 18 my $self = shift;
1088              
1089 2 100       40 CORE::rmdir $self->name
1090             or $self->$_throw( 'Path [_1] not removed: [_2]',
1091             [ $self->name, $OS_ERROR ] );
1092 1         70 return $self;
1093             }
1094              
1095             sub rmtree {
1096 2     2 1 13 my ($self, @args) = @_; ensure_class_loaded 'File::Path';
  2         8  
1097              
1098 2         105 return File::Path::remove_tree( $self->name, @args );
1099             }
1100              
1101             sub seek {
1102 5     5 1 52 my ($self, $posn, $whence) = @_;
1103              
1104 5 50       17 $self->is_open or $self->assert_open( is_mswin ? 'r' : 'r+' );
    100          
1105 5         46 CORE::seek $self->io_handle, $posn, $whence; $self->error_check;
  5         14  
1106 5         7 return $self;
1107             }
1108              
1109             sub separator {
1110 1 50   1 1 18 defined $_[ 1 ] and $_[ 0 ]->_separator( $_[ 1 ] ); return $_[ 0 ];
  1         17  
1111             }
1112              
1113             sub set_binmode {
1114 144     144 1 180 my $self = shift;
1115              
1116 144 50       328 is_ntfs and $self->$_push_layer(); # uncoverable branch true
1117              
1118 144         171 $self->$_sane_binmode( $_ ) for (@{ $self->_layers });
  144         456  
1119              
1120 144         17208 return $self;
1121             }
1122              
1123             sub set_lock {
1124 144 100   144 1 158 my $self = shift; $self->_lock or return;
  144         2061  
1125              
1126 67 100       1149 my $async = $self->_lock == LOCK_NONBLOCKING ? TRUE : FALSE;
1127 67 100       422 my $mode = $self->mode eq 'r' ? LOCK_SH : LOCK_EX;
1128              
1129 67 100       155 $async and $mode |= LOCK_NB;
1130 67 50       1480 $self->_set_have_lock( (flock $self->io_handle, $mode) ? TRUE : FALSE );
1131 67         2576 return $self;
1132             }
1133              
1134             sub sibling {
1135 1     1 1 7 my $self = shift; return $self->parent->child( @_ );
  1         4  
1136             }
1137              
1138             sub slurp {
1139 13     13 1 46 my $self = shift; my $slurp = $self->all;
  13         26  
1140              
1141 12 100       59 wantarray or return $slurp; local $RS = $self->_separator;
  2         21  
1142              
1143 2 50       620 $self->_chomp or return split m{ (?<=\Q$RS\E) }mx, $slurp;
1144              
1145 2         3742 return map { CORE::chomp; $_ } split m{ (?<=\Q$RS\E) }mx, $slurp;
  1450         807  
  1450         1177  
1146             }
1147              
1148             sub splitdir {
1149 1     1 1 37 return File::Spec->splitdir( $_[ 0 ]->name );
1150             }
1151              
1152             sub splitpath {
1153 1     1 1 20 return File::Spec->splitpath( $_[ 0 ]->name );
1154             }
1155              
1156             sub stat {
1157 347 100 66 347 1 1269 my $self = shift; $self->exists or $self->is_open or return;
  347         523  
1158              
1159 345         11308 my %stat_hash = ( id => $self->filename );
1160              
1161 345 50       568 @stat_hash{ STAT_FIELDS() }
1162             = stat( $self->exists ? $self->name : $self->io_handle );
1163              
1164 345         1379 return \%stat_hash;
1165             }
1166              
1167             sub substitute {
1168 4   100 4 1 12 my ($self, $search, $replace) = @_; $replace //= NUL;
  4         13  
1169              
1170 4 100 100     27 (defined $search and CORE::length $search) or return $self;
1171              
1172 2         6 my $perms = $self->$_untainted_perms;
1173 2         29 my $wtr = $self->$_constructor( $self->name )->atomic;
1174              
1175 2 50       9 $perms and $wtr->perms( $perms );
1176              
1177 2         5 for ($self->getlines) { s{ $search }{$replace}gmx; $wtr->print( $_ ) }
  6         34  
  6         10  
1178              
1179 2         6 $self->close; $wtr->close;
  2         4  
1180 2         27 return $self;
1181             }
1182              
1183             sub tail {
1184 3   100 3 1 19 my ($self, $lines, @args) = @_; my @res; $lines //= 10; $self->close;
  3         4  
  3         13  
  3         5  
1185              
1186 3         8 while ($lines--) {
1187 14   50     291 unshift @res, ($self->$_getline_backwards( @args ) or last);
1188             }
1189              
1190 2         17 $self->close;
1191 2 50       16 return wantarray ? @res : join NUL, @res;
1192             }
1193              
1194             sub tell {
1195 3     3 1 6 my $self = shift;
1196              
1197 3 0       8 $self->is_open or $self->assert_open( is_mswin ? 'r' : 'r+' );
    50          
1198              
1199 3         13 return CORE::tell $self->io_handle;
1200             }
1201              
1202             sub tempfile {
1203 2     2 1 27 my ($self, $tmplt) = @_; my $tempdir;
  2         3  
1204              
1205 2   50     10 ensure_class_loaded 'File::Temp'; $tmplt ||= '%6.6dXXXX';
  2         90  
1206              
1207 2 100 66     30 ($tempdir = $self->name and -d $tempdir) or $tempdir = File::Spec->tmpdir;
1208              
1209 2         66 my $tmpfh = File::Temp->new
1210             ( DIR => $tempdir, TEMPLATE => (sprintf $tmplt, $PID) );
1211 2         918 my $t = $self->$_constructor( $tmpfh->filename )->file;
1212              
1213 2         29 $t->_set_io_handle( $tmpfh ); $t->_set_is_open( TRUE );
  2         44  
1214 2         43 $t->_set_mode( 'w+' );
1215 2         25 return $t;
1216             }
1217              
1218             sub touch {
1219 7 50 66 7 1 57 my ($self, $time) = @_; CORE::length $self->name or return; $time //= time;
  7         102  
  7         66  
1220              
1221 7 50       92 -e $self->name or $self->$_open_file( $self->$_open_args( 'w' ) )->close;
1222              
1223 7         95 utime $time, $time, $self->name;
1224 7         140 return $self;
1225             }
1226              
1227             sub unlink {
1228 27     27 1 2214 return unlink $_[ 0 ]->name;
1229             }
1230              
1231             sub unlock {
1232 286 100   286 1 343 my $self = shift; $self->_lock or return; my $handle = $self->io_handle;
  286         3947  
  69         427  
1233              
1234 69 100 66     313 $handle and $handle->opened and flock $handle, LOCK_UN;
1235 69         2634 $self->_set_have_lock( FALSE );
1236 69         1505 return $self;
1237             }
1238              
1239             sub utf8 {
1240 1     1 1 4 $_[ 0 ]->encoding( 'UTF-8' ); return $_[ 0 ];
  1         5  
1241             }
1242              
1243             sub visit {
1244 1     1 1 13 my ($self, $cb, $args) = @_;
1245              
1246 1         5 my $iter = $self->iterator( $args ); my $state = {};
  1         2  
1247              
1248 1         4 while (defined (my $entry = $iter->())) {
1249 9         9 local $_ = $entry; my $r = $cb->( $entry, $state );
  9         17  
1250              
1251 9 100 100     55 ref $r and not ${ $r } and last;
  8         79  
1252             }
1253              
1254 1         20 return $state;
1255             }
1256              
1257             sub write {
1258 15     15 1 47 my ($self, @args) = @_; $self->assert_open( 'w' );
  15         18  
1259              
1260             my $length = @args
1261             ? $self->io_handle->write( @args )
1262 15 50       35 : $self->io_handle->write( ${ $self->buffer }, $self->length );
  15         20  
1263              
1264 15 50       364 $self->error_check; scalar @args or $self->clear;
  15         38  
1265 15         27 return $length;
1266             }
1267              
1268             # Method installer
1269             my $_proxy = sub { # Methods handled by the IO::Handle object
1270             my ($proxy, $chain, $mode) = @_;
1271              
1272             my $package = caller; $package->can( $proxy ) and return;
1273              
1274             install_sub { into => $package, as => $proxy, code => sub {
1275 9 100   9   2155 my $self = shift; defined $mode and $self->assert_open( $mode );
  9         24  
1276              
1277 9 100       31 defined $self->io_handle or throw InvocantUndefined, [ $proxy ];
1278              
1279 8         63 my @results = $self->io_handle->$proxy( @_ ); # Mustn't copy stack args
1280              
1281 8 100       194 $self->error_check; $chain and return $self;
  8         30  
1282              
1283 7 50       33 return wantarray ? @results : $results[ 0 ];
1284             } };
1285             };
1286              
1287             $_proxy->( 'autoflush', TRUE );
1288             $_proxy->( 'eof' );
1289             $_proxy->( 'fileno' );
1290             $_proxy->( 'flush', TRUE );
1291             $_proxy->( 'getc', FALSE, 'r' );
1292             $_proxy->( 'sysread', FALSE, O_RDONLY );
1293             $_proxy->( 'syswrite', FALSE, O_CREAT | O_WRONLY );
1294             $_proxy->( 'truncate', TRUE );
1295              
1296             1;
1297              
1298             __END__