File Coverage

blib/lib/Path/Tiny.pm

Criterion	Covered	Total	%
statement	668	717	93.1
branch	390	476	81.9
condition	152	212	71.7
subroutine	104	106	98.1
pod	63	64	98.4
total	1377	1575	87.4

line	stmt	bran	cond	sub	pod	time	code
1	29			29		2502247	use 5.008001;
	29					406
2	29			29		173	use strict;
	29					55
	29					640
3	29			29		151	use warnings;
	29					55
	29					1690
4
5							package Path::Tiny;
6							# ABSTRACT: File path utility
7
8							our $VERSION = '0.142';
9
10							# Dependencies
11	29			29		183	use Config;
	29					58
	29					1495
12	29			29		187	use Exporter 5.57 (qw/import/);
	29					397
	29					1159
13	29			29		179	use File::Spec 0.86 (); # shipped with 5.8.1
	29					452
	29					558
14	29			29		137	use Carp ();
	29					71
	29					2240
15
16							our @EXPORT = qw/path/;
17							our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/;
18
19							use constant {
20	29					5026	PATH => 0,
21							CANON => 1,
22							VOL => 2,
23							DIR => 3,
24							FILE => 4,
25							TEMP => 5,
26							IS_WIN32 => ( $^O eq 'MSWin32' ),
27	29			29		187	};
	29					73
28
29							use overload (
30							q{""} => 'stringify',
31							bool => sub () { 1 },
32	29					191	fallback => 1,
33	29			29		3762	);
	29					2996
34
35							# FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol
36	2			2	0	6	sub THAW { return path( $_[2] ) }
37	29			29		3736	{ no warnings 'once'; TO_JSON = FREEZE = \&stringify };
	29					59
	29					15485
38
39							my $HAS_UU; # has Unicode::UTF8; lazily populated
40
41							sub _check_UU {
42	4			4		21	local $SIG{__DIE__}; # prevent outer handler from being called
43	4					10	!!eval {
44	4					884	require Unicode::UTF8;
45	1					592	Unicode::UTF8->VERSION(0.58);
46	1					12	1;
47							};
48							}
49
50							my $HAS_PU; # has PerlIO::utf8_strict; lazily populated
51
52							sub _check_PU {
53	4			4		2402	local $SIG{__DIE__}; # prevent outer handler from being called
54	4					11	!!eval {
55							# MUST preload Encode or $SIG{__DIE__} localization fails
56							# on some Perl 5.8.8 (maybe other 5.8.*) compiled with -O2.
57	4					1228	require Encode;
58	4					43638	require PerlIO::utf8_strict;
59	0					0	PerlIO::utf8_strict->VERSION(0.003);
60	0					0	1;
61							};
62							}
63
64							my $HAS_FLOCK = $Config{d_flock} \|\| $Config{d_fcntl_can_lock} \|\| $Config{d_lockf};
65
66							# notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \
67							my $SLASH = qr{[\\/]};
68							my $NOTSLASH = qr{[^\\/]};
69							my $DRV_VOL = qr{[a-z]:}i;
70							my $UNC_VOL = qr{$SLASH $SLASH $NOTSLASH+ $SLASH $NOTSLASH+}x;
71							my $WIN32_ROOT = qr{(?: $UNC_VOL $SLASH \| $DRV_VOL $SLASH \| $SLASH )}x;
72
73							sub _win32_vol {
74	0			0		0	my ( $path, $drv ) = @_;
75	0					0	require Cwd;
76	0					0	my $dcwd = eval { Cwd::getdcwd($drv) }; # C: -> C:\some\cwd
	0					0
77							# getdcwd on non-existent drive returns empty string
78							# so just use the original drive Z: -> Z:
79	0	0	0			0	$dcwd = "$drv" unless defined $dcwd && length $dcwd;
80							# normalize dwcd to end with a slash: might be C:\some\cwd or D:\ or Z:
81	0					0	$dcwd =~ s{$SLASH?\z}{/};
82							# make the path absolute with dcwd
83	0					0	$path =~ s{^$DRV_VOL}{$dcwd};
84	0					0	return $path;
85							}
86
87							# This is a string test for before we have the object; see is_rootdir for well-formed
88							# object test
89							sub _is_root {
90	2463			2463		6080	return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' );
91							}
92
93							BEGIN {
94	29			29		10622	*_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] };
	337			337		808
95							}
96
97							# mode bits encoded for chmod in symbolic mode
98							my %MODEBITS = ( om => 0007, gm => 0070, um => 0700 ); ## no critic
99							{ my $m = 0; $MODEBITS{$_} = ( 1 << $m++ ) for qw/ox ow or gx gw gr ux uw ur/ };
100
101							sub _symbolic_chmod {
102	1173			1173		621095	my ( $mode, $symbolic ) = @_;
103	1173					5524	for my $clause ( split /,\s*/, $symbolic ) {
104	2366	100				9344	if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) {
105	2365					6535	my ( $who, $action, $perms ) = ( $1, $2, $3 );
106	2365					4848	$who =~ s/a/ugo/g;
107	2365					5308	for my $w ( split //, $who ) {
108	7391					8888	my $p = 0;
109	7391					18009	$p \|= $MODEBITS{"$w$_"} for split //, $perms;
110	7391	100				13261	if ( $action eq '=' ) {
111	2081					4222	$mode = ( $mode & ~$MODEBITS{"${w}m"} ) \| $p;
112							}
113							else {
114	5310	100				10053	$mode = $action eq "+" ? ( $mode \| $p ) : ( $mode & ~$p );
115							}
116							}
117							}
118							else {
119	1					87	Carp::croak("Invalid mode clause '$clause' for chmod()");
120							}
121							}
122	1172					5024	return $mode;
123							}
124
125							# flock doesn't work on NFS on BSD or on some filesystems like lustre.
126							# Since program authors often can't control or detect that, we warn once
127							# instead of being fatal if we can detect it and people who need it strict
128							# can fatalize the 'flock' category
129
130							#<<< No perltidy
131	29			29		276	{ package flock; use warnings::register }
	29					77
	29					196496
132							#>>>
133
134							my $WARNED_NO_FLOCK = 0;
135
136							sub _throw {
137	16			16		525	my ( $self, $function, $file, $msg ) = @_;
138	16	50	33			79	if ( $function =~ /^flock/
			33
139							&& $! =~ /operation not supported\|function not implemented/i
140							&& !warnings::fatal_enabled('flock') )
141							{
142	0	0				0	if ( !$WARNED_NO_FLOCK ) {
143	0					0	warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" );
144	0					0	$WARNED_NO_FLOCK++;
145							}
146							}
147							else {
148	16	100				98	$msg = $! unless defined $msg;
149	16	100				119	Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ),
150							$msg );
151							}
152	0					0	return;
153							}
154
155							# cheapo option validation
156							sub _get_args {
157	1435			1435		3159	my ( $raw, @valid ) = @_;
158	1435	100	100			5267	if ( defined($raw) && ref($raw) ne 'HASH' ) {
159	6					41	my ( undef, undef, undef, $called_as ) = caller(1);
160	6					36	$called_as =~ s{^.*::}{};
161	6					440	Carp::croak("Options for $called_as must be a hash reference");
162							}
163	1429					2195	my $cooked = {};
164	1429					2817	for my $k (@valid) {
165	2403	100				6138	$cooked->{$k} = delete $raw->{$k} if exists $raw->{$k};
166							}
167	1429	100				3550	if ( keys %$raw ) {
168	8					44	my ( undef, undef, undef, $called_as ) = caller(1);
169	8					48	$called_as =~ s{^.*::}{};
170	8					679	Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) );
171							}
172	1421					2987	return $cooked;
173							}
174
175							#--------------------------------------------------------------------------#
176							# Constructors
177							#--------------------------------------------------------------------------#
178
179							#pod =construct path
180							#pod
181							#pod $path = path("foo/bar");
182							#pod $path = path("/tmp", "file.txt"); # list
183							#pod $path = path("."); # cwd
184							#pod
185							#pod Constructs a C object. It doesn't matter if you give a file or
186							#pod directory path. It's still up to you to call directory-like methods only on
187							#pod directories and file-like methods only on files. This function is exported
188							#pod automatically by default.
189							#pod
190							#pod The first argument must be defined and have non-zero length or an exception
191							#pod will be thrown. This prevents subtle, dangerous errors with code like
192							#pod C<< path( maybe_undef() )->remove_tree >>.
193							#pod
194							#pod B: If and only if the B character of the B argument
195							#pod to C is a tilde ('~'), then tilde replacement will be applied to the
196							#pod first path segment. A single tilde will be replaced with C and a
197							#pod tilde followed by a username will be replaced with output of
198							#pod C. B.
199							#pod See L for more.
200							#pod
201							#pod On Windows, if the path consists of a drive identifier without a path component
202							#pod (C or C), it will be expanded to the absolute path of the current
203							#pod directory on that volume using C.
204							#pod
205							#pod If called with a single C argument, the original is returned unless
206							#pod the original is holding a temporary file or directory reference in which case a
207							#pod stringified copy is made.
208							#pod
209							#pod $path = path("foo/bar");
210							#pod $temp = Path::Tiny->tempfile;
211							#pod
212							#pod $p2 = path($path); # like $p2 = $path
213							#pod $t2 = path($temp); # like $t2 = path( "$temp" )
214							#pod
215							#pod This optimizes copies without proliferating references unexpectedly if a copy is
216							#pod made by code outside your control.
217							#pod
218							#pod Current API available since 0.017.
219							#pod
220							#pod =cut
221
222							sub path {
223	294			294	1	157510	my $path = shift;
224							Carp::croak("Path::Tiny paths require defined, positive-length parts")
225	294	100				729	unless 1 + @_ == grep { defined && length } $path, @_;
	326	100				2219
226
227							# non-temp Path::Tiny objects are effectively immutable and can be reused
228	289	100	100			1435	if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
			66
229	4					14	return $path;
230							}
231
232							# stringify objects
233	285					458	$path = "$path";
234
235							# do any tilde expansions
236	285					812	my ($tilde) = $path =~ m{^(~[^/]*)};
237	285	100				594	if ( defined $tilde ) {
238							# Escape File::Glob metacharacters
239	28					118	(my $escaped = $tilde) =~ s/([\[\{\*\?\\])/\\$1/g;
240	28					154	require File::Glob;
241	28					1679	my ($homedir) = File::Glob::bsd_glob($escaped);
242	28	50	33			275	if (defined $homedir && ! $File::Glob::ERROR) {
243	28					35	$homedir =~ tr[\\][/] if IS_WIN32();
244	28					467	$path =~ s{^\Q$tilde\E}{$homedir};
245							}
246							}
247
248	285					719	unshift @_, $path;
249	285					899	goto &_pathify;
250							}
251
252							# _path is like path but without tilde expansion
253							sub _path {
254	1684			1684		3122	my $path = shift;
255							Carp::croak("Path::Tiny paths require defined, positive-length parts")
256	1684	50				3666	unless 1 + @_ == grep { defined && length } $path, @_;
	2409	50				8823
257
258							# non-temp Path::Tiny objects are effectively immutable and can be reused
259	1684	100	100			8502	if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
			100
260	118					435	return $path;
261							}
262
263							# stringify objects
264	1566					3169	$path = "$path";
265
266	1566					4635	unshift @_, $path;
267	1566					4411	goto &_pathify;
268							}
269
270							# _pathify expects one or more string arguments, then joins and canonicalizes
271							# them into an object.
272							sub _pathify {
273	1851			1851		2918	my $path = shift;
274
275							# expand relative volume paths on windows; put trailing slash on UNC root
276	1851					2344	if ( IS_WIN32() ) {
277							$path = _win32_vol( $path, $1 ) if $path =~ m{^($DRV_VOL)(?:$NOTSLASH\|\z)};
278							$path .= "/" if $path =~ m{^$UNC_VOL\z};
279							}
280
281							# concatenations stringifies objects, too
282	1851	100				3523	if (@_) {
283	612	100				1169	$path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ );
284							}
285
286
287							# canonicalize, but with unix slashes and put back trailing volume slash
288	1851					8132	my $cpath = $path = File::Spec->canonpath($path);
289	1851					2578	$path =~ tr[\\][/] if IS_WIN32();
290	1851	50				3477	$path = "/" if $path eq '/..'; # for old File::Spec
291	1851					2262	$path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL\z};
292
293							# root paths must always have a trailing slash, but other paths must not
294	1851	100				3156	if ( _is_root($path) ) {
295	57					282	$path =~ s{/?\z}{/};
296							}
297							else {
298	1794					3545	$path =~ s{/\z}{};
299							}
300
301	1851					8504	bless [ $path, $cpath ], __PACKAGE__;
302							}
303
304							#pod =construct new
305							#pod
306							#pod $path = Path::Tiny->new("foo/bar");
307							#pod
308							#pod This is just like C, but with method call overhead. (Why would you
309							#pod do that?)
310							#pod
311							#pod Current API available since 0.001.
312							#pod
313							#pod =cut
314
315	2			2	1	323	sub new { shift; path(@_) }
	2					6
316
317							#pod =construct cwd
318							#pod
319							#pod $path = Path::Tiny->cwd; # path( Cwd::getcwd )
320							#pod $path = cwd; # optional export
321							#pod
322							#pod Gives you the absolute path to the current directory as a C object.
323							#pod This is slightly faster than C<< path(".")->absolute >>.
324							#pod
325							#pod C may be exported on request and used as a function instead of as a
326							#pod method.
327							#pod
328							#pod Current API available since 0.018.
329							#pod
330							#pod =cut
331
332							sub cwd {
333	10			10	1	17185	require Cwd;
334	10					107	return _path( Cwd::getcwd() );
335							}
336
337							#pod =construct rootdir
338							#pod
339							#pod $path = Path::Tiny->rootdir; # /
340							#pod $path = rootdir; # optional export
341							#pod
342							#pod Gives you C<< File::Spec->rootdir >> as a C object if you're too
343							#pod picky for C.
344							#pod
345							#pod C may be exported on request and used as a function instead of as a
346							#pod method.
347							#pod
348							#pod Current API available since 0.018.
349							#pod
350							#pod =cut
351
352	3			3	1	139	sub rootdir { _path( File::Spec->rootdir ) }
353
354							#pod =construct tempfile, tempdir
355							#pod
356							#pod $temp = Path::Tiny->tempfile( @options );
357							#pod $temp = Path::Tiny->tempdir( @options );
358							#pod $temp = $dirpath->tempfile( @options );
359							#pod $temp = $dirpath->tempdir( @options );
360							#pod $temp = tempfile( @options ); # optional export
361							#pod $temp = tempdir( @options ); # optional export
362							#pod
363							#pod C passes the options to C<< File::Temp->new >> and returns a
364							#pod C object with the file name. The C option will be enabled
365							#pod by default, but you can override that by passing C<< TMPDIR => 0 >> along with
366							#pod the options. (If you use an absolute C
367							#pod disable C.)
368							#pod
369							#pod The resulting C object is cached. When the C object is
370							#pod destroyed, the C object will be as well.
371							#pod
372							#pod C annoyingly requires you to specify a custom template in slightly
373							#pod different ways depending on which function or method you call, but
374							#pod C lets you ignore that and can take either a leading template or a
375							#pod C
376							#pod
377							#pod $temp = Path::Tiny->tempfile( "customXXXXXXXX" ); # ok
378							#pod $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok
379							#pod
380							#pod The tempfile path object will be normalized to have an absolute path, even if
381							#pod created in a relative directory using C. If you want it to have
382							#pod the C instead, pass a leading options hash like this:
383							#pod
384							#pod $real_temp = tempfile({realpath => 1}, @options);
385							#pod
386							#pod C is just like C, except it calls
387							#pod C<< File::Temp->newdir >> instead.
388							#pod
389							#pod Both C and C may be exported on request and used as
390							#pod functions instead of as methods.
391							#pod
392							#pod The methods can be called on an instances representing a
393							#pod directory. In this case, the directory is used as the base to create the
394							#pod temporary file/directory, setting the C option in File::Temp.
395							#pod
396							#pod my $target_dir = path('/to/destination');
397							#pod my $tempfile = $target_dir->tempfile('foobarXXXXXX');
398							#pod $tempfile->spew('A lot of data...'); # not atomic
399							#pod $tempfile->move($target_dir->child('foobar')); # hopefully atomic
400							#pod
401							#pod In this case, any value set for option C is ignored.
402							#pod
403							#pod B: for tempfiles, the filehandles from File::Temp are closed and not
404							#pod reused. This is not as secure as using File::Temp handles directly, but is
405							#pod less prone to deadlocks or access problems on some platforms. Think of what
406							#pod C gives you to be just a temporary file B that gets cleaned
407							#pod up.
408							#pod
409							#pod B: if you don't want these cleaned up automatically when the object
410							#pod is destroyed, File::Temp requires different options for directories and
411							#pod files. Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for
412							#pod files.
413							#pod
414							#pod B: Don't lose the temporary object by chaining a method call instead
415							#pod of storing it:
416							#pod
417							#pod my $lost = tempdir()->child("foo"); # tempdir cleaned up right away
418							#pod
419							#pod B: The cached object may be accessed with the L method.
420							#pod Keeping a reference to, or modifying the cached object may break the
421							#pod behavior documented above and is not supported. Use at your own risk.
422							#pod
423							#pod Current API available since 0.119.
424							#pod
425							#pod =cut
426
427							sub tempfile {
428	187			187	1	478086	my ( $opts, $maybe_template, $args )
429							= _parse_file_temp_args(tempfile => @_);
430
431							# File::Temp->new demands TEMPLATE
432	187	100				435	$args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template;
433
434	187					987	require File::Temp;
435	187					959	my $temp = File::Temp->new( TMPDIR => 1, %$args );
436	187					73263	close $temp;
437	187	100				901	my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
438	187					414	$self->[TEMP] = $temp; # keep object alive while we are
439	187					764	return $self;
440							}
441
442							sub tempdir {
443	21			21	1	36945	my ( $opts, $maybe_template, $args )
444							= _parse_file_temp_args(tempdir => @_);
445
446	21					119	require File::Temp;
447	21					144	my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args );
448	21	100				9789	my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
449	21					58	$self->[TEMP] = $temp; # keep object alive while we are
450							# Some ActiveState Perls for Windows break Cwd in ways that lead
451							# File::Temp to get confused about what path to remove; this
452							# monkey-patches the object with our own view of the absolute path
453	21					37	$temp->{REALNAME} = $self->[CANON] if IS_WIN32;
454	21					104	return $self;
455							}
456
457							# normalize the various ways File::Temp does templates
458							sub _parse_file_temp_args {
459	208			208		431	my $called_as = shift;
460	208	100	66			1055	if ( @_ && $_[0] eq 'Path::Tiny' ) { shift } # class method
	201	100	66			318
461	7					48	elsif ( @_ && eval{$_[0]->isa('Path::Tiny')} ) {
462	5					8	my $dir = shift;
463	5	50				13	if (! $dir->is_dir) {
464	0					0	$dir->_throw( $called_as, $dir, "is not a directory object" );
465							}
466	5					34	push @_, DIR => $dir->stringify; # no overriding
467							}
468	208	100	100			680	my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
469	208					472	$opts = _get_args( $opts, qw/realpath/ );
470
471	208	100				629	my $leading_template = ( scalar(@_) % 2 == 1 ? shift(@_) : '' );
472	208					384	my %args = @_;
473	208					458	%args = map { uc($_), $args{$_} } keys %args;
	14					62
474							my @template = (
475							exists $args{TEMPLATE} ? delete $args{TEMPLATE}
476	208	100				558	: $leading_template ? $leading_template
		100
477							: ()
478							);
479
480	208					635	return ( $opts, \@template, \%args );
481							}
482
483							#--------------------------------------------------------------------------#
484							# Private methods
485							#--------------------------------------------------------------------------#
486
487							sub _splitpath {
488	836			836		1294	my ($self) = @_;
489	836					8453	@{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] );
	836					3058
490							}
491
492							sub _resolve_symlinks {
493	179			179		325	my ($self) = @_;
494	179					249	my $new = $self;
495	179					312	my ( $count, %seen ) = 0;
496	179					2850	while ( -l $new->[PATH] ) {
497	12	100				77	if ( $seen{ $new->[PATH] }++ ) {
498	1					5	$self->_throw( 'readlink', $self->[PATH], "symlink loop detected" );
499							}
500	11	50				42	if ( ++$count > 100 ) {
501	0					0	$self->_throw( 'readlink', $self->[PATH], "maximum symlink depth exceeded" );
502							}
503	11					111	my $resolved = readlink $new->[PATH];
504	11	50				39	$new->_throw( 'readlink', $new->[PATH] ) unless defined $resolved;
505	11					27	$resolved = _path($resolved);
506	11	100				30	$new = $resolved->is_absolute ? $resolved : $new->sibling($resolved);
507							}
508	178					702	return $new;
509							}
510
511							sub _replacment_path {
512	146			146		253	my ($self) = @_;
513
514	146					657	my $unique_suffix = $$ . int( rand( 2**31 ) );
515	146					478	my $temp = _path( $self . $unique_suffix );
516
517							# If filename with process+random suffix is too long, use a shorter
518							# version that doesn't preserve the basename.
519	146	100				412	if ( length $temp->basename > 255 ) {
520	1					7	$temp = $self->sibling( "temp" . $unique_suffix );
521							}
522
523	146					287	return $temp;
524							}
525
526							#--------------------------------------------------------------------------#
527							# Public methods
528							#--------------------------------------------------------------------------#
529
530							#pod =method absolute
531							#pod
532							#pod $abs = path("foo/bar")->absolute;
533							#pod $abs = path("foo/bar")->absolute("/tmp");
534							#pod
535							#pod Returns a new C object with an absolute path (or itself if already
536							#pod absolute). If no argument is given, the current directory is used as the
537							#pod absolute base path. If an argument is given, it will be converted to an
538							#pod absolute path (if it is not already) and used as the absolute base path.
539							#pod
540							#pod This will not resolve upward directories ("foo/../bar") unless C
541							#pod in L would normally do so on your platform. If you need them
542							#pod resolved, you must call the more expensive C method instead.
543							#pod
544							#pod On Windows, an absolute path without a volume component will have it added
545							#pod based on the current drive.
546							#pod
547							#pod Current API available since 0.101.
548							#pod
549							#pod =cut
550
551							sub absolute {
552	279			279	1	946	my ( $self, $base ) = @_;
553
554							# absolute paths handled differently by OS
555	279					373	if (IS_WIN32) {
556							return $self if length $self->volume;
557							# add missing volume
558							if ( $self->is_absolute ) {
559							require Cwd;
560							# use Win32::GetCwd not Cwd::getdcwd because we're sure
561							# to have the former but not necessarily the latter
562							my ($drv) = Win32::GetCwd() =~ /^($DRV_VOL \| $UNC_VOL)/x;
563							return _path( $drv . $self->[PATH] );
564							}
565							}
566							else {
567	279	100				611	return $self if $self->is_absolute;
568							}
569
570							# no base means use current directory as base
571	70					372	require Cwd;
572	70	100				772	return _path( Cwd::getcwd(), $_[0]->[PATH] ) unless defined $base;
573
574							# relative base should be made absolute; we check is_absolute rather
575							# than unconditionally make base absolute so that "/foo" doesn't become
576							# "C:/foo" on Windows.
577	6					14	$base = _path($base);
578	6	50				18	return _path( ( $base->is_absolute ? $base : $base->absolute ), $_[0]->[PATH] );
579							}
580
581							#pod =method append, append_raw, append_utf8
582							#pod
583							#pod path("foo.txt")->append(@data);
584							#pod path("foo.txt")->append(\@data);
585							#pod path("foo.txt")->append({binmode => ":raw"}, @data);
586							#pod path("foo.txt")->append_raw(@data);
587							#pod path("foo.txt")->append_utf8(@data);
588							#pod
589							#pod Appends data to a file. The file is locked with C prior to writing
590							#pod and closed afterwards. An optional hash reference may be used to pass
591							#pod options. Valid options are:
592							#pod
593							#pod =for :list
594							#pod * C: passed to C on the handle used for writing.
595							#pod * C: truncates the file after locking and before appending
596							#pod
597							#pod The C option is a way to replace the contents of a file
598							#pod B, unlike L which writes to a temporary file and then
599							#pod replaces the original (if it exists).
600							#pod
601							#pod C is like C with a C of C<:unix> for a fast,
602							#pod unbuffered, raw write.
603							#pod
604							#pod C is like C with an unbuffered C
605							#pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
606							#pod L). If L 0.58+ is installed, an
607							#pod unbuffered, raw append will be done instead on the data encoded with
608							#pod C.
609							#pod
610							#pod Current API available since 0.060.
611							#pod
612							#pod =cut
613
614							sub append {
615	47			47	1	3199	my ( $self, @data ) = @_;
616	47	100	100			229	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
617	47					113	$args = _get_args( $args, qw/binmode truncate/ );
618	46					83	my $binmode = $args->{binmode};
619	46	100	100			281	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
620	46	100				126	my $mode = $args->{truncate} ? ">" : ">>";
621	46					147	my $fh = $self->filehandle( { locked => 1 }, $mode, $binmode );
622	46	100				113	print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data ) or self->_throw('print');
	46	50				115
	91					961
623	46	50				2266	close $fh or $self->_throw('close');
624							}
625
626							sub append_raw {
627	9			9	1	2010	my ( $self, @data ) = @_;
628	9	100	66			57	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
629	9					28	$args = _get_args( $args, qw/binmode truncate/ );
630	9					26	$args->{binmode} = ':unix';
631	9					26	append( $self, $args, @data );
632							}
633
634							sub append_utf8 {
635	9			9	1	32	my ( $self, @data ) = @_;
636	9	100	66			59	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
637	9					25	$args = _get_args( $args, qw/binmode truncate/ );
638	9	50				48	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		50
		100
		50
639	3					9	$args->{binmode} = ":unix";
640	3					8	append( $self, $args, map { Unicode::UTF8::encode_utf8($_) } @data );
	9					31
641							}
642							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
643	0					0	$args->{binmode} = ":unix:utf8_strict";
644	0					0	append( $self, $args, @data );
645							}
646							else {
647	6					16	$args->{binmode} = ":unix:encoding(UTF-8)";
648	6					16	append( $self, $args, @data );
649							}
650							}
651
652							#pod =method assert
653							#pod
654							#pod $path = path("foo.txt")->assert( sub { $_->exists } );
655							#pod
656							#pod Returns the invocant after asserting that a code reference argument returns
657							#pod true. When the assertion code reference runs, it will have the invocant
658							#pod object in the C<$_> variable. If it returns false, an exception will be
659							#pod thrown. The assertion code reference may also throw its own exception.
660							#pod
661							#pod If no assertion is provided, the invocant is returned without error.
662							#pod
663							#pod Current API available since 0.062.
664							#pod
665							#pod =cut
666
667							sub assert {
668	2			2	1	6	my ( $self, $assertion ) = @_;
669	2	50				6	return $self unless $assertion;
670	2	50				9	if ( ref $assertion eq 'CODE' ) {
671	2					4	local $_ = $self;
672	2	100				4	$assertion->()
673							or Path::Tiny::Error->throw( "assert", $self->[PATH], "failed assertion" );
674							}
675							else {
676	0					0	Carp::croak("argument to assert must be a code reference argument");
677							}
678	1					14	return $self;
679							}
680
681							#pod =method basename
682							#pod
683							#pod $name = path("foo/bar.txt")->basename; # bar.txt
684							#pod $name = path("foo.txt")->basename('.txt'); # foo
685							#pod $name = path("foo.txt")->basename(qr/.txt/); # foo
686							#pod $name = path("foo.txt")->basename(@suffixes);
687							#pod
688							#pod Returns the file portion or last directory portion of a path.
689							#pod
690							#pod Given a list of suffixes as strings or regular expressions, any that match at
691							#pod the end of the file portion or last directory portion will be removed before
692							#pod the result is returned.
693							#pod
694							#pod Current API available since 0.054.
695							#pod
696							#pod =cut
697
698							sub basename {
699	169			169	1	985	my ( $self, @suffixes ) = @_;
700	169	100				653	$self->_splitpath unless defined $self->[FILE];
701	169					346	my $file = $self->[FILE];
702	169					362	for my $s (@suffixes) {
703	8	100				96	my $re = ref($s) eq 'Regexp' ? qr/$s\z/ : qr/\Q$s\E\z/;
704	8	100				54	last if $file =~ s/$re//;
705							}
706	169					486	return $file;
707							}
708
709							#pod =method canonpath
710							#pod
711							#pod $canonical = path("foo/bar")->canonpath; # foo\bar on Windows
712							#pod
713							#pod Returns a string with the canonical format of the path name for
714							#pod the platform. In particular, this means directory separators
715							#pod will be C<\> on Windows.
716							#pod
717							#pod Current API available since 0.001.
718							#pod
719							#pod =cut
720
721	1			1	1	7	sub canonpath { $_[0]->[CANON] }
722
723							#pod =method cached_temp
724							#pod
725							#pod Returns the cached C or C object if the
726							#pod C object was created with C or C.
727							#pod If there is no such object, this method throws.
728							#pod
729							#pod B: Keeping a reference to, or modifying the cached object may
730							#pod break the behavior documented for temporary files and directories created
731							#pod with C and is not supported. Use at your own risk.
732							#pod
733							#pod Current API available since 0.101.
734							#pod
735							#pod =cut
736
737							sub cached_temp {
738	3			3	1	19	my $self = shift;
739	3	100				11	$self->_throw( "cached_temp", $self, "has no cached File::Temp object" )
740							unless defined $self->[TEMP];
741	2					10	return $self->[TEMP];
742							}
743
744							#pod =method child
745							#pod
746							#pod $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
747							#pod $file = path("/tmp")->child(@parts);
748							#pod
749							#pod Returns a new C object relative to the original. Works
750							#pod like C or C from File::Spec, but without caring about
751							#pod file or directories.
752							#pod
753							#pod B: because the argument could contain C<..> or refer to symlinks,
754							#pod there is no guarantee that the new path refers to an actual descendent of
755							#pod the original. If this is important to you, transform parent and child with
756							#pod L and check them with L.
757							#pod
758							#pod Current API available since 0.001.
759							#pod
760							#pod =cut
761
762							sub child {
763	417			417	1	26917	my ( $self, @parts ) = @_;
764	417					1038	return _path( $self->[PATH], @parts );
765							}
766
767							#pod =method children
768							#pod
769							#pod @paths = path("/tmp")->children;
770							#pod @paths = path("/tmp")->children( qr/\.txt\z/ );
771							#pod
772							#pod Returns a list of C objects for all files and directories
773							#pod within a directory. Excludes "." and ".." automatically.
774							#pod
775							#pod If an optional C argument is provided, it only returns objects for child
776							#pod names that match the given regular expression. Only the base name is used
777							#pod for matching:
778							#pod
779							#pod @paths = path("/tmp")->children( qr/^foo/ );
780							#pod # matches children like the glob foo*
781							#pod
782							#pod Current API available since 0.028.
783							#pod
784							#pod =cut
785
786							sub children {
787	9			9	1	2087	my ( $self, $filter ) = @_;
788	9					17	my $dh;
789	9	50				345	opendir $dh, $self->[PATH] or $self->_throw('opendir');
790	9					238	my @children = readdir $dh;
791	9	50				141	closedir $dh or $self->_throw('closedir');
792
793	9	100	66			51	if ( not defined $filter ) {
		100
794	7	100				17	@children = grep { $_ ne '.' && $_ ne '..' } @children;
	25					113
795							}
796							elsif ( $filter && ref($filter) eq 'Regexp' ) {
797	1	100	100			3	@children = grep { $_ ne '.' && $_ ne '..' && $_ =~ $filter } @children;
	5					44
798							}
799							else {
800	1					181	Carp::croak("Invalid argument '$filter' for children()");
801							}
802
803	8					22	return map { _path( $self->[PATH], $_ ) } @children;
	13					36
804							}
805
806							#pod =method chmod
807							#pod
808							#pod path("foo.txt")->chmod(0777);
809							#pod path("foo.txt")->chmod("0755");
810							#pod path("foo.txt")->chmod("go-w");
811							#pod path("foo.txt")->chmod("a=r,u+wx");
812							#pod
813							#pod Sets file or directory permissions. The argument can be a numeric mode, a
814							#pod octal string beginning with a "0" or a limited subset of the symbolic mode use
815							#pod by F.
816							#pod
817							#pod The symbolic mode must be a comma-delimited list of mode clauses. Clauses must
818							#pod match C<< qr/\A([augo]+)([=+-])([rwx]+)\z/ >>, which defines "who", "op" and
819							#pod "perms" parameters for each clause. Unlike F, all three parameters
820							#pod are required for each clause, multiple ops are not allowed and permissions
821							#pod C are not supported. (See L for more complex needs.)
822							#pod
823							#pod Current API available since 0.053.
824							#pod
825							#pod =cut
826
827							sub chmod {
828	6			6	1	4324	my ( $self, $new_mode ) = @_;
829
830	6					9	my $mode;
831	6	100				40	if ( $new_mode =~ /\d/ ) {
		100
832	3	100				20	$mode = ( $new_mode =~ /^0/ ? oct($new_mode) : $new_mode );
833							}
834							elsif ( $new_mode =~ /[=+-]/ ) {
835	2					11	$mode = _symbolic_chmod( $self->stat->mode & 07777, $new_mode ); ## no critic
836							}
837							else {
838	1					182	Carp::croak("Invalid mode argument '$new_mode' for chmod()");
839							}
840
841	4	100				101	CORE::chmod( $mode, $self->[PATH] ) or $self->_throw("chmod");
842
843	3					19	return 1;
844							}
845
846							#pod =method copy
847							#pod
848							#pod path("/tmp/foo.txt")->copy("/tmp/bar.txt");
849							#pod
850							#pod Copies the current path to the given destination using L's
851							#pod C function. Upon success, returns the C object for the
852							#pod newly copied file.
853							#pod
854							#pod Current API available since 0.070.
855							#pod
856							#pod =cut
857
858							# XXX do recursively for directories?
859							sub copy {
860	2			2	1	13	my ( $self, $dest ) = @_;
861	2					9	require File::Copy;
862	2	50				9	File::Copy::copy( $self->[PATH], $dest )
863							or Carp::croak("copy failed for $self to $dest: $!");
864
865	2	100				362	return -d $dest ? _path( $dest, $self->basename ) : _path($dest);
866							}
867
868							#pod =method digest
869							#pod
870							#pod $obj = path("/tmp/foo.txt")->digest; # SHA-256
871							#pod $obj = path("/tmp/foo.txt")->digest("MD5"); # user-selected
872							#pod $obj = path("/tmp/foo.txt")->digest( { chunk_size => 1e6 }, "MD5" );
873							#pod
874							#pod Returns a hexadecimal digest for a file. An optional hash reference of options may
875							#pod be given. The only option is C. If C is given, that many
876							#pod bytes will be read at a time. If not provided, the entire file will be slurped
877							#pod into memory to compute the digest.
878							#pod
879							#pod Any subsequent arguments are passed to the constructor for L to select
880							#pod an algorithm. If no arguments are given, the default is SHA-256.
881							#pod
882							#pod Current API available since 0.056.
883							#pod
884							#pod =cut
885
886							sub digest {
887	6			6	1	97	my ( $self, @opts ) = @_;
888	6	100	100			30	my $args = ( @opts && ref $opts[0] eq 'HASH' ) ? shift @opts : {};
889	6					20	$args = _get_args( $args, qw/chunk_size/ );
890	6	100				18	unshift @opts, 'SHA-256' unless @opts;
891	6					30	require Digest;
892	6					29	my $digest = Digest->new(@opts);
893	6	100				3896	if ( $args->{chunk_size} ) {
894	2					13	my $fh = $self->filehandle( { locked => 1 }, "<", ":unix" );
895	2					6	my $buf;
896	2					62	while (!eof($fh)) {
897	10					97	my $rc = read $fh, $buf, $args->{chunk_size};
898	10	50				31	$self->_throw('read') unless defined $rc;
899	10					134	$digest->add($buf);
900							}
901							}
902							else {
903	4					14	$digest->add( $self->slurp_raw );
904							}
905	6					107	return $digest->hexdigest;
906							}
907
908							#pod =method dirname (deprecated)
909							#pod
910							#pod $name = path("/tmp/foo.txt")->dirname; # "/tmp/"
911							#pod
912							#pod Returns the directory portion you would get from calling
913							#pod C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a
914							#pod parent directory portion. Because L is inconsistent, the result
915							#pod might or might not have a trailing slash. Because of this, this method is
916							#pod B.
917							#pod
918							#pod A better, more consistently approach is likely C<< $path->parent->stringify >>,
919							#pod which will not have a trailing slash except for a root directory.
920							#pod
921							#pod Deprecated in 0.056.
922							#pod
923							#pod =cut
924
925							sub dirname {
926	798			798	1	2490	my ($self) = @_;
927	798	100				2528	$self->_splitpath unless defined $self->[DIR];
928	798	100				3719	return length $self->[DIR] ? $self->[DIR] : ".";
929							}
930
931							#pod =method edit, edit_raw, edit_utf8
932							#pod
933							#pod path("foo.txt")->edit( \&callback, $options );
934							#pod path("foo.txt")->edit_utf8( \&callback );
935							#pod path("foo.txt")->edit_raw( \&callback );
936							#pod
937							#pod These are convenience methods that allow "editing" a file using a single
938							#pod callback argument. They slurp the file using C, place the contents
939							#pod inside a localized C<$_> variable, call the callback function (without
940							#pod arguments), and then write C<$_> (presumably mutated) back to the
941							#pod file with C.
942							#pod
943							#pod An optional hash reference may be used to pass options. The only option is
944							#pod C, which is passed to C and C.
945							#pod
946							#pod C and C act like their respective C and
947							#pod C methods.
948							#pod
949							#pod Current API available since 0.077.
950							#pod
951							#pod =cut
952
953							sub edit {
954	6			6	1	34	my $self = shift;
955	6					13	my $cb = shift;
956	6					18	my $args = _get_args( shift, qw/binmode/ );
957	6	50	33			50	Carp::croak("Callback for edit() must be a code reference")
958							unless defined($cb) && ref($cb) eq 'CODE';
959
960							local $_ =
961	6	50				40	$self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () );
962	6					40	$cb->();
963	6					64	$self->spew( $args, $_ );
964
965	6					24	return;
966							}
967
968							# this is done long-hand to benefit from slurp_utf8 optimizations
969							sub edit_utf8 {
970	3			3	1	13	my ( $self, $cb ) = @_;
971	3	50	33			28	Carp::croak("Callback for edit_utf8() must be a code reference")
972							unless defined($cb) && ref($cb) eq 'CODE';
973
974	3					16	local $_ = $self->slurp_utf8;
975	3					23	$cb->();
976	3					65	$self->spew_utf8($_);
977
978	3					11	return;
979							}
980
981	3			3	1	42	sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit }
	3					13
982
983							#pod =method edit_lines, edit_lines_utf8, edit_lines_raw
984							#pod
985							#pod path("foo.txt")->edit_lines( \&callback, $options );
986							#pod path("foo.txt")->edit_lines_utf8( \&callback );
987							#pod path("foo.txt")->edit_lines_raw( \&callback );
988							#pod
989							#pod These are convenience methods that allow "editing" a file's lines using a
990							#pod single callback argument. They iterate over the file: for each line, the
991							#pod line is put into a localized C<$_> variable, the callback function is
992							#pod executed (without arguments) and then C<$_> is written to a temporary file.
993							#pod When iteration is finished, the temporary file is atomically renamed over
994							#pod the original.
995							#pod
996							#pod An optional hash reference may be used to pass options. The only option is
997							#pod C, which is passed to the method that open handles for reading and
998							#pod writing.
999							#pod
1000							#pod C is like C with a buffered C of
1001							#pod C<:raw>.
1002							#pod
1003							#pod C is like C with a buffered C
1004							#pod C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
1005							#pod L).
1006							#pod
1007							#pod Current API available since 0.077.
1008							#pod
1009							#pod =cut
1010
1011							sub edit_lines {
1012	9			9	1	37	my $self = shift;
1013	9					16	my $cb = shift;
1014	9					21	my $args = _get_args( shift, qw/binmode/ );
1015	9	50	33			57	Carp::croak("Callback for edit_lines() must be a code reference")
1016							unless defined($cb) && ref($cb) eq 'CODE';
1017
1018	9					21	my $binmode = $args->{binmode};
1019							# get default binmode from caller's lexical scope (see "perldoc open")
1020	9	50	0			22	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
1021
1022							# writing needs to follow the link and create the tempfile in the same
1023							# dir for later atomic rename
1024	9					23	my $resolved_path = $self->_resolve_symlinks;
1025	9					34	my $temp = $resolved_path->_replacment_path;
1026
1027	9					42	my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
1028	9					49	my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode );
1029
1030	9					25	local $_;
1031	9					190	while (! eof($in_fh) ) {
1032	36	50				461	defined( $_ = readline($in_fh) ) or $self->_throw('readline');
1033	36					113	$cb->();
1034	36	50				291	$temp_fh->print($_) or self->_throw('print', $temp);
1035							}
1036
1037	9	50				885	close $temp_fh or $self->_throw( 'close', $temp );
1038	9	50				119	close $in_fh or $self->_throw('close');
1039
1040	9					39	return $temp->move($resolved_path);
1041							}
1042
1043	3			3	1	38	sub edit_lines_raw { $_[2] = { binmode => ":raw" }; goto &edit_lines }
	3					11
1044
1045							sub edit_lines_utf8 {
1046	3	50		3	1	49	if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
		50
1047	0					0	$_[2] = { binmode => ":raw:utf8_strict" };
1048							}
1049							else {
1050	3					15	$_[2] = { binmode => ":raw:encoding(UTF-8)" };
1051							}
1052	3					11	goto &edit_lines;
1053							}
1054
1055							#pod =method exists, is_file, is_dir
1056							#pod
1057							#pod if ( path("/tmp")->exists ) { ... } # -e
1058							#pod if ( path("/tmp")->is_dir ) { ... } # -d
1059							#pod if ( path("/tmp")->is_file ) { ... } # -e && ! -d
1060							#pod
1061							#pod Implements file test operations, this means the file or directory actually has
1062							#pod to exist on the filesystem. Until then, it's just a path.
1063							#pod
1064							#pod B: C is not C<-f> because C<-f> is not the opposite of C<-d>.
1065							#pod C<-f> means "plain file", excluding symlinks, devices, etc. that often can be
1066							#pod read just like files.
1067							#pod
1068							#pod Use C<-f> instead if you really mean to check for a plain file.
1069							#pod
1070							#pod Current API available since 0.053.
1071							#pod
1072							#pod =cut
1073
1074	29			29	1	656	sub exists { -e $_[0]->[PATH] }
1075
1076	32	100		32	1	435	sub is_file { -e $_[0]->[PATH] && !-d _ }
1077
1078	6			6	1	93	sub is_dir { -d $_[0]->[PATH] }
1079
1080							#pod =method filehandle
1081							#pod
1082							#pod $fh = path("/tmp/foo.txt")->filehandle($mode, $binmode);
1083							#pod $fh = path("/tmp/foo.txt")->filehandle({ locked => 1 }, $mode, $binmode);
1084							#pod $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1 }, $mode, $binmode);
1085							#pod
1086							#pod Returns an open file handle. The C<$mode> argument must be a Perl-style
1087							#pod read/write mode string ("<" ,">", ">>", etc.). If a C<$binmode>
1088							#pod is given, it is set during the C call.
1089							#pod
1090							#pod An optional hash reference may be used to pass options.
1091							#pod
1092							#pod The C option governs file locking; if true, handles opened for writing,
1093							#pod appending or read-write are locked with C; otherwise, they are
1094							#pod locked with C. When using C, ">" or "+>" modes will delay
1095							#pod truncation until after the lock is acquired.
1096							#pod
1097							#pod The C option causes the open() call to fail if the file already
1098							#pod exists. This corresponds to the O_EXCL flag to sysopen / open(2).
1099							#pod C implies C and will set it for you if you forget it.
1100							#pod
1101							#pod See C, C, C, and C for sugar.
1102							#pod
1103							#pod Current API available since 0.066.
1104							#pod
1105							#pod =cut
1106
1107							# Note: must put binmode on open line, not subsequent binmode() call, so things
1108							# like ":unix" actually stop perlio/crlf from being added
1109
1110							sub filehandle {
1111	555			555	1	1308	my ( $self, @args ) = @_;
1112	555	100	66			2270	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1113	555					1136	$args = _get_args( $args, qw/locked exclusive/ );
1114	555	100				1249	$args->{locked} = 1 if $args->{exclusive};
1115	555					1193	my ( $opentype, $binmode ) = @args;
1116
1117	555	100				1150	$opentype = "<" unless defined $opentype;
1118							Carp::croak("Invalid file mode '$opentype'")
1119	555	50				1007	unless grep { $opentype eq $_ } qw/< +< > +> >> +>>/;
	3330					6028
1120
1121	555	100	50			2554	$binmode = ( ( caller(0) )[10] \|\| {} )->{ 'open' . substr( $opentype, -1, 1 ) }
1122							unless defined $binmode;
1123	555	100				1345	$binmode = "" unless defined $binmode;
1124
1125	555					891	my ( $fh, $lock, $trunc );
1126	555	100	66			2688	if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) {
			100
1127	448					2162	require Fcntl;
1128							# truncating file modes shouldn't truncate until lock acquired
1129	448	100	33			768	if ( grep { $opentype eq $_ } qw( > +> ) ) {
	896	50				2608
1130							# sysopen in write mode without truncation
1131	155	50				356	my $flags = $opentype eq ">" ? Fcntl::O_WRONLY() : Fcntl::O_RDWR();
1132	155					250	$flags \|= Fcntl::O_CREAT();
1133	155	100				345	$flags \|= Fcntl::O_EXCL() if $args->{exclusive};
1134	155	100				11980	sysopen( $fh, $self->[PATH], $flags ) or $self->_throw("sysopen");
1135
1136							# fix up the binmode since sysopen() can't specify layers like
1137							# open() and binmode() can't start with just :unix like open()
1138	154	100				1127	if ( $binmode =~ s/^:unix// ) {
1139							# eliminate pseudo-layers
1140	67	50				452	binmode( $fh, ":raw" ) or $self->_throw("binmode (:raw)");
1141							# strip off real layers until only :unix is left
1142	67					597	while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
1143	67	50				454	binmode( $fh, ":pop" ) or $self->_throw("binmode (:pop)");
1144							}
1145							}
1146
1147							# apply any remaining binmode layers
1148	154	100				424	if ( length $binmode ) {
1149	46	50				592	binmode( $fh, $binmode ) or $self->_throw("binmode ($binmode)");
1150							}
1151
1152							# ask for lock and truncation
1153	154					3928	$lock = Fcntl::LOCK_EX();
1154	154					266	$trunc = 1;
1155							}
1156							elsif ( $^O eq 'aix' && $opentype eq "<" ) {
1157							# AIX can only lock write handles, so upgrade to RW and LOCK_EX if
1158							# the file is writable; otherwise give up on locking. N.B.
1159							# checking -w before open to determine the open mode is an
1160							# unavoidable race condition
1161	0	0				0	if ( -w $self->[PATH] ) {
1162	0					0	$opentype = "+<";
1163	0					0	$lock = Fcntl::LOCK_EX();
1164							}
1165							}
1166							else {
1167	293	100				635	$lock = $opentype eq "<" ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX();
1168							}
1169							}
1170
1171	554	100				1204	unless ($fh) {
1172	400					814	my $mode = $opentype . $binmode;
1173	400	100		4		17774	open $fh, $mode, $self->[PATH] or $self->_throw("open ($mode)");
	4					23
	4					7
	4					27
1174							}
1175
1176	551	50				8562	do { flock( $fh, $lock ) or $self->_throw("flock ($lock)") } if $lock;
	444	100				4176
1177	551	50				1377	do { truncate( $fh, 0 ) or $self->_throw("truncate") } if $trunc;
	154	100				3443
1178
1179	551					2614	return $fh;
1180							}
1181
1182							#pod =method has_same_bytes
1183							#pod
1184							#pod if ( path("foo.txt")->has_same_bytes("bar.txt") ) {
1185							#pod # ...
1186							#pod }
1187							#pod
1188							#pod This method returns true if both the invocant and the argument can be opened as
1189							#pod file handles and the handles contain the same bytes. It returns false if their
1190							#pod contents differ. If either can't be opened as a file (e.g. a directory or
1191							#pod non-existent file), the method throws an exception. If both can be opened and
1192							#pod both have the same C, the method returns true without scanning any
1193							#pod data.
1194							#pod
1195							#pod Current API available since 0.125.
1196							#pod
1197							#pod =cut
1198
1199							sub has_same_bytes {
1200	11			11	1	2503	my ($self, $other_path) = @_;
1201	11					23	my $other = _path($other_path);
1202
1203	11					38	my $fh1 = $self->openr_raw({ locked => 1 });
1204	10					42	my $fh2 = $other->openr_raw({ locked => 1 });
1205
1206							# check for directories
1207	9	100				82	if (-d $fh1) {
1208	3					18	$self->_throw('has_same_bytes', $self->[PATH], "directory not allowed");
1209							}
1210	6	100				59	if (-d $fh2) {
1211	1					7	$self->_throw('has_same_bytes', $other->[PATH], "directory not allowed");
1212							}
1213
1214							# Now that handles are open, we know the inputs are readable files that
1215							# exist, so it's safe to compare via realpath
1216	5	100				18	if ($self->realpath eq $other->realpath) {
1217	3					75	return 1
1218							}
1219
1220							# result is 0 for equal, 1 for unequal, -1 for error
1221	2					462	require File::Compare;
1222	2					1039	my $res = File::Compare::compare($fh1, $fh2, 65536);
1223	2	50				180	if ($res < 0) {
1224	0					0	$self->_throw('has_same_bytes')
1225							}
1226
1227	2					51	return $res == 0;
1228							}
1229
1230							#pod =method is_absolute, is_relative
1231							#pod
1232							#pod if ( path("/tmp")->is_absolute ) { ... }
1233							#pod if ( path("/tmp")->is_relative ) { ... }
1234							#pod
1235							#pod Booleans for whether the path appears absolute or relative.
1236							#pod
1237							#pod Current API available since 0.001.
1238							#pod
1239							#pod =cut
1240
1241	647			647	1	2177	sub is_absolute { substr( $_[0]->dirname, 0, 1 ) eq '/' }
1242
1243	145			145	1	702	sub is_relative { substr( $_[0]->dirname, 0, 1 ) ne '/' }
1244
1245							#pod =method is_rootdir
1246							#pod
1247							#pod while ( ! $path->is_rootdir ) {
1248							#pod $path = $path->parent;
1249							#pod ...
1250							#pod }
1251							#pod
1252							#pod Boolean for whether the path is the root directory of the volume. I.e. the
1253							#pod C is C and the C is C.
1254							#pod
1255							#pod This works even on C with drives and UNC volumes:
1256							#pod
1257							#pod path("C:/")->is_rootdir; # true
1258							#pod path("//server/share/")->is_rootdir; #true
1259							#pod
1260							#pod Current API available since 0.038.
1261							#pod
1262							#pod =cut
1263
1264							sub is_rootdir {
1265	164			164	1	279	my ($self) = @_;
1266	164	100				312	$self->_splitpath unless defined $self->[DIR];
1267	164		100			535	return $self->[DIR] eq '/' && $self->[FILE] eq '';
1268							}
1269
1270							#pod =method iterator
1271							#pod
1272							#pod $iter = path("/tmp")->iterator( \%options );
1273							#pod
1274							#pod Returns a code reference that walks a directory lazily. Each invocation
1275							#pod returns a C object or undef when the iterator is exhausted.
1276							#pod
1277							#pod $iter = path("/tmp")->iterator;
1278							#pod while ( $path = $iter->() ) {
1279							#pod ...
1280							#pod }
1281							#pod
1282							#pod The current and parent directory entries ("." and "..") will not
1283							#pod be included.
1284							#pod
1285							#pod If the C option is true, the iterator will walk the directory
1286							#pod recursively, breadth-first. If the C option is also true,
1287							#pod directory links will be followed recursively. There is no protection against
1288							#pod loops when following links. If a directory is not readable, it will not be
1289							#pod followed.
1290							#pod
1291							#pod The default is the same as:
1292							#pod
1293							#pod $iter = path("/tmp")->iterator( {
1294							#pod recurse => 0,
1295							#pod follow_symlinks => 0,
1296							#pod } );
1297							#pod
1298							#pod For a more powerful, recursive iterator with built-in loop avoidance, see
1299							#pod L.
1300							#pod
1301							#pod See also L.
1302							#pod
1303							#pod Current API available since 0.016.
1304							#pod
1305							#pod =cut
1306
1307							sub iterator {
1308	20			20	1	1736	my $self = shift;
1309	20					45	my $args = _get_args( shift, qw/recurse follow_symlinks/ );
1310	18					76	my @dirs = $self;
1311	18					28	my $current;
1312							return sub {
1313	292			292		1143	my $next;
1314	292					558	while (@dirs) {
1315	347	100				767	if ( ref $dirs[0] eq 'Path::Tiny' ) {
1316	74	100				264	if ( !-r $dirs[0] ) {
1317							# Directory is missing or not readable, so skip it. There
1318							# is still a race condition possible between the check and
1319							# the opendir, but we can't easily differentiate between
1320							# error cases that are OK to skip and those that we want
1321							# to be exceptions, so we live with the race and let opendir
1322							# be fatal.
1323	1	50				8	shift @dirs and next;
1324							}
1325	73					241	$current = $dirs[0];
1326	73					99	my $dh;
1327	73	50				1813	opendir( $dh, $current->[PATH] )
1328							or $self->_throw( 'opendir', $current->[PATH] );
1329	73					187	$dirs[0] = $dh;
1330	73	50	66			788	if ( -l $current->[PATH] && !$args->{follow_symlinks} ) {
1331							# Symlink attack! It was a real dir, but is now a symlink!
1332							# N.B. we check after opendir so the attacker has to win
1333							# two races: replace dir with symlink before opendir and
1334							# replace symlink with dir before -l check above
1335	0	0				0	shift @dirs and next;
1336							}
1337							}
1338	346					2171	while ( defined( $next = readdir $dirs[0] ) ) {
1339	417	100	100			1689	next if $next eq '.' \|\| $next eq '..';
1340	275					589	my $path = $current->child($next);
1341							push @dirs, $path
1342	275	100	100			871	if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path );
			100
			100
1343	275					1285	return $path;
1344							}
1345	71					901	shift @dirs;
1346							}
1347	17					67	return;
1348	18					100	};
1349							}
1350
1351							#pod =method lines, lines_raw, lines_utf8
1352							#pod
1353							#pod @contents = path("/tmp/foo.txt")->lines;
1354							#pod @contents = path("/tmp/foo.txt")->lines(\%options);
1355							#pod @contents = path("/tmp/foo.txt")->lines_raw;
1356							#pod @contents = path("/tmp/foo.txt")->lines_utf8;
1357							#pod
1358							#pod @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } );
1359							#pod
1360							#pod Returns a list of lines from a file. Optionally takes a hash-reference of
1361							#pod options. Valid options are C, C and C.
1362							#pod
1363							#pod If C is provided, it will be set on the handle prior to reading.
1364							#pod
1365							#pod If a positive C is provided, that many lines will be returned from the
1366							#pod start of the file. If a negative C is provided, the entire file will be
1367							#pod read, but only C will be kept and returned. If C
1368							#pod exceeds the number of lines in the file, all lines will be returned.
1369							#pod
1370							#pod If C is set, any end-of-line character sequences (C, C, or
1371							#pod C) will be removed from the lines returned.
1372							#pod
1373							#pod Because the return is a list, C in scalar context will return the number
1374							#pod of lines (and throw away the data).
1375							#pod
1376							#pod $number_of_lines = path("/tmp/foo.txt")->lines;
1377							#pod
1378							#pod C is like C with a C of C<:raw>. We use C<:raw>
1379							#pod instead of C<:unix> so PerlIO buffering can manage reading by line.
1380							#pod
1381							#pod C is like C with a C of C<:raw:encoding(UTF-8)>
1382							#pod (or C<:raw:utf8_strict> with L). If L
1383							#pod 0.58+ is installed, a raw, unbuffered UTF-8 slurp will be done and then the
1384							#pod lines will be split. This is actually faster than relying on
1385							#pod IO layers, though a bit memory intensive. If memory use is a
1386							#pod concern, consider C and iterating directly on the handle.
1387							#pod
1388							#pod Current API available since 0.065.
1389							#pod
1390							#pod =cut
1391
1392							sub lines {
1393	112			112	1	7516	my $self = shift;
1394	112					260	my $args = _get_args( shift, qw/binmode chomp count/ );
1395	110					198	my $binmode = $args->{binmode};
1396	110	100	100			710	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open<'} unless defined $binmode;
1397	110					401	my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
1398	110					347	my $chomp = $args->{chomp};
1399							# XXX more efficient to read @lines then chomp(@lines) vs map?
1400	110	100				320	if ( $args->{count} ) {
		100
1401	84					233	my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) );
1402	84					117	my $line;
1403	84					1684	while ( !eof($fh) ) {
1404	216	50				1130	defined( $line = readline($fh) ) or $self->_throw('readline');
1405
1406	216	100				714	$line =~ s/(?:\x{0d}?\x{0a}\|\x{0d})\z// if $chomp;
1407	216					469	$result[ $counter++ ] = $line;
1408							# for positive count, terminate after right number of lines
1409	216	100				435	last if $counter == $args->{count};
1410							# for negative count, eventually wrap around in the result array
1411	180					571	$counter %= $mod;
1412							}
1413							# reorder results if full and wrapped somewhere in the middle
1414	84	100	100			368	splice( @result, 0, 0, splice( @result, $counter ) )
1415							if @result == $mod && $counter % $mod;
1416	84					2354	return @result;
1417							}
1418							elsif ($chomp) {
1419	6					45	local $!;
1420	6					163	my @lines = map { s/(?:\x{0d}?\x{0a}\|\x{0d})\z//; $_ } <$fh>; ## no critic
	21					191
	21					101
1421	6	50				44	$self->_throw('readline') if $!;
1422	6					171	return @lines;
1423							}
1424							else {
1425	20	100				54	if ( wantarray ) {
1426	14					129	local $!;
1427	14					378	my @lines = <$fh>;
1428	14	50				139	$self->_throw('readline') if $!;
1429	14					396	return @lines;
1430							} else {
1431	6					39	local $!;
1432	6					175	my $count =()= <$fh>;
1433	6	50				38	$self->_throw('readline') if $!;
1434	6					144	return $count;
1435							}
1436							}
1437							}
1438
1439							sub lines_raw {
1440	17			17	1	36	my $self = shift;
1441	17					47	my $args = _get_args( shift, qw/binmode chomp count/ );
1442	15	50	33			61	if ( $args->{chomp} && !$args->{count} ) {
1443	0					0	return split /\n/, slurp_raw($self); ## no critic
1444							}
1445							else {
1446	15					33	$args->{binmode} = ":raw";
1447	15					39	return lines( $self, $args );
1448							}
1449							}
1450
1451							my $CRLF = qr/(?:\x{0d}?\x{0a}\|\x{0d})/;
1452
1453							sub lines_utf8 {
1454	35			35	1	70	my $self = shift;
1455	35					98	my $args = _get_args( shift, qw/binmode chomp count/ );
1456	33	50	100			197	if ( ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) )
		100	100
		100
		50
1457							&& $args->{chomp}
1458							&& !$args->{count} )
1459							{
1460	2					7	my $slurp = slurp_utf8($self);
1461	2					66	$slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF\|CR
1462	2					46	return split $CRLF, $slurp, -1; ## no critic
1463							}
1464							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
1465	0					0	$args->{binmode} = ":raw:utf8_strict";
1466	0					0	return lines( $self, $args );
1467							}
1468							else {
1469	31					71	$args->{binmode} = ":raw:encoding(UTF-8)";
1470	31					75	return lines( $self, $args );
1471							}
1472							}
1473
1474							#pod =method mkdir
1475							#pod
1476							#pod path("foo/bar/baz")->mkdir;
1477							#pod path("foo/bar/baz")->mkdir( \%options );
1478							#pod
1479							#pod Like calling C from L. An optional hash reference
1480							#pod is passed through to C. Errors will be trapped and an exception
1481							#pod thrown. Returns the the path object to facilitate chaining.
1482							#pod
1483							#pod B: unlike Perl's builtin C, this will create intermediate paths
1484							#pod similar to the Unix C command. It will not error if applied to an
1485							#pod existing directory.
1486							#pod
1487							#pod Current API available since 0.125.
1488							#pod
1489							#pod =cut
1490
1491							sub mkdir {
1492	48			48	1	210	my ( $self, $args ) = @_;
1493	48	100				137	$args = {} unless ref $args eq 'HASH';
1494	48					69	my $err;
1495	48	50				177	$args->{error} = \$err unless defined $args->{error};
1496	48					258	require File::Path;
1497	48					77	my @dirs;
1498	48					75	my $ok = eval {
1499	48					9060	File::Path::make_path( $self->[PATH], $args );
1500	48					213	1;
1501							};
1502	48	50				148	if (!$ok) {
1503	0					0	$self->_throw('mkdir', $self->[PATH], "error creating path: $@");
1504							}
1505	48	50	33			235	if ( $err && @$err ) {
1506	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1507	0					0	$self->_throw('mkdir', $file, $message);
1508							}
1509	48					248	return $self;
1510							}
1511
1512							#pod =method mkpath (deprecated)
1513							#pod
1514							#pod Like calling C, but returns the list of directories created or an empty list if
1515							#pod the directories already exist, just like C.
1516							#pod
1517							#pod Deprecated in 0.125.
1518							#pod
1519							#pod =cut
1520
1521							sub mkpath {
1522	2			2	1	5	my ( $self, $args ) = @_;
1523	2	100				10	$args = {} unless ref $args eq 'HASH';
1524	2					3	my $err;
1525	2	50				7	$args->{error} = \$err unless defined $args->{error};
1526	2					13	require File::Path;
1527	2					323	my @dirs = File::Path::make_path( $self->[PATH], $args );
1528	2	50	33			18	if ( $err && @$err ) {
1529	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1530	0					0	Carp::croak("mkpath failed for $file: $message");
1531							}
1532	2					12	return @dirs;
1533							}
1534
1535							#pod =method move
1536							#pod
1537							#pod path("foo.txt")->move("bar.txt");
1538							#pod
1539							#pod Moves the current path to the given destination using L's
1540							#pod C function. Upon success, returns the C object for the
1541							#pod newly moved file.
1542							#pod
1543							#pod If the destination already exists and is a directory, and the source is not a
1544							#pod directory, then the source file will be renamed into the directory
1545							#pod specified by the destination.
1546							#pod
1547							#pod If possible, move() will simply rename the file. Otherwise, it
1548							#pod copies the file to the new location and deletes the original. If an
1549							#pod error occurs during this copy-and-delete process, you may be left
1550							#pod with a (possibly partial) copy of the file under the destination
1551							#pod name.
1552							#pod
1553							#pod Current API available since 0.124. Prior versions used Perl's
1554							#pod -built-in (and less robust) L function
1555							#pod and did not return an object.
1556							#pod
1557							#pod =cut
1558
1559							sub move {
1560	149			149	1	346	my ( $self, $dest ) = @_;
1561	149					4425	require File::Copy;
1562	149	100				24627	File::Copy::move( $self->[PATH], $dest )
1563							or $self->_throw( 'move', $self->[PATH] . "' -> '$dest" );
1564
1565	148	100				2056	return -d $dest ? _path( $dest, $self->basename ) : _path($dest);
1566							}
1567
1568							#pod =method openr, openw, openrw, opena
1569							#pod
1570							#pod $fh = path("foo.txt")->openr($binmode); # read
1571							#pod $fh = path("foo.txt")->openr_raw;
1572							#pod $fh = path("foo.txt")->openr_utf8;
1573							#pod
1574							#pod $fh = path("foo.txt")->openw($binmode); # write
1575							#pod $fh = path("foo.txt")->openw_raw;
1576							#pod $fh = path("foo.txt")->openw_utf8;
1577							#pod
1578							#pod $fh = path("foo.txt")->opena($binmode); # append
1579							#pod $fh = path("foo.txt")->opena_raw;
1580							#pod $fh = path("foo.txt")->opena_utf8;
1581							#pod
1582							#pod $fh = path("foo.txt")->openrw($binmode); # read/write
1583							#pod $fh = path("foo.txt")->openrw_raw;
1584							#pod $fh = path("foo.txt")->openrw_utf8;
1585							#pod
1586							#pod Returns a file handle opened in the specified mode. The C style methods
1587							#pod take a single C argument. All of the C methods have
1588							#pod C and C equivalents that use buffered I/O layers C<:raw>
1589							#pod and C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
1590							#pod L).
1591							#pod
1592							#pod An optional hash reference may be used to pass options. The only option is
1593							#pod C. If true, handles opened for writing, appending or read-write are
1594							#pod locked with C; otherwise, they are locked for C.
1595							#pod
1596							#pod $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );
1597							#pod
1598							#pod See L for more on locking.
1599							#pod
1600							#pod Current API available since 0.011.
1601							#pod
1602							#pod =cut
1603
1604							# map method names to corresponding open mode
1605							my %opens = (
1606							opena => ">>",
1607							openr => "<",
1608							openw => ">",
1609							openrw => "+<"
1610							);
1611
1612							while ( my ( $k, $v ) = each %opens ) {
1613	29			29		295	no strict 'refs';
	29					65
	29					113062
1614							# must check for lexical IO mode hint
1615							*{$k} = sub {
1616	70			70		11362	my ( $self, @args ) = @_;
1617	70	100	100			311	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1618	70					184	$args = _get_args( $args, qw/locked/ );
1619	70					140	my ($binmode) = @args;
1620	70	100	100			906	$binmode = ( ( caller(0) )[10] \|\| {} )->{ 'open' . substr( $v, -1, 1 ) }
1621							unless defined $binmode;
1622	70					279	$self->filehandle( $args, $v, $binmode );
1623							};
1624							*{ $k . "_raw" } = sub {
1625	39			39		4215	my ( $self, @args ) = @_;
1626	39	100	66			186	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1627	39					110	$args = _get_args( $args, qw/locked/ );
1628	39					108	$self->filehandle( $args, $v, ":raw" );
1629							};
1630							*{ $k . "_utf8" } = sub {
1631	18			18		4146	my ( $self, @args ) = @_;
1632	18	50	33			79	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1633	18					47	$args = _get_args( $args, qw/locked/ );
1634	18					33	my $layer;
1635	18	50				55	if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
		50
1636	0					0	$layer = ":raw:utf8_strict";
1637							}
1638							else {
1639	18					30	$layer = ":raw:encoding(UTF-8)";
1640							}
1641	18					43	$self->filehandle( $args, $v, $layer );
1642							};
1643							}
1644
1645							#pod =method parent
1646							#pod
1647							#pod $parent = path("foo/bar/baz")->parent; # foo/bar
1648							#pod $parent = path("foo/wibble.txt")->parent; # foo
1649							#pod
1650							#pod $parent = path("foo/bar/baz")->parent(2); # foo
1651							#pod
1652							#pod Returns a C object corresponding to the parent directory of the
1653							#pod original directory or file. An optional positive integer argument is the number
1654							#pod of parent directories upwards to return. C by itself is equivalent to
1655							#pod C.
1656							#pod
1657							#pod Current API available since 0.014.
1658							#pod
1659							#pod =cut
1660
1661							# XXX this is ugly and coverage is incomplete. I think it's there for windows
1662							# so need to check coverage there and compare
1663							sub parent {
1664	358			358	1	2283	my ( $self, $level ) = @_;
1665	358	100	100			1039	$level = 1 unless defined $level && $level > 0;
1666	358	100				1035	$self->_splitpath unless defined $self->[FILE];
1667	358					536	my $parent;
1668	358	100				744	if ( length $self->[FILE] ) {
		50
1669	316	100	100			999	if ( $self->[FILE] eq '.' \|\| $self->[FILE] eq ".." ) {
1670	58					155	$parent = _path( $self->[PATH] . "/.." );
1671							}
1672							else {
1673	258					764	$parent = _path( _non_empty( $self->[VOL] . $self->[DIR] ) );
1674							}
1675							}
1676							elsif ( length $self->[DIR] ) {
1677							# because of symlinks, any internal updir requires us to
1678							# just add more updirs at the end
1679	42	100				175	if ( $self->[DIR] =~ m{(?:^\.\./\|/\.\./\|/\.\.\z)} ) {
1680	35					120	$parent = _path( $self->[VOL] . $self->[DIR] . "/.." );
1681							}
1682							else {
1683	7					14	( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/};
1684	7					23	$parent = _path( $self->[VOL] . $dir );
1685							}
1686							}
1687							else {
1688	0					0	$parent = _path( _non_empty( $self->[VOL] ) );
1689							}
1690	358	100				1994	return $level == 1 ? $parent : $parent->parent( $level - 1 );
1691							}
1692
1693							sub _non_empty {
1694	258			258		467	my ($string) = shift;
1695	258	100	66			1000	return ( ( defined($string) && length($string) ) ? $string : "." );
1696							}
1697
1698							#pod =method realpath
1699							#pod
1700							#pod $real = path("/baz/foo/../bar")->realpath;
1701							#pod $real = path("foo/../bar")->realpath;
1702							#pod
1703							#pod Returns a new C object with all symbolic links and upward directory
1704							#pod parts resolved using L's C. Compared to C, this is
1705							#pod more expensive as it must actually consult the filesystem.
1706							#pod
1707							#pod If the parent path can't be resolved (e.g. if it includes directories that
1708							#pod don't exist), an exception will be thrown:
1709							#pod
1710							#pod $real = path("doesnt_exist/foo")->realpath; # dies
1711							#pod
1712							#pod However, if the parent path exists and only the last component (e.g. filename)
1713							#pod doesn't exist, the realpath will be the realpath of the parent plus the
1714							#pod non-existent last component:
1715							#pod
1716							#pod $real = path("./aasdlfasdlf")->realpath; # works
1717							#pod
1718							#pod The underlying L module usually worked this way on Unix, but died on
1719							#pod Windows (and some Unixes) if the full path didn't exist. As of version 0.064,
1720							#pod it's safe to use anywhere.
1721							#pod
1722							#pod Current API available since 0.001.
1723							#pod
1724							#pod =cut
1725
1726							# Win32 and some Unixes need parent path resolved separately so realpath
1727							# doesn't throw an error resolving non-existent basename
1728							sub realpath {
1729	33			33	1	540	my $self = shift;
1730	33					108	$self = $self->_resolve_symlinks;
1731	32					176	require Cwd;
1732	32	100				127	$self->_splitpath if !defined $self->[FILE];
1733	32		100			199	my $check_parent =
1734							length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..';
1735	32					61	my $realpath = eval {
1736							# pure-perl Cwd can carp
1737	32			0		226	local $SIG{__WARN__} = sub { };
1738	32	100				277	Cwd::realpath( $check_parent ? $self->parent->[PATH] : $self->[PATH] );
1739							};
1740							# parent realpath must exist; not all Cwd::realpath will error if it doesn't
1741	32	100	33			515	$self->_throw("resolving realpath")
			66
1742							unless defined $realpath && length $realpath && -e $realpath;
1743	31	100				142	return ( $check_parent ? _path( $realpath, $self->[FILE] ) : _path($realpath) );
1744							}
1745
1746							#pod =method relative
1747							#pod
1748							#pod $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
1749							#pod
1750							#pod Returns a C object with a path relative to a new base path
1751							#pod given as an argument. If no argument is given, the current directory will
1752							#pod be used as the new base path.
1753							#pod
1754							#pod If either path is already relative, it will be made absolute based on the
1755							#pod current directly before determining the new relative path.
1756							#pod
1757							#pod The algorithm is roughly as follows:
1758							#pod
1759							#pod =for :list
1760							#pod * If the original and new base path are on different volumes, an exception
1761							#pod will be thrown.
1762							#pod * If the original and new base are identical, the relative path is C<".">.
1763							#pod * If the new base subsumes the original, the relative path is the original
1764							#pod path with the new base chopped off the front
1765							#pod * If the new base does not subsume the original, a common prefix path is
1766							#pod determined (possibly the root directory) and the relative path will
1767							#pod consist of updirs (C<"..">) to reach the common prefix, followed by the
1768							#pod original path less the common prefix.
1769							#pod
1770							#pod Unlike C, in the last case above, the calculation based
1771							#pod on a common prefix takes into account symlinks that could affect the updir
1772							#pod process. Given an original path "/A/B" and a new base "/A/C",
1773							#pod (where "A", "B" and "C" could each have multiple path components):
1774							#pod
1775							#pod =for :list
1776							#pod * Symlinks in "A" don't change the result unless the last component of A is
1777							#pod a symlink and the first component of "C" is an updir.
1778							#pod * Symlinks in "B" don't change the result and will exist in the result as
1779							#pod given.
1780							#pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into
1781							#pod account the possibility that not all path components might exist on the
1782							#pod filesystem.
1783							#pod
1784							#pod Current API available since 0.001. New algorithm (that accounts for
1785							#pod symlinks) available since 0.079.
1786							#pod
1787							#pod =cut
1788
1789							sub relative {
1790	72			72	1	193	my ( $self, $base ) = @_;
1791	72	100	100			294	$base = _path( defined $base && length $base ? $base : '.' );
1792
1793							# relative paths must be converted to absolute first
1794	72	100				201	$self = $self->absolute if $self->is_relative;
1795	72	100				198	$base = $base->absolute if $base->is_relative;
1796
1797							# normalize volumes if they exist
1798	72	50	33			212	$self = $self->absolute if !length $self->volume && length $base->volume;
1799	72	50	33			144	$base = $base->absolute if length $self->volume && !length $base->volume;
1800
1801							# can't make paths relative across volumes
1802	72	50				125	if ( !_same( $self->volume, $base->volume ) ) {
1803	0					0	Carp::croak("relative() can't cross volumes: '$self' vs '$base'");
1804							}
1805
1806							# if same absolute path, relative is current directory
1807	72	100				157	return _path(".") if _same( $self->[PATH], $base->[PATH] );
1808
1809							# if base is a prefix of self, chop prefix off self
1810	66	100				147	if ( $base->subsumes($self) ) {
1811	20	100				52	$base = "" if $base->is_rootdir;
1812	20					46	my $relative = "$self";
1813	20					77	$relative =~ s{\A\Q$base/}{};
1814	20					77	return _path(".", $relative);
1815							}
1816
1817							# base is not a prefix, so must find a common prefix (even if root)
1818	46					107	my ( @common, @self_parts, @base_parts );
1819	46					97	@base_parts = split /\//, $base->_just_filepath;
1820
1821							# if self is rootdir, then common directory is root (shown as empty
1822							# string for later joins); otherwise, must be computed from path parts.
1823	46	100				103	if ( $self->is_rootdir ) {
1824	6					15	@common = ("");
1825	6					11	shift @base_parts;
1826							}
1827							else {
1828	40					68	@self_parts = split /\//, $self->_just_filepath;
1829
1830	40		66			211	while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) {
			100
1831	154					263	push @common, shift @base_parts;
1832	154					475	shift @self_parts;
1833							}
1834							}
1835
1836							# if there are any symlinks from common to base, we have a problem, as
1837							# you can't guarantee that updir from base reaches the common prefix;
1838							# we must resolve symlinks and try again; likewise, any updirs are
1839							# a problem as it throws off calculation of updirs needed to get from
1840							# self's path to the common prefix.
1841	46	100				120	if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) {
1842	6					39	return $self->relative($new_base);
1843							}
1844
1845							# otherwise, symlinks in common or from common to A don't matter as
1846							# those don't involve updirs
1847	40					166	my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts );
1848	40					105	return _path(@new_path);
1849							}
1850
1851							sub _just_filepath {
1852	87			87		115	my $self = shift;
1853	87					133	my $self_vol = $self->volume;
1854	87	50				214	return "$self" if !length $self_vol;
1855
1856	0					0	( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{};
1857
1858	0					0	return $self_path;
1859							}
1860
1861							sub _resolve_between {
1862	46			46		81	my ( $self, $common, $base ) = @_;
1863	46					83	my $path = $self->volume . join( "/", @$common );
1864	46					88	my $changed = 0;
1865	46					89	for my $p (@$base) {
1866	141					278	$path .= "/$p";
1867	141	100				247	if ( $p eq '..' ) {
1868	4					7	$changed = 1;
1869	4	100				92	if ( -e $path ) {
1870	2					11	$path = _path($path)->realpath->[PATH];
1871							}
1872							else {
1873	2					23	$path =~ s{/[^/]+/..\z}{/};
1874							}
1875							}
1876	141	100				1677	if ( -l $path ) {
1877	2					6	$changed = 1;
1878	2					9	$path = _path($path)->realpath->[PATH];
1879							}
1880							}
1881	46	100				184	return $changed ? _path($path) : undef;
1882							}
1883
1884							#pod =method remove
1885							#pod
1886							#pod path("foo.txt")->remove;
1887							#pod
1888							#pod This is just like C, except for its error handling: if the path does
1889							#pod not exist, it returns false; if deleting the file fails, it throws an
1890							#pod exception.
1891							#pod
1892							#pod Current API available since 0.012.
1893							#pod
1894							#pod =cut
1895
1896							sub remove {
1897	10			10	1	1113	my $self = shift;
1898
1899	10	100	100			195	return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1900
1901	9		66			751	return unlink( $self->[PATH] ) \|\| $self->_throw('unlink');
1902							}
1903
1904							#pod =method remove_tree
1905							#pod
1906							#pod # directory
1907							#pod path("foo/bar/baz")->remove_tree;
1908							#pod path("foo/bar/baz")->remove_tree( \%options );
1909							#pod path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove
1910							#pod
1911							#pod Like calling C from L, but defaults to C mode.
1912							#pod An optional hash reference is passed through to C. Errors will be
1913							#pod trapped and an exception thrown. Returns the number of directories deleted,
1914							#pod just like C.
1915							#pod
1916							#pod If you want to remove a directory only if it is empty, use the built-in
1917							#pod C function instead.
1918							#pod
1919							#pod rmdir path("foo/bar/baz/");
1920							#pod
1921							#pod Current API available since 0.013.
1922							#pod
1923							#pod =cut
1924
1925							sub remove_tree {
1926	22			22	1	348	my ( $self, $args ) = @_;
1927	22	100	100			402	return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1928	20	100				95	$args = {} unless ref $args eq 'HASH';
1929	20					36	my $err;
1930	20	50				75	$args->{error} = \$err unless defined $args->{error};
1931	20	100				54	$args->{safe} = 1 unless defined $args->{safe};
1932	20					115	require File::Path;
1933	20					9926	my $count = File::Path::remove_tree( $self->[PATH], $args );
1934
1935	20	50	33			158	if ( $err && @$err ) {
1936	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1937	0					0	Carp::croak("remove_tree failed for $file: $message");
1938							}
1939	20					122	return $count;
1940							}
1941
1942							#pod =method sibling
1943							#pod
1944							#pod $foo = path("/tmp/foo.txt");
1945							#pod $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt
1946							#pod $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt
1947							#pod
1948							#pod Returns a new C object relative to the parent of the original.
1949							#pod This is slightly more efficient than C<< $path->parent->child(...) >>.
1950							#pod
1951							#pod Current API available since 0.058.
1952							#pod
1953							#pod =cut
1954
1955							sub sibling {
1956	6			6	1	13	my $self = shift;
1957	6					16	return _path( $self->parent->[PATH], @_ );
1958							}
1959
1960							#pod =method size, size_human
1961							#pod
1962							#pod my $p = path("foo"); # with size 1025 bytes
1963							#pod
1964							#pod $p->size; # "1025"
1965							#pod $p->size_human; # "1.1 K"
1966							#pod $p->size_human( {format => "iec"} ); # "1.1 KiB"
1967							#pod
1968							#pod Returns the size of a file. The C method is just a wrapper around C<-s>.
1969							#pod
1970							#pod The C method provides a human-readable string similar to
1971							#pod C. Like C, it rounds upwards and provides one decimal place for
1972							#pod single-digit sizes and no decimal places for larger sizes. The only available
1973							#pod option is C, which has three valid values:
1974							#pod
1975							#pod =for :list
1976							#pod * 'ls' (the default): base-2 sizes, with C style single-letter suffixes (K, M, etc.)
1977							#pod * 'iec': base-2 sizes, with IEC binary suffixes (KiB, MiB, etc.)
1978							#pod * 'si': base-10 sizes, with SI decimal suffixes (kB, MB, etc.)
1979							#pod
1980							#pod If C<-s> would return C, C returns the empty string.
1981							#pod
1982							#pod Current API available since 0.122.
1983							#pod
1984							#pod =cut
1985
1986	1			1	1	20	sub size { -s $_[0]->[PATH] }
1987
1988							my %formats = (
1989							'ls' => [ 1024, log(1024), [ "", map { " $_" } qw/K M G T/ ] ],
1990							'iec' => [ 1024, log(1024), [ "", map { " $_" } qw/KiB MiB GiB TiB/ ] ],
1991							'si' => [ 1000, log(1000), [ "", map { " $_" } qw/kB MB GB TB/ ] ],
1992							);
1993
1994	93			93		71318	sub _formats { return $formats{$_[0]} }
1995
1996							sub size_human {
1997	7			7	1	46	my $self = shift;
1998	7					17	my $args = _get_args( shift, qw/format/ );
1999	7	100				19	my $format = defined $args->{format} ? $args->{format} : "ls";
2000	7	100				192	my $fmt_opts = $formats{$format}
2001							or Carp::croak("Invalid format '$format' for size_human()");
2002	6					96	my $size = -s $self->[PATH];
2003	6	100				34	return defined $size ? _human_size( $size, @$fmt_opts ) : "";
2004							}
2005
2006							sub _ceil {
2007	92	100		92		248	return $_[0] == int($_[0]) ? $_[0] : int($_[0]+1);
2008							}
2009
2010							sub _human_size {
2011	98			98		397	my ( $size, $base, $log_base, $suffixes ) = @_;
2012	98	100				247	return "0" if $size == 0;
2013
2014	95					356	my $mag = int( log($size) / $log_base );
2015	95					181	$size /= $base**$mag;
2016	95	100				333	$size =
		100
2017							$mag == 0 ? $size
2018							: length( int($size) ) == 1 ? _ceil( $size * 10 ) / 10
2019							: _ceil($size);
2020	95	100				206	if ( $size >= $base ) {
2021	9					14	$size /= $base;
2022	9					14	$mag++;
2023							}
2024
2025	95	100	100			391	my $fmt = ( $mag == 0 \|\| length( int($size) ) > 1 ) ? "%.0f%s" : "%.1f%s";
2026	95					701	return sprintf( $fmt, $size, $suffixes->[$mag] );
2027							}
2028
2029							#pod =method slurp, slurp_raw, slurp_utf8
2030							#pod
2031							#pod $data = path("foo.txt")->slurp;
2032							#pod $data = path("foo.txt")->slurp( {binmode => ":raw"} );
2033							#pod $data = path("foo.txt")->slurp_raw;
2034							#pod $data = path("foo.txt")->slurp_utf8;
2035							#pod
2036							#pod Reads file contents into a scalar. Takes an optional hash reference which may
2037							#pod be used to pass options. The only available option is C, which is
2038							#pod passed to C on the handle used for reading.
2039							#pod
2040							#pod C is like C with a C of C<:unix> for
2041							#pod a fast, unbuffered, raw read.
2042							#pod
2043							#pod C is like C with a C of
2044							#pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
2045							#pod L). If L 0.58+ is installed, a
2046							#pod unbuffered, raw slurp will be done instead and the result decoded with
2047							#pod C. This is just as strict and is roughly an order of
2048							#pod magnitude faster than using C<:encoding(UTF-8)>.
2049							#pod
2050							#pod B: C and friends lock the filehandle before slurping. If
2051							#pod you plan to slurp from a file created with L, be sure to
2052							#pod close other handles or open without locking to avoid a deadlock:
2053							#pod
2054							#pod my $tempfile = File::Temp->new(EXLOCK => 0);
2055							#pod my $guts = path($tempfile)->slurp;
2056							#pod
2057							#pod Current API available since 0.004.
2058							#pod
2059							#pod =cut
2060
2061							sub slurp {
2062	116			116	1	2269	my $self = shift;
2063	116					312	my $args = _get_args( shift, qw/binmode/ );
2064	114					241	my $binmode = $args->{binmode};
2065	114	100	100			615	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open<'} unless defined $binmode;
2066	114					424	my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
2067	113	100	66			872	if ( ( defined($binmode) ? $binmode : "" ) eq ":unix"
		100
2068							and my $size = -s $fh )
2069							{
2070	41					91	my $buf;
2071	41					496	my $rc = read $fh, $buf, $size; # File::Slurp in a nutshell
2072	41	50				141	$self->_throw('read') unless defined $rc;
2073	41					801	return $buf;
2074							}
2075							else {
2076	72					316	local $/;
2077	72					2256	my $buf = scalar <$fh>;
2078	72	50				530	$self->_throw('read') unless defined $buf;
2079	72					1559	return $buf;
2080							}
2081							}
2082
2083	28			28	1	168	sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp }
	28					90
2084
2085							sub slurp_utf8 {
2086	27	100		27	1	660	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		100
		100
		50
2087	10					61	return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) );
2088							}
2089							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
2090	0					0	$_[1] = { binmode => ":unix:utf8_strict" };
2091	0					0	goto &slurp;
2092							}
2093							else {
2094	17					82	$_[1] = { binmode => ":unix:encoding(UTF-8)" };
2095	17					82	goto &slurp;
2096							}
2097							}
2098
2099							#pod =method spew, spew_raw, spew_utf8
2100							#pod
2101							#pod path("foo.txt")->spew(@data);
2102							#pod path("foo.txt")->spew(\@data);
2103							#pod path("foo.txt")->spew({binmode => ":raw"}, @data);
2104							#pod path("foo.txt")->spew_raw(@data);
2105							#pod path("foo.txt")->spew_utf8(@data);
2106							#pod
2107							#pod Writes data to a file atomically. The file is written to a temporary file in
2108							#pod the same directory, then renamed over the original. An optional hash reference
2109							#pod may be used to pass options. The only option is C, which is passed to
2110							#pod C on the handle used for writing.
2111							#pod
2112							#pod C is like C with a C of C<:unix> for a fast,
2113							#pod unbuffered, raw write.
2114							#pod
2115							#pod C is like C with a C of C<:unix:encoding(UTF-8)>
2116							#pod (or C<:unix:utf8_strict> with L). If L
2117							#pod 0.58+ is installed, a raw, unbuffered spew will be done instead on the data
2118							#pod encoded with C.
2119							#pod
2120							#pod B: because the file is written to a temporary file and then renamed, the
2121							#pod new file will wind up with permissions based on your current umask. This is a
2122							#pod feature to protect you from a race condition that would otherwise give
2123							#pod different permissions than you might expect. If you really want to keep the
2124							#pod original mode flags, use L with the C option.
2125							#pod
2126							#pod Current API available since 0.011.
2127							#pod
2128							#pod =cut
2129
2130							sub spew {
2131	138			138	1	831	my ( $self, @data ) = @_;
2132	138	100	100			686	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
2133	138					372	$args = _get_args( $args, qw/binmode/ );
2134	137					275	my $binmode = $args->{binmode};
2135							# get default binmode from caller's lexical scope (see "perldoc open")
2136	137	100	100			831	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
2137
2138							# writing needs to follow the link and create the tempfile in the same
2139							# dir for later atomic rename
2140	137					461	my $resolved_path = $self->_resolve_symlinks;
2141	137					379	my $temp = $resolved_path->_replacment_path;
2142
2143	137					548	my $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
2144	136	100				310	print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data) or self->_throw('print', $temp->[PATH]);
	136	50				365
	264					3070
2145	136	50				10293	close $fh or $self->_throw( 'close', $temp->[PATH] );
2146
2147	136					689	return $temp->move($resolved_path);
2148							}
2149
2150	25			25	1	231	sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew }
	25					81
2151
2152							sub spew_utf8 {
2153	33	100		33	1	309	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		100
		100
		50
2154	11					19	my $self = shift;
2155							spew(
2156							$self,
2157							{ binmode => ":unix" },
2158	11	100				38	map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_
	31					99
	29					73
2159							);
2160							}
2161							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
2162	0					0	splice @_, 1, 0, { binmode => ":unix:utf8_strict" };
2163	0					0	goto &spew;
2164							}
2165							else {
2166	22					364	splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" };
2167	22					72	goto &spew;
2168							}
2169							}
2170
2171							#pod =method stat, lstat
2172							#pod
2173							#pod $stat = path("foo.txt")->stat;
2174							#pod $stat = path("/some/symlink")->lstat;
2175							#pod
2176							#pod Like calling C or C from L.
2177							#pod
2178							#pod Current API available since 0.001.
2179							#pod
2180							#pod =cut
2181
2182							# XXX break out individual stat() components as subs?
2183							sub stat {
2184	9			9	1	1017	my $self = shift;
2185	9					2062	require File::stat;
2186	9		66			27575	return File::stat::stat( $self->[PATH] ) \|\| $self->_throw('stat');
2187							}
2188
2189							sub lstat {
2190	2			2	1	12	my $self = shift;
2191	2					11	require File::stat;
2192	2		66			11	return File::stat::lstat( $self->[PATH] ) \|\| $self->_throw('lstat');
2193							}
2194
2195							#pod =method stringify
2196							#pod
2197							#pod $path = path("foo.txt");
2198							#pod say $path->stringify; # same as "$path"
2199							#pod
2200							#pod Returns a string representation of the path. Unlike C, this method
2201							#pod returns the path standardized with Unix-style C directory separators.
2202							#pod
2203							#pod Current API available since 0.001.
2204							#pod
2205							#pod =cut
2206
2207	2685	100		2685	1	128528	sub stringify { $_[0]->[PATH] =~ /^~/ ? './' . $_[0]->[PATH] : $_[0]->[PATH] }
2208
2209							#pod =method subsumes
2210							#pod
2211							#pod path("foo/bar")->subsumes("foo/bar/baz"); # true
2212							#pod path("/foo/bar")->subsumes("/foo/baz"); # false
2213							#pod
2214							#pod Returns true if the first path is a prefix of the second path at a directory
2215							#pod boundary.
2216							#pod
2217							#pod This B resolve parent directory entries (C<..>) or symlinks:
2218							#pod
2219							#pod path("foo/bar")->subsumes("foo/bar/../baz"); # true
2220							#pod
2221							#pod If such things are important to you, ensure that both paths are resolved to
2222							#pod the filesystem with C:
2223							#pod
2224							#pod my $p1 = path("foo/bar")->realpath;
2225							#pod my $p2 = path("foo/bar/../baz")->realpath;
2226							#pod if ( $p1->subsumes($p2) ) { ... }
2227							#pod
2228							#pod Current API available since 0.048.
2229							#pod
2230							#pod =cut
2231
2232							sub subsumes {
2233	96			96	1	144	my $self = shift;
2234	96	50				194	Carp::croak("subsumes() requires a defined, positive-length argument")
2235							unless defined $_[0];
2236	96					191	my $other = _path(shift);
2237
2238							# normalize absolute vs relative
2239	96	100	100			208	if ( $self->is_absolute && !$other->is_absolute ) {
		100	100
2240	3					8	$other = $other->absolute;
2241							}
2242							elsif ( $other->is_absolute && !$self->is_absolute ) {
2243	2					6	$self = $self->absolute;
2244							}
2245
2246							# normalize volume vs non-volume; do this after absolute path
2247							# adjustments above since that might add volumes already
2248	96	50	33			221	if ( length $self->volume && !length $other->volume ) {
		50	33
2249	0					0	$other = $other->absolute;
2250							}
2251							elsif ( length $other->volume && !length $self->volume ) {
2252	0					0	$self = $self->absolute;
2253							}
2254
2255	96	100				248	if ( $self->[PATH] eq '.' ) {
		100
2256	2					13	return !!1; # cwd subsumes everything relative
2257							}
2258							elsif ( $self->is_rootdir ) {
2259							# a root directory ("/", "c:/") already ends with a separator
2260	4					63	return $other->[PATH] =~ m{^\Q$self->[PATH]\E};
2261							}
2262							else {
2263							# exact match or prefix breaking at a separator
2264	90					1715	return $other->[PATH] =~ m{^\Q$self->[PATH]\E(?:/\|\z)};
2265							}
2266							}
2267
2268							#pod =method touch
2269							#pod
2270							#pod path("foo.txt")->touch;
2271							#pod path("foo.txt")->touch($epoch_secs);
2272							#pod
2273							#pod Like the Unix C utility. Creates the file if it doesn't exist, or else
2274							#pod changes the modification and access times to the current time. If the first
2275							#pod argument is the epoch seconds then it will be used.
2276							#pod
2277							#pod Returns the path object so it can be easily chained with other methods:
2278							#pod
2279							#pod # won't die if foo.txt doesn't exist
2280							#pod $content = path("foo.txt")->touch->slurp;
2281							#pod
2282							#pod Current API available since 0.015.
2283							#pod
2284							#pod =cut
2285
2286							sub touch {
2287	27			27	1	525	my ( $self, $epoch ) = @_;
2288	27	100				643	if ( !-e $self->[PATH] ) {
2289	25					91	my $fh = $self->openw;
2290	25	50				361	close $fh or $self->_throw('close');
2291							}
2292	27	100				92	if ( defined $epoch ) {
2293	1	50				23	utime $epoch, $epoch, $self->[PATH]
2294							or $self->_throw("utime ($epoch)");
2295							}
2296							else {
2297							# literal undef prevents warnings :-(
2298	26	50				420	utime undef, undef, $self->[PATH]
2299							or $self->_throw("utime ()");
2300							}
2301	27					172	return $self;
2302							}
2303
2304							#pod =method touchpath
2305							#pod
2306							#pod path("bar/baz/foo.txt")->touchpath;
2307							#pod
2308							#pod Combines C and C. Creates the parent directory if it doesn't exist,
2309							#pod before touching the file. Returns the path object like C does.
2310							#pod
2311							#pod If you need to pass options, use C and C separately:
2312							#pod
2313							#pod path("bar/baz")->mkdir( \%options )->child("foo.txt")->touch($epoch_secs);
2314							#pod
2315							#pod Current API available since 0.022.
2316							#pod
2317							#pod =cut
2318
2319							sub touchpath {
2320	16			16	1	35	my ($self) = @_;
2321	16					42	my $parent = $self->parent;
2322	16	100				38	$parent->mkdir unless $parent->exists;
2323	16					55	$self->touch;
2324							}
2325
2326							#pod =method visit
2327							#pod
2328							#pod path("/tmp")->visit( \&callback, \%options );
2329							#pod
2330							#pod Executes a callback for each child of a directory. It returns a hash
2331							#pod reference with any state accumulated during iteration.
2332							#pod
2333							#pod The options are the same as for L (which it uses internally):
2334							#pod C and C. Both default to false.
2335							#pod
2336							#pod The callback function will receive a C object as the first argument
2337							#pod and a hash reference to accumulate state as the second argument. For example:
2338							#pod
2339							#pod # collect files sizes
2340							#pod my $sizes = path("/tmp")->visit(
2341							#pod sub {
2342							#pod my ($path, $state) = @_;
2343							#pod return if $path->is_dir;
2344							#pod $state->{$path} = -s $path;
2345							#pod },
2346							#pod { recurse => 1 }
2347							#pod );
2348							#pod
2349							#pod For convenience, the C object will also be locally aliased as the
2350							#pod C<$_> global variable:
2351							#pod
2352							#pod # print paths matching /foo/
2353							#pod path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} );
2354							#pod
2355							#pod If the callback returns a B to a false scalar value, iteration will
2356							#pod terminate. This is not the same as "pruning" a directory search; this just
2357							#pod stops all iteration and returns the state hash reference.
2358							#pod
2359							#pod # find up to 10 files larger than 100K
2360							#pod my $files = path("/tmp")->visit(
2361							#pod sub {
2362							#pod my ($path, $state) = @_;
2363							#pod $state->{$path}++ if -s $path > 102400
2364							#pod return \0 if keys %$state == 10;
2365							#pod },
2366							#pod { recurse => 1 }
2367							#pod );
2368							#pod
2369							#pod If you want more flexible iteration, use a module like L.
2370							#pod
2371							#pod Current API available since 0.062.
2372							#pod
2373							#pod =cut
2374
2375							sub visit {
2376	14			14	1	1494	my $self = shift;
2377	14					27	my $cb = shift;
2378	14					41	my $args = _get_args( shift, qw/recurse follow_symlinks/ );
2379	12	50	33			70	Carp::croak("Callback for visit() must be a code reference")
2380							unless defined($cb) && ref($cb) eq 'CODE';
2381	12					36	my $next = $self->iterator($args);
2382	12					25	my $state = {};
2383	12					44	while ( my $file = $next->() ) {
2384	236					360	local $_ = $file;
2385	236					551	my $r = $cb->( $file, $state );
2386	236	100	66			951	last if ref($r) eq 'SCALAR' && !$$r;
2387							}
2388	12					197	return $state;
2389							}
2390
2391							#pod =method volume
2392							#pod
2393							#pod $vol = path("/tmp/foo.txt")->volume; # ""
2394							#pod $vol = path("C:/tmp/foo.txt")->volume; # "C:"
2395							#pod
2396							#pod Returns the volume portion of the path. This is equivalent
2397							#pod to what L would give from C and thus
2398							#pod usually is the empty string on Unix-like operating systems or the
2399							#pod drive letter for an absolute path on C.
2400							#pod
2401							#pod Current API available since 0.001.
2402							#pod
2403							#pod =cut
2404
2405							sub volume {
2406	687			687	1	1016	my ($self) = @_;
2407	687	100				1257	$self->_splitpath unless defined $self->[VOL];
2408	687					1787	return $self->[VOL];
2409							}
2410
2411							package Path::Tiny::Error;
2412
2413							our @CARP_NOT = qw/Path::Tiny/;
2414
2415	29			29		325	use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 );
	29			31		84
	29					278
	31					3497
2416
2417							sub throw {
2418	17			17		55	my ( $class, $op, $file, $err ) = @_;
2419	17					2403	chomp( my $trace = Carp::shortmess );
2420	17					667	my $msg = "Error $op on '$file': $err$trace\n";
2421	17					272	die bless { op => $op, file => $file, err => $err, msg => $msg }, $class;
2422							}
2423
2424							1;
2425
2426
2427							# vim: ts=4 sts=4 sw=4 et:
2428
2429							__END__