File Coverage

blib/lib/Path/Tiny.pm

Criterion	Covered	Total	%
statement	692	729	94.9
branch	405	486	83.3
condition	166	230	72.1
subroutine	104	106	98.1
pod	63	64	98.4
total	1430	1615	88.5

line	stmt	bran	cond	sub	pod	time	code
1	29			29		4723105	use 5.008001;
	29					118
2	29			29		4471	use strict;
	29					1902
	29					3079
3	29			29		2362	use warnings;
	29					62
	29					6774
4
5							package Path::Tiny;
6							# ABSTRACT: File path utility
7
8							our $VERSION = '0.150';
9
10							# Dependencies
11	29			29		1953	use Config;
	29					2248
	29					1828
12	29			29		1738	use Exporter 5.57 (qw/import/);
	29					537
	29					1218
13	29			29		160	use File::Spec 0.86 (); # shipped with 5.8.1
	29					2436
	29					640
14	29			29		162	use Carp ();
	29					1602
	29					6893
15
16							our @EXPORT = qw/path/;
17							our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/;
18
19							use constant {
20	29					17289	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		202	};
	29					77
28
29							use overload (
30							q{""} => 'stringify',
31							bool => sub () { 1 },
32	29					266	fallback => 1,
33	29			29		1992	);
	29					5091
34
35							# FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol
36	2			2	0	7	sub THAW { return path( $_[2] ) }
37	29			29		4149	{ no warnings 'once'; TO_JSON = FREEZE = \&stringify };
	29					58
	29					18371
38
39							my $HAS_UU; # has Unicode::UTF8; lazily populated
40
41							sub _check_UU {
42	4			4		22	local $SIG{__DIE__}; # prevent outer handler from being called
43	4					30	!!eval {
44	4					1117	require Unicode::UTF8;
45	1					1081	Unicode::UTF8->VERSION(0.58);
46	1					13	1;
47							};
48							}
49
50							my $HAS_PU; # has PerlIO::utf8_strict; lazily populated
51
52							sub _check_PU {
53	4			4		694	local $SIG{__DIE__}; # prevent outer handler from being called
54	4					10	!!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					38	require Encode;
58	4					1087	require PerlIO::utf8_strict;
59	2					2012	PerlIO::utf8_strict->VERSION(0.003);
60	2					21	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	2470			2470		7374	return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' );
91							}
92
93							BEGIN {
94	29			29		15060	*_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] };
	337			337		993
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		888969	my ( $mode, $symbolic ) = @_;
103	1173					6244	for my $clause ( split /,\s*/, $symbolic ) {
104	2366	100				11304	if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) {
105	2365					7639	my ( $who, $action, $perms ) = ( $1, $2, $3 );
106	2365					5546	$who =~ s/a/ugo/g;
107	2365					5206	for my $w ( split //, $who ) {
108	7391					9243	my $p = 0;
109	7391					20463	$p \|= $MODEBITS{"$w$_"} for split //, $perms;
110	7391	100				13315	if ( $action eq '=' ) {
111	2081					4756	$mode = ( $mode & ~$MODEBITS{"${w}m"} ) \| $p;
112							}
113							else {
114	5310	100				11419	$mode = $action eq "+" ? ( $mode \| $p ) : ( $mode & ~$p );
115							}
116							}
117							}
118							else {
119	1					189	Carp::croak("Invalid mode clause '$clause' for chmod()");
120							}
121							}
122	1172					5653	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		257	{ package flock; use warnings::register }
	29					70
	29					253440
132							#>>>
133
134							my $WARNED_NO_FLOCK = 0;
135
136							sub _throw {
137	26			26		679	my ( $self, $function, $file, $msg ) = @_;
138	26	50	33			146	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	26	100				157	$msg = $! unless defined $msg;
149	26	100				189	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	1436			1436		3708	my ( $raw, @valid ) = @_;
158	1436	100	100			6122	if ( defined($raw) && ref($raw) ne 'HASH' ) {
159	6					19	my ( undef, undef, undef, $called_as ) = caller(1);
160	6					31	$called_as =~ s{^.*::}{};
161	6					602	Carp::croak("Options for $called_as must be a hash reference");
162							}
163	1430					2520	my $cooked = {};
164	1430					2808	for my $k (@valid) {
165	2404	100				7391	$cooked->{$k} = delete $raw->{$k} if exists $raw->{$k};
166							}
167	1430	100				3825	if ( keys %$raw ) {
168	8					30	my ( undef, undef, undef, $called_as ) = caller(1);
169	8					40	$called_as =~ s{^.*::}{};
170	8					781	Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) );
171							}
172	1422					3505	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	5382981	my $path = shift;
224							Carp::croak("Path::Tiny paths require defined, positive-length parts")
225	294	100				1006	unless 1 + @_ == grep { defined && length } $path, @_;
	326	100				2635
226
227							# non-temp Path::Tiny objects are effectively immutable and can be reused
228	289	100	100			1787	if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
			66
229	4					22	return $path;
230							}
231
232							# stringify objects
233	285					524	$path = "$path";
234
235							# do any tilde expansions
236	285					1031	my ($tilde) = $path =~ m{^(~[^/]*)};
237	285	100				690	if ( defined $tilde ) {
238							# Escape File::Glob metacharacters
239	28					140	(my $escaped = $tilde) =~ s/([\[\{\*\?\\])/\\$1/g;
240	28					162	require File::Glob;
241	28					2005	my ($homedir) = File::Glob::bsd_glob($escaped);
242	28	50	33			369	if (defined $homedir && ! $File::Glob::ERROR) {
243	28					35	$homedir =~ tr[\\][/] if IS_WIN32();
244	28					577	$path =~ s{^\Q$tilde\E}{$homedir};
245							}
246							}
247
248	285					754	unshift @_, $path;
249	285					1086	goto &_pathify;
250							}
251
252							# _path is like path but without tilde expansion
253							sub _path {
254	1688			1688		3419	my $path = shift;
255							Carp::croak("Path::Tiny paths require defined, positive-length parts")
256	1688	50				5265	unless 1 + @_ == grep { defined && length } $path, @_;
	2416	50				10524
257
258							# non-temp Path::Tiny objects are effectively immutable and can be reused
259	1688	100	100			10464	if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
			100
260	118					510	return $path;
261							}
262
263							# stringify objects
264	1570					3466	$path = "$path";
265
266	1570					5391	unshift @_, $path;
267	1570					5114	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	1855			1855		3252	my $path = shift;
274
275							# expand relative volume paths on windows; put trailing slash on UNC root
276	1855					2807	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	1855	100				4304	if (@_) {
283	615	100				1339	$path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ );
284							}
285
286
287							# canonicalize, but with unix slashes and put back trailing volume slash
288	1855					9790	my $cpath = $path = File::Spec->canonpath($path);
289	1855					2866	$path =~ tr[\\][/] if IS_WIN32();
290	1855	50				4177	$path = "/" if $path eq '/..'; # for old File::Spec
291	1855					2430	$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	1855	100				3977	if ( _is_root($path) ) {
295	57					360	$path =~ s{/?\z}{/};
296							}
297							else {
298	1798					4300	$path =~ s{/\z}{};
299							}
300
301	1855					12024	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	259	sub new { shift; path(@_) }
	2					5
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	23863	require Cwd;
334	10					112	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	262161	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	1300192	my ( $opts, $maybe_template, $args )
429							= _parse_file_temp_args(tempfile => @_);
430
431							# File::Temp->new demands TEMPLATE
432	187	100				597	$args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template;
433
434	187					1549	require File::Temp;
435	187					1508	my $temp = File::Temp->new( TMPDIR => 1, %$args );
436	187					120633	close $temp;
437	187	100				1126	my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
438	187					690	$self->[TEMP] = $temp; # keep object alive while we are
439	187					981	return $self;
440							}
441
442							sub tempdir {
443	22			22	1	1364840	my ( $opts, $maybe_template, $args )
444							= _parse_file_temp_args(tempdir => @_);
445
446	22					167	require File::Temp;
447	22					207	my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args );
448	22	100				14402	my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
449	22					88	$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	22					56	$temp->{REALNAME} = $self->[CANON] if IS_WIN32;
454	22					106	return $self;
455							}
456
457							# normalize the various ways File::Temp does templates
458							sub _parse_file_temp_args {
459	209			209		598	my $called_as = shift;
460	209	100	66			1769	if ( @_ && $_[0] eq 'Path::Tiny' ) { shift } # class method
	202	100	66			399
461	7					57	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					15	push @_, DIR => $dir->stringify; # no overriding
467							}
468	209	100	100			953	my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
469	209					870	$opts = _get_args( $opts, qw/realpath/ );
470
471	209	100				921	my $leading_template = ( scalar(@_) % 2 == 1 ? shift(@_) : '' );
472	209					591	my %args = @_;
473	209					637	%args = map { uc($_), $args{$_} } keys %args;
	14					64
474							my @template = (
475							exists $args{TEMPLATE} ? delete $args{TEMPLATE}
476	209	100				844	: $leading_template ? $leading_template
		100
477							: ()
478							);
479
480	209					760	return ( $opts, \@template, \%args );
481							}
482
483							#--------------------------------------------------------------------------#
484							# Private methods
485							#--------------------------------------------------------------------------#
486
487							sub _splitpath {
488	837			837		1490	my ($self) = @_;
489	837					11198	@{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] );
	837					4123
490							}
491
492							sub _resolve_symlinks {
493	179			179		580	my ($self) = @_;
494	179					272	my $new = $self;
495	179					425	my ( $count, %seen ) = 0;
496	179					4060	while ( -l $new->[PATH] ) {
497	12	100				60	if ( $seen{ $new->[PATH] }++ ) {
498	1					5	$self->_throw( 'readlink', $self->[PATH], "symlink loop detected" );
499							}
500	11	50				33	if ( ++$count > 100 ) {
501	0					0	$self->_throw( 'readlink', $self->[PATH], "maximum symlink depth exceeded" );
502							}
503	11					334	my $resolved = readlink $new->[PATH];
504	11	50				35	$new->_throw( 'readlink', $new->[PATH] ) unless defined $resolved;
505	11					34	$resolved = _path($resolved);
506	11	100				51	$new = $resolved->is_absolute ? $resolved : $new->sibling($resolved);
507							}
508	178					593	return $new;
509							}
510
511							sub _replacement_path {
512	146			146		296	my ($self) = @_;
513
514	146					1136	my $unique_suffix = $$ . int( rand( 2**31 ) );
515	146					643	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				640	if ( length $temp->basename > 255 ) {
520	1					8	$temp = $self->sibling( "temp" . $unique_suffix );
521							}
522
523	146					351	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	280			280	1	1264	my ( $self, $base ) = @_;
553
554							# absolute paths handled differently by OS
555	280					496	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	280	100				942	return $self if $self->is_absolute;
568							}
569
570							# no base means use current directory as base
571	70					543	require Cwd;
572	70	100				916	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					16	$base = _path($base);
578	6	50				21	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	4465	my ( $self, @data ) = @_;
616	47	100	100			295	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
617	47					121	$args = _get_args( $args, qw/binmode truncate/ );
618	46					106	my $binmode = $args->{binmode};
619	46	100	100			281	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
620	46	100				162	my $mode = $args->{truncate} ? ">" : ">>";
621	46					269	my $fh = $self->filehandle( { locked => 1 }, $mode, $binmode );
622	46	100				98	print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data ) or $self->_throw('print');
	46	50				113
	91					1438
623	46	50				3160	close $fh or $self->_throw('close');
624							}
625
626							sub append_raw {
627	9			9	1	2314	my ( $self, @data ) = @_;
628	9	100	66			67	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
629	9					22	$args = _get_args( $args, qw/binmode truncate/ );
630	9					21	$args->{binmode} = ':unix';
631	9					23	append( $self, $args, @data );
632							}
633
634							sub append_utf8 {
635	9			9	1	31	my ( $self, @data ) = @_;
636	9	100	66			59	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
637	9					30	$args = _get_args( $args, qw/binmode truncate/ );
638	9	50				61	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		50
		100
		100
639	3					9	$args->{binmode} = ":unix";
640	3					10	append( $self, $args, map { Unicode::UTF8::encode_utf8($_) } @data );
	9					90
641							}
642							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
643	3					7	$args->{binmode} = ":unix:utf8_strict";
644	3					9	append( $self, $args, @data );
645							}
646							else {
647	3					9	$args->{binmode} = ":unix:encoding(UTF-8)";
648	3					8	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	7	my ( $self, $assertion ) = @_;
669	2	50				7	return $self unless $assertion;
670	2	50				8	if ( ref $assertion eq 'CODE' ) {
671	2					4	local $_ = $self;
672	2	100				7	$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	1278	my ( $self, @suffixes ) = @_;
700	169	100				732	$self->_splitpath unless defined $self->[FILE];
701	169					404	my $file = $self->[FILE];
702	169					410	for my $s (@suffixes) {
703	8	100				154	my $re = ref($s) eq 'Regexp' ? qr/$s\z/ : qr/\Q$s\E\z/;
704	8	100				71	last if $file =~ s/$re//;
705							}
706	169					640	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	9	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	17	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					14	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	420			420	1	49309	my ( $self, @parts ) = @_;
764	420					1186	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	2223	my ( $self, $filter ) = @_;
788	9					16	my $dh;
789	9	50				496	opendir $dh, $self->[PATH] or $self->_throw('opendir');
790	9					319	my @children = readdir $dh;
791	9	50				159	closedir $dh or $self->_throw('closedir');
792
793	9	100	66			46	if ( not defined $filter ) {
		100
794	7	100				19	@children = grep { $_ ne '.' && $_ ne '..' } @children;
	25					116
795							}
796							elsif ( $filter && ref($filter) eq 'Regexp' ) {
797	1	100	100			4	@children = grep { $_ ne '.' && $_ ne '..' && $_ =~ $filter } @children;
	5					84
798							}
799							else {
800	1					250	Carp::croak("Invalid argument '$filter' for children()");
801							}
802
803	8					19	return map { _path( $self->[PATH], $_ ) } @children;
	13					32
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	8229	my ( $self, $new_mode ) = @_;
829
830	6					16	my $mode;
831	6	100				45	if ( $new_mode =~ /\d/ ) {
		100
832	3	100				18	$mode = ( $new_mode =~ /^0/ ? oct($new_mode) : $new_mode );
833							}
834							elsif ( $new_mode =~ /[=+-]/ ) {
835	2					13	$mode = _symbolic_chmod( $self->stat->mode & 07777, $new_mode ); ## no critic
836							}
837							else {
838	1					226	Carp::croak("Invalid mode argument '$new_mode' for chmod()");
839							}
840
841	4	100				176	CORE::chmod( $mode, $self->[PATH] ) or $self->_throw("chmod");
842
843	3					23	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	17	my ( $self, $dest ) = @_;
861	2					14	require File::Copy;
862	2	50				11	File::Copy::copy( $self->[PATH], $dest )
863							or Carp::croak("copy failed for $self to $dest: $!");
864
865	2	100				578	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	81	my ( $self, @opts ) = @_;
888	6	100	100			43	my $args = ( @opts && ref $opts[0] eq 'HASH' ) ? shift @opts : {};
889	6					15	$args = _get_args( $args, qw/chunk_size/ );
890	6	100				13	unshift @opts, 'SHA-256' unless @opts;
891	6					28	require Digest;
892	6					26	my $digest = Digest->new(@opts);
893	6	100				3459	if ( $args->{chunk_size} ) {
894	2					9	my $fh = $self->filehandle( { locked => 1 }, "<", ":unix" );
895	2					3	my $buf;
896	2					43	while (!eof($fh)) {
897	10					34	my $rc = read $fh, $buf, $args->{chunk_size};
898	10	50				17	$self->_throw('read') unless defined $rc;
899	10					62	$digest->add($buf);
900							}
901							}
902							else {
903	4					15	$digest->add( $self->slurp_raw );
904							}
905	6					63	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	799			799	1	3190	my ($self) = @_;
927	799	100				5383	$self->_splitpath unless defined $self->[DIR];
928	799	100				4947	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					10	my $cb = shift;
956	6					16	my $args = _get_args( shift, qw/binmode/ );
957	6	50	33			68	Carp::croak("Callback for edit() must be a code reference")
958							unless defined($cb) && ref($cb) eq 'CODE';
959
960							local $_ =
961	6	50				39	$self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () );
962	6					29	$cb->();
963	6					48	$self->spew( $args, $_ );
964
965	6					48	return;
966							}
967
968							# this is done long-hand to benefit from slurp_utf8 optimizations
969							sub edit_utf8 {
970	3			3	1	11	my ( $self, $cb ) = @_;
971	3	50	33			29	Carp::croak("Callback for edit_utf8() must be a code reference")
972							unless defined($cb) && ref($cb) eq 'CODE';
973
974	3					18	local $_ = $self->slurp_utf8;
975	3					17	$cb->();
976	3					43	$self->spew_utf8($_);
977
978	3					13	return;
979							}
980
981	3			3	1	33	sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit }
	3					11
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	51	my $self = shift;
1013	9					15	my $cb = shift;
1014	9					23	my $args = _get_args( shift, qw/binmode/ );
1015	9	50	33			55	Carp::croak("Callback for edit_lines() must be a code reference")
1016							unless defined($cb) && ref($cb) eq 'CODE';
1017
1018	9					19	my $binmode = $args->{binmode};
1019							# get default binmode from caller's lexical scope (see "perldoc open")
1020	9	50	0			26	$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					26	my $resolved_path = $self->_resolve_symlinks;
1025	9					24	my $temp = $resolved_path->_replacement_path;
1026
1027	9					44	my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
1028	9					66	my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode );
1029
1030	9					21	local $_;
1031	9					239	while (! eof($in_fh) ) {
1032	36	50				321	defined( $_ = readline($in_fh) ) or $self->_throw('readline');
1033	36					78	$cb->();
1034	36	50				227	$temp_fh->print($_) or $self->_throw('print', $temp);
1035							}
1036
1037	9	50				1206	close $temp_fh or $self->_throw( 'close', $temp );
1038	9	50				107	close $in_fh or $self->_throw('close');
1039
1040	9					38	return $temp->move($resolved_path);
1041							}
1042
1043	3			3	1	33	sub edit_lines_raw { $_[2] = { binmode => ":raw" }; goto &edit_lines }
	3					11
1044
1045							sub edit_lines_utf8 {
1046	3	50		3	1	38	if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
		100
1047	2					10	$_[2] = { binmode => ":raw:utf8_strict" };
1048							}
1049							else {
1050	1					3	$_[2] = { binmode => ":raw:encoding(UTF-8)" };
1051							}
1052	3					182	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	1083	sub exists { -e $_[0]->[PATH] }
1075
1076	32	100		32	1	347	sub is_file { -e $_[0]->[PATH] && !-d _ }
1077
1078	6			6	1	103	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	1418	my ( $self, @args ) = @_;
1112	555	100	66			2474	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1113	555					1189	$args = _get_args( $args, qw/locked exclusive/ );
1114	555	100				1502	$args->{locked} = 1 if $args->{exclusive};
1115	555					1213	my ( $opentype, $binmode ) = @args;
1116
1117	555	100				1190	$opentype = "<" unless defined $opentype;
1118							Carp::croak("Invalid file mode '$opentype'")
1119	555	50				1130	unless grep { $opentype eq $_ } qw/< +< > +> >> +>>/;
	3330					6438
1120
1121	555	100	50			2619	$binmode = ( ( caller(0) )[10] \|\| {} )->{ 'open' . substr( $opentype, -1, 1 ) }
1122							unless defined $binmode;
1123	555	100				1579	$binmode = "" unless defined $binmode;
1124
1125	555					971	my ( $fh, $lock, $trunc );
1126	555	100	66			3100	if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) {
			100
1127	448					2977	require Fcntl;
1128							# truncating file modes shouldn't truncate until lock acquired
1129	448	100	33			804	if ( grep { $opentype eq $_ } qw( > +> ) ) {
	896	50				2641
1130							# sysopen in write mode without truncation
1131	155	50				437	my $flags = $opentype eq ">" ? Fcntl::O_WRONLY() : Fcntl::O_RDWR();
1132	155					319	$flags \|= Fcntl::O_CREAT();
1133	155	100				440	$flags \|= Fcntl::O_EXCL() if $args->{exclusive};
1134	155	100				22968	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				1129	if ( $binmode =~ s/^:unix// ) {
1139							# eliminate pseudo-layers
1140	67	50				412	binmode( $fh, ":raw" ) or $self->_throw("binmode (:raw)");
1141							# strip off real layers until only :unix is left
1142	67					711	while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
1143	67	50				478	binmode( $fh, ":pop" ) or $self->_throw("binmode (:pop)");
1144							}
1145							}
1146
1147							# apply any remaining binmode layers
1148	154	100				420	if ( length $binmode ) {
1149	46	50		2		463	binmode( $fh, $binmode ) or $self->_throw("binmode ($binmode)");
	2					714
	2					863
	2					13
1150							}
1151
1152							# ask for lock and truncation
1153	154					2327	$lock = Fcntl::LOCK_EX();
1154	154					301	$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				718	$lock = $opentype eq "<" ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX();
1168							}
1169							}
1170
1171	554	100				1260	unless ($fh) {
1172	400					819	my $mode = $opentype . $binmode;
1173	400	100				25418	open $fh, $mode, $self->[PATH] or $self->_throw("open ($mode)");
1174							}
1175
1176	551	50				4507	do { flock( $fh, $lock ) or $self->_throw("flock ($lock)") } if $lock;
	444	100				3808
1177	551	50				1228	do { truncate( $fh, 0 ) or $self->_throw("truncate") } if $trunc;
	154	100				7623
1178
1179	551					2904	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	4215	my ($self, $other_path) = @_;
1201	11					31	my $other = _path($other_path);
1202
1203	11					64	my $fh1 = $self->openr_raw({ locked => 1 });
1204	10					39	my $fh2 = $other->openr_raw({ locked => 1 });
1205
1206							# check for directories
1207	9	100				90	if (-d $fh1) {
1208	3					15	$self->_throw('has_same_bytes', $self->[PATH], "directory not allowed");
1209							}
1210	6	100				29	if (-d $fh2) {
1211	1					4	$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				28	if ($self->realpath eq $other->realpath) {
1217	3					74	return 1
1218							}
1219
1220							# result is 0 for equal, 1 for unequal, -1 for error
1221	2					610	require File::Compare;
1222	2					895	my $res = File::Compare::compare($fh1, $fh2, 65536);
1223	2	50				268	if ($res < 0) {
1224	0					0	$self->_throw('has_same_bytes')
1225							}
1226
1227	2					40	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	648			648	1	3168	sub is_absolute { substr( $_[0]->dirname, 0, 1 ) eq '/' }
1242
1243	145			145	1	776	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	333	my ($self) = @_;
1266	164	100				431	$self->_splitpath unless defined $self->[DIR];
1267	164		100			616	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	2649	my $self = shift;
1309	20					73	my $args = _get_args( shift, qw/recurse follow_symlinks/ );
1310	18					64	my @dirs = $self;
1311	18					39	my $current;
1312							return sub {
1313	294			294		1386	my $next;
1314	294					819	while (@dirs) {
1315	350	100				917	if ( ref $dirs[0] eq 'Path::Tiny' ) {
1316	75	100				336	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				10	shift @dirs and next;
1324							}
1325	74					175	$current = $dirs[0];
1326	74					124	my $dh;
1327	74	50				2605	opendir( $dh, $current->[PATH] )
1328							or $self->_throw( 'opendir', $current->[PATH] );
1329	74					171	$dirs[0] = $dh;
1330	74	50	66			873	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	349					3489	while ( defined( $next = readdir $dirs[0] ) ) {
1339	425	100	100			1719	next if $next eq '.' \|\| $next eq '..';
1340	277					781	my $path = $current->child($next);
1341							push @dirs, $path
1342	277	100	100			1918	if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path );
			100
			100
1343	277					1449	return $path;
1344							}
1345	72					1153	shift @dirs;
1346							}
1347	17					66	return;
1348	18					274	};
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 See also L if you want to load a file as a whole chunk.
1389							#pod
1390							#pod Current API available since 0.065.
1391							#pod
1392							#pod =cut
1393
1394							sub lines {
1395	112			112	1	10894	my $self = shift;
1396	112					309	my $args = _get_args( shift, qw/binmode chomp count/ );
1397	110					259	my $binmode = $args->{binmode};
1398	110	100	100			778	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open<'} unless defined $binmode;
1399	110					530	my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
1400	110					345	my $chomp = $args->{chomp};
1401							# XXX more efficient to read @lines then chomp(@lines) vs map?
1402	110	100				317	if ( $args->{count} ) {
		100
1403	84					253	my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) );
1404	84					200	my $line;
1405	84					2295	while ( !eof($fh) ) {
1406	216	50				1037	defined( $line = readline($fh) ) or $self->_throw('readline');
1407
1408	216	100				910	$line =~ s/(?:\x{0d}?\x{0a}\|\x{0d})\z// if $chomp;
1409	216					439	$result[ $counter++ ] = $line;
1410							# for positive count, terminate after right number of lines
1411	216	100				571	last if $counter == $args->{count};
1412							# for negative count, eventually wrap around in the result array
1413	180					657	$counter %= $mod;
1414							}
1415							# reorder results if full and wrapped somewhere in the middle
1416	84	100	100			408	splice( @result, 0, 0, splice( @result, $counter ) )
1417							if @result == $mod && $counter % $mod;
1418	84					3838	return @result;
1419							}
1420							elsif ($chomp) {
1421	6					57	local $!;
1422	6					241	my @lines = map { s/(?:\x{0d}?\x{0a}\|\x{0d})\z//; $_ } <$fh>; ## no critic
	21					184
	21					58
1423	6	50				32	$self->_throw('readline') if $!;
1424	6					240	return @lines;
1425							}
1426							else {
1427	20	100				53	if ( wantarray ) {
1428	14					111	local $!;
1429	14					481	my @lines = <$fh>;
1430	14	50				80	$self->_throw('readline') if $!;
1431	14					359	return @lines;
1432							} else {
1433	6					46	local $!;
1434	6					176	my $count =()= <$fh>;
1435	6	50				32	$self->_throw('readline') if $!;
1436	6					127	return $count;
1437							}
1438							}
1439							}
1440
1441							sub lines_raw {
1442	17			17	1	38	my $self = shift;
1443	17					56	my $args = _get_args( shift, qw/binmode chomp count/ );
1444	15	50	33			66	if ( $args->{chomp} && !$args->{count} ) {
1445	0					0	return split /\n/, slurp_raw($self); ## no critic
1446							}
1447							else {
1448	15					35	$args->{binmode} = ":raw";
1449	15					81	return lines( $self, $args );
1450							}
1451							}
1452
1453							my $CRLF = qr/(?:\x{0d}?\x{0a}\|\x{0d})/;
1454
1455							sub lines_utf8 {
1456	35			35	1	83	my $self = shift;
1457	35					117	my $args = _get_args( shift, qw/binmode chomp count/ );
1458	33	50	100			264	if ( ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) )
		100	100
		100
		100
1459							&& $args->{chomp}
1460							&& !$args->{count} )
1461							{
1462	2					7	my $slurp = slurp_utf8($self);
1463	2					65	$slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF\|CR
1464	2					38	return split $CRLF, $slurp, -1; ## no critic
1465							}
1466							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
1467	20					52	$args->{binmode} = ":raw:utf8_strict";
1468	20					93	return lines( $self, $args );
1469							}
1470							else {
1471	11					29	$args->{binmode} = ":raw:encoding(UTF-8)";
1472	11					52	return lines( $self, $args );
1473							}
1474							}
1475
1476							#pod =method mkdir
1477							#pod
1478							#pod path("foo/bar/baz")->mkdir;
1479							#pod path("foo/bar/baz")->mkdir( \%options );
1480							#pod
1481							#pod Like calling C from L. An optional hash reference
1482							#pod is passed through to C. Errors will be trapped and an exception
1483							#pod thrown. Returns the the path object to facilitate chaining.
1484							#pod
1485							#pod B: unlike Perl's builtin C, this will create intermediate paths
1486							#pod similar to the Unix C command. It will not error if applied to an
1487							#pod existing directory.
1488							#pod
1489							#pod Passing a defined argument I than a hash reference is an error, and an
1490							#pod exception will be thrown.
1491							#pod
1492							#pod Current API available since 0.125.
1493							#pod
1494							#pod =cut
1495
1496							sub mkdir {
1497	53			53	1	1442	my ( $self, $args, @rest ) = @_;
1498
1499	53	100				194	$args = {} unless defined $args;
1500	53	100	66			401	if (@rest \|\| (defined $args && ref $args ne 'HASH')) {
			100
1501	4					8	$self->_throw('mkdir', undef, "method argument was given, but was not a hash reference");
1502							}
1503
1504	49					77	my $err;
1505
1506	49	50				213	$args->{error} = \$err unless defined $args->{error};
1507	49					328	require File::Path;
1508	49					76	my @dirs;
1509	49					144	my $ok = eval {
1510	49					17163	File::Path::make_path( $self->[PATH], $args );
1511	49					233	1;
1512							};
1513	49	50				164	if (!$ok) {
1514	0					0	$self->_throw('mkdir', $self->[PATH], "error creating path: $@");
1515							}
1516	49	50	33			284	if ( $err && @$err ) {
1517	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1518	0					0	$self->_throw('mkdir', $file, $message);
1519							}
1520	49					271	return $self;
1521							}
1522
1523							#pod =method mkpath (deprecated)
1524							#pod
1525							#pod Like calling C, but returns the list of directories created or an empty list if
1526							#pod the directories already exist, just like C.
1527							#pod
1528							#pod Passing a defined argument I than a hash reference is an error, and an
1529							#pod exception will be thrown.
1530							#pod
1531							#pod Deprecated in 0.125.
1532							#pod
1533							#pod =cut
1534
1535							sub mkpath {
1536	6			6	1	1126	my ( $self, $args, @rest ) = @_;
1537
1538	6	100				17	$args = {} unless defined $args;
1539	6	100	66			33	if (@rest \|\| (defined $args && ref $args ne 'HASH')) {
			100
1540	4					30	$self->_throw('mkdir', undef, "method argument was given, but was not a hash reference");
1541							}
1542
1543	2					3	my $err;
1544	2	50				7	$args->{error} = \$err unless defined $args->{error};
1545	2					15	require File::Path;
1546	2					1438	my @dirs = File::Path::make_path( $self->[PATH], $args );
1547	2	50	33			13	if ( $err && @$err ) {
1548	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1549	0					0	Carp::croak("mkpath failed for $file: $message");
1550							}
1551	2					11	return @dirs;
1552							}
1553
1554							#pod =method move
1555							#pod
1556							#pod path("foo.txt")->move("bar.txt");
1557							#pod
1558							#pod Moves the current path to the given destination using L's
1559							#pod C function. Upon success, returns the C object for the
1560							#pod newly moved file.
1561							#pod
1562							#pod If the destination already exists and is a directory, and the source is not a
1563							#pod directory, then the source file will be renamed into the directory
1564							#pod specified by the destination.
1565							#pod
1566							#pod If possible, move() will simply rename the file. Otherwise, it
1567							#pod copies the file to the new location and deletes the original. If an
1568							#pod error occurs during this copy-and-delete process, you may be left
1569							#pod with a (possibly partial) copy of the file under the destination
1570							#pod name.
1571							#pod
1572							#pod Current API available since 0.124. Prior versions used Perl's
1573							#pod -built-in (and less robust) L function
1574							#pod and did not return an object.
1575							#pod
1576							#pod =cut
1577
1578							sub move {
1579	149			149	1	526	my ( $self, $dest ) = @_;
1580	149					5031	require File::Copy;
1581	149	100				34251	File::Copy::move( $self->[PATH], $dest )
1582							or $self->_throw( 'move', $self->[PATH] . "' -> '$dest" );
1583
1584	148	100				2085	return -d $dest ? _path( $dest, $self->basename ) : _path($dest);
1585							}
1586
1587							#pod =method openr, openw, openrw, opena
1588							#pod
1589							#pod $fh = path("foo.txt")->openr($binmode); # read
1590							#pod $fh = path("foo.txt")->openr_raw;
1591							#pod $fh = path("foo.txt")->openr_utf8;
1592							#pod
1593							#pod $fh = path("foo.txt")->openw($binmode); # write
1594							#pod $fh = path("foo.txt")->openw_raw;
1595							#pod $fh = path("foo.txt")->openw_utf8;
1596							#pod
1597							#pod $fh = path("foo.txt")->opena($binmode); # append
1598							#pod $fh = path("foo.txt")->opena_raw;
1599							#pod $fh = path("foo.txt")->opena_utf8;
1600							#pod
1601							#pod $fh = path("foo.txt")->openrw($binmode); # read/write
1602							#pod $fh = path("foo.txt")->openrw_raw;
1603							#pod $fh = path("foo.txt")->openrw_utf8;
1604							#pod
1605							#pod Returns a file handle opened in the specified mode. The C style methods
1606							#pod take a single C argument. All of the C methods have
1607							#pod C and C equivalents that use buffered I/O layers C<:raw>
1608							#pod and C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
1609							#pod L).
1610							#pod
1611							#pod An optional hash reference may be used to pass options. The only option is
1612							#pod C. If true, handles opened for writing, appending or read-write are
1613							#pod locked with C; otherwise, they are locked for C.
1614							#pod
1615							#pod $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );
1616							#pod
1617							#pod See L for more on locking.
1618							#pod
1619							#pod Current API available since 0.011.
1620							#pod
1621							#pod =cut
1622
1623							# map method names to corresponding open mode
1624							my %opens = (
1625							opena => ">>",
1626							openr => "<",
1627							openw => ">",
1628							openrw => "+<"
1629							);
1630
1631							while ( my ( $k, $v ) = each %opens ) {
1632	29			29		318	no strict 'refs';
	29					74
	29					149504
1633							# must check for lexical IO mode hint
1634							*{$k} = sub {
1635	70			70		15465	my ( $self, @args ) = @_;
1636	70	100	100			345	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1637	70					371	$args = _get_args( $args, qw/locked/ );
1638	70					146	my ($binmode) = @args;
1639	70	100	100			1030	$binmode = ( ( caller(0) )[10] \|\| {} )->{ 'open' . substr( $v, -1, 1 ) }
1640							unless defined $binmode;
1641	70					419	$self->filehandle( $args, $v, $binmode );
1642							};
1643							*{ $k . "_raw" } = sub {
1644	39			39		6315	my ( $self, @args ) = @_;
1645	39	100	66			188	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1646	39					120	$args = _get_args( $args, qw/locked/ );
1647	39					136	$self->filehandle( $args, $v, ":raw" );
1648							};
1649							*{ $k . "_utf8" } = sub {
1650	18			18		6068	my ( $self, @args ) = @_;
1651	18	50	33			100	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1652	18					74	$args = _get_args( $args, qw/locked/ );
1653	18					28	my $layer;
1654	18	50				64	if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
		100
1655	12					43	$layer = ":raw:utf8_strict";
1656							}
1657							else {
1658	6					9	$layer = ":raw:encoding(UTF-8)";
1659							}
1660	18					98	$self->filehandle( $args, $v, $layer );
1661							};
1662							}
1663
1664							#pod =method parent
1665							#pod
1666							#pod $parent = path("foo/bar/baz")->parent; # foo/bar
1667							#pod $parent = path("foo/wibble.txt")->parent; # foo
1668							#pod
1669							#pod $parent = path("foo/bar/baz")->parent(2); # foo
1670							#pod
1671							#pod Returns a C object corresponding to the parent directory of the
1672							#pod original directory or file. An optional positive integer argument is the number
1673							#pod of parent directories upwards to return. C by itself is equivalent to
1674							#pod C.
1675							#pod
1676							#pod Current API available since 0.014.
1677							#pod
1678							#pod =cut
1679
1680							# XXX this is ugly and coverage is incomplete. I think it's there for windows
1681							# so need to check coverage there and compare
1682							sub parent {
1683	358			358	1	2464	my ( $self, $level ) = @_;
1684	358	100	100			1169	$level = 1 unless defined $level && $level > 0;
1685	358	100				1510	$self->_splitpath unless defined $self->[FILE];
1686	358					584	my $parent;
1687	358	100				854	if ( length $self->[FILE] ) {
		50
1688	316	100	100			1262	if ( $self->[FILE] eq '.' \|\| $self->[FILE] eq ".." ) {
1689	58					173	$parent = _path( $self->[PATH] . "/.." );
1690							}
1691							else {
1692	258					839	$parent = _path( _non_empty( $self->[VOL] . $self->[DIR] ) );
1693							}
1694							}
1695							elsif ( length $self->[DIR] ) {
1696							# because of symlinks, any internal updir requires us to
1697							# just add more updirs at the end
1698	42	100				247	if ( $self->[DIR] =~ m{(?:^\.\./\|/\.\./\|/\.\.\z)} ) {
1699	35					134	$parent = _path( $self->[VOL] . $self->[DIR] . "/.." );
1700							}
1701							else {
1702	7					13	( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/};
1703	7					18	$parent = _path( $self->[VOL] . $dir );
1704							}
1705							}
1706							else {
1707	0					0	$parent = _path( _non_empty( $self->[VOL] ) );
1708							}
1709	358	100				2285	return $level == 1 ? $parent : $parent->parent( $level - 1 );
1710							}
1711
1712							sub _non_empty {
1713	258			258		502	my ($string) = shift;
1714	258	100	66			1093	return ( ( defined($string) && length($string) ) ? $string : "." );
1715							}
1716
1717							#pod =method realpath
1718							#pod
1719							#pod $real = path("/baz/foo/../bar")->realpath;
1720							#pod $real = path("foo/../bar")->realpath;
1721							#pod
1722							#pod Returns a new C object with all symbolic links and upward directory
1723							#pod parts resolved using L's C. Compared to C, this is
1724							#pod more expensive as it must actually consult the filesystem.
1725							#pod
1726							#pod If the parent path can't be resolved (e.g. if it includes directories that
1727							#pod don't exist), an exception will be thrown:
1728							#pod
1729							#pod $real = path("doesnt_exist/foo")->realpath; # dies
1730							#pod
1731							#pod However, if the parent path exists and only the last component (e.g. filename)
1732							#pod doesn't exist, the realpath will be the realpath of the parent plus the
1733							#pod non-existent last component:
1734							#pod
1735							#pod $real = path("./aasdlfasdlf")->realpath; # works
1736							#pod
1737							#pod The underlying L module usually worked this way on Unix, but died on
1738							#pod Windows (and some Unixes) if the full path didn't exist. As of version 0.064,
1739							#pod it's safe to use anywhere.
1740							#pod
1741							#pod Current API available since 0.001.
1742							#pod
1743							#pod =cut
1744
1745							# Win32 and some Unixes need parent path resolved separately so realpath
1746							# doesn't throw an error resolving non-existent basename
1747							sub realpath {
1748	33			33	1	779	my $self = shift;
1749	33					86	$self = $self->_resolve_symlinks;
1750	32					227	require Cwd;
1751	32	100				117	$self->_splitpath if !defined $self->[FILE];
1752	32		100			171	my $check_parent =
1753							length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..';
1754	32					58	my $realpath = eval {
1755							# pure-perl Cwd can carp
1756	32			0		258	local $SIG{__WARN__} = sub { };
1757	32	100				296	Cwd::realpath( $check_parent ? $self->parent->[PATH] : $self->[PATH] );
1758							};
1759							# parent realpath must exist; not all Cwd::realpath will error if it doesn't
1760	32	100	33			533	$self->_throw("resolving realpath")
			66
1761							unless defined $realpath && length $realpath && -e $realpath;
1762	31	100				115	return ( $check_parent ? _path( $realpath, $self->[FILE] ) : _path($realpath) );
1763							}
1764
1765							#pod =method relative
1766							#pod
1767							#pod $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
1768							#pod
1769							#pod Returns a C object with a path relative to a new base path
1770							#pod given as an argument. If no argument is given, the current directory will
1771							#pod be used as the new base path.
1772							#pod
1773							#pod If either path is already relative, it will be made absolute based on the
1774							#pod current directly before determining the new relative path.
1775							#pod
1776							#pod The algorithm is roughly as follows:
1777							#pod
1778							#pod =for :list
1779							#pod * If the original and new base path are on different volumes, an exception
1780							#pod will be thrown.
1781							#pod * If the original and new base are identical, the relative path is C<".">.
1782							#pod * If the new base subsumes the original, the relative path is the original
1783							#pod path with the new base chopped off the front
1784							#pod * If the new base does not subsume the original, a common prefix path is
1785							#pod determined (possibly the root directory) and the relative path will
1786							#pod consist of updirs (C<"..">) to reach the common prefix, followed by the
1787							#pod original path less the common prefix.
1788							#pod
1789							#pod Unlike C, in the last case above, the calculation based
1790							#pod on a common prefix takes into account symlinks that could affect the updir
1791							#pod process. Given an original path "/A/B" and a new base "/A/C",
1792							#pod (where "A", "B" and "C" could each have multiple path components):
1793							#pod
1794							#pod =for :list
1795							#pod * Symlinks in "A" don't change the result unless the last component of A is
1796							#pod a symlink and the first component of "C" is an updir.
1797							#pod * Symlinks in "B" don't change the result and will exist in the result as
1798							#pod given.
1799							#pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into
1800							#pod account the possibility that not all path components might exist on the
1801							#pod filesystem.
1802							#pod
1803							#pod Current API available since 0.001. New algorithm (that accounts for
1804							#pod symlinks) available since 0.079.
1805							#pod
1806							#pod =cut
1807
1808							sub relative {
1809	72			72	1	243	my ( $self, $base ) = @_;
1810	72	100	100			357	$base = _path( defined $base && length $base ? $base : '.' );
1811
1812							# relative paths must be converted to absolute first
1813	72	100				258	$self = $self->absolute if $self->is_relative;
1814	72	100				180	$base = $base->absolute if $base->is_relative;
1815
1816							# normalize volumes if they exist
1817	72	50	33			300	$self = $self->absolute if !length $self->volume && length $base->volume;
1818	72	50	33			189	$base = $base->absolute if length $self->volume && !length $base->volume;
1819
1820							# can't make paths relative across volumes
1821	72	50				155	if ( !_same( $self->volume, $base->volume ) ) {
1822	0					0	Carp::croak("relative() can't cross volumes: '$self' vs '$base'");
1823							}
1824
1825							# if same absolute path, relative is current directory
1826	72	100				194	return _path(".") if _same( $self->[PATH], $base->[PATH] );
1827
1828							# if base is a prefix of self, chop prefix off self
1829	66	100				189	if ( $base->subsumes($self) ) {
1830	20	100				63	$base = "" if $base->is_rootdir;
1831	20					54	my $relative = "$self";
1832	20					91	$relative =~ s{\A\Q$base/}{};
1833	20					67	return _path(".", $relative);
1834							}
1835
1836							# base is not a prefix, so must find a common prefix (even if root)
1837	46					124	my ( @common, @self_parts, @base_parts );
1838	46					129	@base_parts = split /\//, $base->_just_filepath;
1839
1840							# if self is rootdir, then common directory is root (shown as empty
1841							# string for later joins); otherwise, must be computed from path parts.
1842	46	100				145	if ( $self->is_rootdir ) {
1843	6					17	@common = ("");
1844	6					13	shift @base_parts;
1845							}
1846							else {
1847	40					860	@self_parts = split /\//, $self->_just_filepath;
1848
1849	40		66			230	while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) {
			100
1850	154					300	push @common, shift @base_parts;
1851	154					607	shift @self_parts;
1852							}
1853							}
1854
1855							# if there are any symlinks from common to base, we have a problem, as
1856							# you can't guarantee that updir from base reaches the common prefix;
1857							# we must resolve symlinks and try again; likewise, any updirs are
1858							# a problem as it throws off calculation of updirs needed to get from
1859							# self's path to the common prefix.
1860	46	100				162	if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) {
1861	6					29	return $self->relative($new_base);
1862							}
1863
1864							# otherwise, symlinks in common or from common to A don't matter as
1865							# those don't involve updirs
1866	40					213	my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts );
1867	40					155	return _path(@new_path);
1868							}
1869
1870							sub _just_filepath {
1871	87			87		146	my $self = shift;
1872	87					237	my $self_vol = $self->volume;
1873	87	50				290	return "$self" if !length $self_vol;
1874
1875	0					0	( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{};
1876
1877	0					0	return $self_path;
1878							}
1879
1880							sub _resolve_between {
1881	46			46		105	my ( $self, $common, $base ) = @_;
1882	46					92	my $path = $self->volume . join( "/", @$common );
1883	46					74	my $changed = 0;
1884	46					147	for my $p (@$base) {
1885	141					300	$path .= "/$p";
1886	141	100				355	if ( $p eq '..' ) {
1887	4					7	$changed = 1;
1888	4	100				64	if ( -e $path ) {
1889	2					7	$path = _path($path)->realpath->[PATH];
1890							}
1891							else {
1892	2					23	$path =~ s{/[^/]+/..\z}{/};
1893							}
1894							}
1895	141	100				3278	if ( -l $path ) {
1896	2					7	$changed = 1;
1897	2					6	$path = _path($path)->realpath->[PATH];
1898							}
1899							}
1900	46	100				237	return $changed ? _path($path) : undef;
1901							}
1902
1903							#pod =method remove
1904							#pod
1905							#pod path("foo.txt")->remove;
1906							#pod
1907							#pod This is just like C, except for its error handling: if the path does
1908							#pod not exist, it returns false; if deleting the file fails, it throws an
1909							#pod exception.
1910							#pod
1911							#pod Current API available since 0.012.
1912							#pod
1913							#pod =cut
1914
1915							sub remove {
1916	10			10	1	1248	my $self = shift;
1917
1918	10	100	100			324	return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1919
1920	9		66			941	return unlink( $self->[PATH] ) \|\| $self->_throw('unlink');
1921							}
1922
1923							#pod =method remove_tree
1924							#pod
1925							#pod # directory
1926							#pod path("foo/bar/baz")->remove_tree;
1927							#pod path("foo/bar/baz")->remove_tree( \%options );
1928							#pod path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove
1929							#pod
1930							#pod Like calling C from L, but defaults to C mode.
1931							#pod An optional hash reference is passed through to C. Errors will be
1932							#pod trapped and an exception thrown. Returns the number of directories deleted,
1933							#pod just like C.
1934							#pod
1935							#pod If you want to remove a directory only if it is empty, use the built-in
1936							#pod C function instead.
1937							#pod
1938							#pod rmdir path("foo/bar/baz/");
1939							#pod
1940							#pod Current API available since 0.013.
1941							#pod
1942							#pod Passing a defined argument I than a hash reference is an error, and an
1943							#pod exception will be thrown.
1944							#pod
1945							#pod =cut
1946
1947							sub remove_tree {
1948	23			23	1	520	my ( $self, $args, @rest ) = @_;
1949
1950	23	100				79	$args = {} unless defined $args;
1951	23	100	66			181	if (@rest \|\| (defined $args && ref $args ne 'HASH')) {
			66
1952	1					7	$self->_throw('mkdir', undef, "method argument was given, but was not a hash reference");
1953							}
1954
1955	22	100	100			703	return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1956
1957	20					74	my $err;
1958	20	50				97	$args->{error} = \$err unless defined $args->{error};
1959	20	100				73	$args->{safe} = 1 unless defined $args->{safe};
1960	20					153	require File::Path;
1961	20					17288	my $count = File::Path::remove_tree( $self->[PATH], $args );
1962
1963	20	50	33			167	if ( $err && @$err ) {
1964	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1965	0					0	Carp::croak("remove_tree failed for $file: $message");
1966							}
1967	20					115	return $count;
1968							}
1969
1970							#pod =method sibling
1971							#pod
1972							#pod $foo = path("/tmp/foo.txt");
1973							#pod $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt
1974							#pod $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt
1975							#pod
1976							#pod Returns a new C object relative to the parent of the original.
1977							#pod This is slightly more efficient than C<< $path->parent->child(...) >>.
1978							#pod
1979							#pod Current API available since 0.058.
1980							#pod
1981							#pod =cut
1982
1983							sub sibling {
1984	6			6	1	10	my $self = shift;
1985	6					17	return _path( $self->parent->[PATH], @_ );
1986							}
1987
1988							#pod =method size, size_human
1989							#pod
1990							#pod my $p = path("foo"); # with size 1025 bytes
1991							#pod
1992							#pod $p->size; # "1025"
1993							#pod $p->size_human; # "1.1 K"
1994							#pod $p->size_human( {format => "iec"} ); # "1.1 KiB"
1995							#pod
1996							#pod Returns the size of a file. The C method is just a wrapper around C<-s>.
1997							#pod
1998							#pod The C method provides a human-readable string similar to
1999							#pod C. Like C, it rounds upwards and provides one decimal place for
2000							#pod single-digit sizes and no decimal places for larger sizes. The only available
2001							#pod option is C, which has three valid values:
2002							#pod
2003							#pod =for :list
2004							#pod * 'ls' (the default): base-2 sizes, with C style single-letter suffixes (K, M, etc.)
2005							#pod * 'iec': base-2 sizes, with IEC binary suffixes (KiB, MiB, etc.)
2006							#pod * 'si': base-10 sizes, with SI decimal suffixes (kB, MB, etc.)
2007							#pod
2008							#pod If C<-s> would return C, C returns the empty string.
2009							#pod
2010							#pod Current API available since 0.122.
2011							#pod
2012							#pod =cut
2013
2014	1			1	1	19	sub size { -s $_[0]->[PATH] }
2015
2016							my %formats = (
2017							'ls' => [ 1024, log(1024), [ "", map { " $_" } qw/K M G T/ ] ],
2018							'iec' => [ 1024, log(1024), [ "", map { " $_" } qw/KiB MiB GiB TiB/ ] ],
2019							'si' => [ 1000, log(1000), [ "", map { " $_" } qw/kB MB GB TB/ ] ],
2020							);
2021
2022	93			93		98725	sub _formats { return $formats{$_[0]} }
2023
2024							sub size_human {
2025	7			7	1	26	my $self = shift;
2026	7					21	my $args = _get_args( shift, qw/format/ );
2027	7	100				22	my $format = defined $args->{format} ? $args->{format} : "ls";
2028	7	100				211	my $fmt_opts = $formats{$format}
2029							or Carp::croak("Invalid format '$format' for size_human()");
2030	6					160	my $size = -s $self->[PATH];
2031	6	100				31	return defined $size ? _human_size( $size, @$fmt_opts ) : "";
2032							}
2033
2034							sub _ceil {
2035	92	100		92		344	return $_[0] == int($_[0]) ? $_[0] : int($_[0]+1);
2036							}
2037
2038							sub _human_size {
2039	98			98		471	my ( $size, $base, $log_base, $suffixes ) = @_;
2040	98	100				295	return "0" if $size == 0;
2041
2042	95					345	my $mag = int( log($size) / $log_base );
2043	95					214	$size /= $base**$mag;
2044	95	100				384	$size =
		100
2045							$mag == 0 ? $size
2046							: length( int($size) ) == 1 ? _ceil( $size * 10 ) / 10
2047							: _ceil($size);
2048	95	100				243	if ( $size >= $base ) {
2049	9					20	$size /= $base;
2050	9					19	$mag++;
2051							}
2052
2053	95	100	100			440	my $fmt = ( $mag == 0 \|\| length( int($size) ) > 1 ) ? "%.0f%s" : "%.1f%s";
2054	95					786	return sprintf( $fmt, $size, $suffixes->[$mag] );
2055							}
2056
2057							#pod =method slurp, slurp_raw, slurp_utf8
2058							#pod
2059							#pod $data = path("foo.txt")->slurp;
2060							#pod $data = path("foo.txt")->slurp( {binmode => ":raw"} );
2061							#pod $data = path("foo.txt")->slurp_raw;
2062							#pod $data = path("foo.txt")->slurp_utf8;
2063							#pod
2064							#pod Reads file contents into a scalar. Takes an optional hash reference which may
2065							#pod be used to pass options. The only available option is C, which is
2066							#pod passed to C on the handle used for reading.
2067							#pod
2068							#pod C is like C with a C of C<:unix> for
2069							#pod a fast, unbuffered, raw read.
2070							#pod
2071							#pod C is like C with a C of
2072							#pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
2073							#pod L). If L 0.58+ is installed, a
2074							#pod unbuffered, raw slurp will be done instead and the result decoded with
2075							#pod C. This is just as strict and is roughly an order of
2076							#pod magnitude faster than using C<:encoding(UTF-8)>.
2077							#pod
2078							#pod B: C and friends lock the filehandle before slurping. If
2079							#pod you plan to slurp from a file created with L, be sure to
2080							#pod close other handles or open without locking to avoid a deadlock:
2081							#pod
2082							#pod my $tempfile = File::Temp->new(EXLOCK => 0);
2083							#pod my $guts = path($tempfile)->slurp;
2084							#pod
2085							#pod See also L if you want to slurp a file into a line array.
2086							#pod
2087							#pod Current API available since 0.004.
2088							#pod
2089							#pod =cut
2090
2091							sub slurp {
2092	116			116	1	2911	my $self = shift;
2093	116					358	my $args = _get_args( shift, qw/binmode/ );
2094	114					279	my $binmode = $args->{binmode};
2095	114	100	100			692	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open<'} unless defined $binmode;
2096	114					492	my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
2097	113	100	66			804	if ( ( defined($binmode) ? $binmode : "" ) eq ":unix"
		100
2098							and my $size = -s $fh )
2099							{
2100	41					69	my $buf;
2101	41					540	my $rc = read $fh, $buf, $size; # File::Slurp in a nutshell
2102	41	50				111	$self->_throw('read') unless defined $rc;
2103	41					750	return $buf;
2104							}
2105							else {
2106	72					328	local $/;
2107	72					2388	my $buf = scalar <$fh>;
2108	72	50				325	$self->_throw('read') unless defined $buf;
2109	72					1489	return $buf;
2110							}
2111							}
2112
2113	28			28	1	208	sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp }
	28					100
2114
2115							sub slurp_utf8 {
2116	27	100		27	1	581	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		100
		100
		100
2117	10					83	return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) );
2118							}
2119							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
2120	8					27	$_[1] = { binmode => ":unix:utf8_strict" };
2121	8					32	goto &slurp;
2122							}
2123							else {
2124	9					53	$_[1] = { binmode => ":unix:encoding(UTF-8)" };
2125	9					33	goto &slurp;
2126							}
2127							}
2128
2129							#pod =method spew, spew_raw, spew_utf8
2130							#pod
2131							#pod path("foo.txt")->spew(@data);
2132							#pod path("foo.txt")->spew(\@data);
2133							#pod path("foo.txt")->spew({binmode => ":raw"}, @data);
2134							#pod path("foo.txt")->spew_raw(@data);
2135							#pod path("foo.txt")->spew_utf8(@data);
2136							#pod
2137							#pod Writes data to a file atomically. The file is written to a temporary file in
2138							#pod the same directory, then renamed over the original. An optional hash reference
2139							#pod may be used to pass options. The only option is C, which is passed to
2140							#pod C on the handle used for writing.
2141							#pod
2142							#pod C is like C with a C of C<:unix> for a fast,
2143							#pod unbuffered, raw write.
2144							#pod
2145							#pod C is like C with a C of C<:unix:encoding(UTF-8)>
2146							#pod (or C<:unix:utf8_strict> with L). If L
2147							#pod 0.58+ is installed, a raw, unbuffered spew will be done instead on the data
2148							#pod encoded with C.
2149							#pod
2150							#pod B: because the file is written to a temporary file and then renamed, the
2151							#pod new file will wind up with permissions based on your current umask. This is a
2152							#pod feature to protect you from a race condition that would otherwise give
2153							#pod different permissions than you might expect. If you really want to keep the
2154							#pod original mode flags, use L with the C option.
2155							#pod
2156							#pod Current API available since 0.011.
2157							#pod
2158							#pod =cut
2159
2160							sub spew {
2161	138			138	1	982	my ( $self, @data ) = @_;
2162	138	100	100			856	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
2163	138					382	$args = _get_args( $args, qw/binmode/ );
2164	137					339	my $binmode = $args->{binmode};
2165							# get default binmode from caller's lexical scope (see "perldoc open")
2166	137	100	100			881	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
2167
2168							# writing needs to follow the link and create the tempfile in the same
2169							# dir for later atomic rename
2170	137					514	my $resolved_path = $self->_resolve_symlinks;
2171	137					427	my $temp = $resolved_path->_replacement_path;
2172
2173	137					218	my $fh;
2174	137					280	my $ok = eval { $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode ); 1 };
	137					770
	136					423
2175	137	100				356	if (!$ok) {
2176	1	50				23	my $msg = ref($@) eq 'Path::Tiny::Error'
2177							? "error opening temp file '$@->{file}' for atomic write: $@->{err}"
2178							: "error opening temp file for atomic write: $@";
2179	1					16	$self->_throw('spew', $self->[PATH], $msg);
2180							}
2181	136	100				241	print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data) or $self->_throw('print', $temp->[PATH]);
	136	50				391
	264					24591
2182	136	50				18979	close $fh or $self->_throw( 'close', $temp->[PATH] );
2183
2184	136					1057	return $temp->move($resolved_path);
2185							}
2186
2187	25			25	1	313	sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew }
	25					107
2188
2189							sub spew_utf8 {
2190	33	100		33	1	413	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		100
		100
		100
2191	11					28	my $self = shift;
2192							spew(
2193							$self,
2194							{ binmode => ":unix" },
2195	11	100				69	map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_
	31					135
	29					122
2196							);
2197							}
2198							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
2199	11					59	splice @_, 1, 0, { binmode => ":unix:utf8_strict" };
2200	11					46	goto &spew;
2201							}
2202							else {
2203	11					211	splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" };
2204	11					36	goto &spew;
2205							}
2206							}
2207
2208							#pod =method stat, lstat
2209							#pod
2210							#pod $stat = path("foo.txt")->stat;
2211							#pod $stat = path("/some/symlink")->lstat;
2212							#pod
2213							#pod Like calling C or C from L.
2214							#pod
2215							#pod Current API available since 0.001.
2216							#pod
2217							#pod =cut
2218
2219							# XXX break out individual stat() components as subs?
2220							sub stat {
2221	9			9	1	1124	my $self = shift;
2222	9					2330	require File::stat;
2223	9		66			26437	return File::stat::stat( $self->[PATH] ) \|\| $self->_throw('stat');
2224							}
2225
2226							sub lstat {
2227	2			2	1	12	my $self = shift;
2228	2					15	require File::stat;
2229	2		66			14	return File::stat::lstat( $self->[PATH] ) \|\| $self->_throw('lstat');
2230							}
2231
2232							#pod =method stringify
2233							#pod
2234							#pod $path = path("foo.txt");
2235							#pod say $path->stringify; # same as "$path"
2236							#pod
2237							#pod Returns a string representation of the path. Unlike C, this method
2238							#pod returns the path standardized with Unix-style C directory separators.
2239							#pod
2240							#pod Current API available since 0.001.
2241							#pod
2242							#pod =cut
2243
2244	2693	100		2693	1	1425542	sub stringify { $_[0]->[PATH] =~ /^~/ ? './' . $_[0]->[PATH] : $_[0]->[PATH] }
2245
2246							#pod =method subsumes
2247							#pod
2248							#pod path("foo/bar")->subsumes("foo/bar/baz"); # true
2249							#pod path("/foo/bar")->subsumes("/foo/baz"); # false
2250							#pod
2251							#pod Returns true if the first path is a prefix of the second path at a directory
2252							#pod boundary.
2253							#pod
2254							#pod This B resolve parent directory entries (C<..>) or symlinks:
2255							#pod
2256							#pod path("foo/bar")->subsumes("foo/bar/../baz"); # true
2257							#pod
2258							#pod If such things are important to you, ensure that both paths are resolved to
2259							#pod the filesystem with C:
2260							#pod
2261							#pod my $p1 = path("foo/bar")->realpath;
2262							#pod my $p2 = path("foo/bar/../baz")->realpath;
2263							#pod if ( $p1->subsumes($p2) ) { ... }
2264							#pod
2265							#pod Current API available since 0.048.
2266							#pod
2267							#pod =cut
2268
2269							sub subsumes {
2270	96			96	1	198	my $self = shift;
2271	96	50				239	Carp::croak("subsumes() requires a defined, positive-length argument")
2272							unless defined $_[0];
2273	96					252	my $other = _path(shift);
2274
2275							# normalize absolute vs relative
2276	96	100	100			294	if ( $self->is_absolute && !$other->is_absolute ) {
		100	100
2277	3					11	$other = $other->absolute;
2278							}
2279							elsif ( $other->is_absolute && !$self->is_absolute ) {
2280	2					6	$self = $self->absolute;
2281							}
2282
2283							# normalize volume vs non-volume; do this after absolute path
2284							# adjustments above since that might add volumes already
2285	96	50	33			315	if ( length $self->volume && !length $other->volume ) {
		50	33
2286	0					0	$other = $other->absolute;
2287							}
2288							elsif ( length $other->volume && !length $self->volume ) {
2289	0					0	$self = $self->absolute;
2290							}
2291
2292	96	100				373	if ( $self->[PATH] eq '.' ) {
		100
2293	2					21	return !!1; # cwd subsumes everything relative
2294							}
2295							elsif ( $self->is_rootdir ) {
2296							# a root directory ("/", "c:/") already ends with a separator
2297	4					114	return $other->[PATH] =~ m{^\Q$self->[PATH]\E};
2298							}
2299							else {
2300							# exact match or prefix breaking at a separator
2301	90					5299	return $other->[PATH] =~ m{^\Q$self->[PATH]\E(?:/\|\z)};
2302							}
2303							}
2304
2305							#pod =method touch
2306							#pod
2307							#pod path("foo.txt")->touch;
2308							#pod path("foo.txt")->touch($epoch_secs);
2309							#pod
2310							#pod Like the Unix C utility. Creates the file if it doesn't exist, or else
2311							#pod changes the modification and access times to the current time. If the first
2312							#pod argument is the epoch seconds then it will be used.
2313							#pod
2314							#pod Returns the path object so it can be easily chained with other methods:
2315							#pod
2316							#pod # won't die if foo.txt doesn't exist
2317							#pod $content = path("foo.txt")->touch->slurp;
2318							#pod
2319							#pod Current API available since 0.015.
2320							#pod
2321							#pod =cut
2322
2323							sub touch {
2324	27			27	1	665	my ( $self, $epoch ) = @_;
2325	27	100				997	if ( !-e $self->[PATH] ) {
2326	25					129	my $fh = $self->openw;
2327	25	50				358	close $fh or $self->_throw('close');
2328							}
2329	27	100				70	if ( defined $epoch ) {
2330	1	50				22	utime $epoch, $epoch, $self->[PATH]
2331							or $self->_throw("utime ($epoch)");
2332							}
2333							else {
2334							# literal undef prevents warnings :-(
2335	26	50				616	utime undef, undef, $self->[PATH]
2336							or $self->_throw("utime ()");
2337							}
2338	27					207	return $self;
2339							}
2340
2341							#pod =method touchpath
2342							#pod
2343							#pod path("bar/baz/foo.txt")->touchpath;
2344							#pod
2345							#pod Combines C and C. Creates the parent directory if it doesn't exist,
2346							#pod before touching the file. Returns the path object like C does.
2347							#pod
2348							#pod If you need to pass options, use C and C separately:
2349							#pod
2350							#pod path("bar/baz")->mkdir( \%options )->child("foo.txt")->touch($epoch_secs);
2351							#pod
2352							#pod Current API available since 0.022.
2353							#pod
2354							#pod =cut
2355
2356							sub touchpath {
2357	16			16	1	45	my ($self) = @_;
2358	16					54	my $parent = $self->parent;
2359	16	100				53	$parent->mkdir unless $parent->exists;
2360	16					86	$self->touch;
2361							}
2362
2363							#pod =method visit
2364							#pod
2365							#pod path("/tmp")->visit( \&callback, \%options );
2366							#pod
2367							#pod Executes a callback for each child of a directory. It returns a hash
2368							#pod reference with any state accumulated during iteration.
2369							#pod
2370							#pod The options are the same as for L (which it uses internally):
2371							#pod C and C. Both default to false.
2372							#pod
2373							#pod The callback function will receive a C object as the first argument
2374							#pod and a hash reference to accumulate state as the second argument. For example:
2375							#pod
2376							#pod # collect files sizes
2377							#pod my $sizes = path("/tmp")->visit(
2378							#pod sub {
2379							#pod my ($path, $state) = @_;
2380							#pod return if $path->is_dir;
2381							#pod $state->{$path} = -s $path;
2382							#pod },
2383							#pod { recurse => 1 }
2384							#pod );
2385							#pod
2386							#pod For convenience, the C object will also be locally aliased as the
2387							#pod C<$_> global variable:
2388							#pod
2389							#pod # print paths matching /foo/
2390							#pod path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} );
2391							#pod
2392							#pod If the callback returns a B to a false scalar value, iteration will
2393							#pod terminate. This is not the same as "pruning" a directory search; this just
2394							#pod stops all iteration and returns the state hash reference.
2395							#pod
2396							#pod # find up to 10 files larger than 100K
2397							#pod my $files = path("/tmp")->visit(
2398							#pod sub {
2399							#pod my ($path, $state) = @_;
2400							#pod $state->{$path}++ if -s $path > 102400
2401							#pod return \0 if keys %$state == 10;
2402							#pod },
2403							#pod { recurse => 1 }
2404							#pod );
2405							#pod
2406							#pod If you want more flexible iteration, use a module like L.
2407							#pod
2408							#pod Current API available since 0.062.
2409							#pod
2410							#pod =cut
2411
2412							sub visit {
2413	14			14	1	2566	my $self = shift;
2414	14					27	my $cb = shift;
2415	14					50	my $args = _get_args( shift, qw/recurse follow_symlinks/ );
2416	12	50	33			78	Carp::croak("Callback for visit() must be a code reference")
2417							unless defined($cb) && ref($cb) eq 'CODE';
2418	12					53	my $next = $self->iterator($args);
2419	12					26	my $state = {};
2420	12					95	while ( my $file = $next->() ) {
2421	238					417	local $_ = $file;
2422	238					712	my $r = $cb->( $file, $state );
2423	238	100	66			1232	last if ref($r) eq 'SCALAR' && !$$r;
2424							}
2425	12					337	return $state;
2426							}
2427
2428							#pod =method volume
2429							#pod
2430							#pod $vol = path("/tmp/foo.txt")->volume; # ""
2431							#pod $vol = path("C:/tmp/foo.txt")->volume; # "C:"
2432							#pod
2433							#pod Returns the volume portion of the path. This is equivalent
2434							#pod to what L would give from C and thus
2435							#pod usually is the empty string on Unix-like operating systems or the
2436							#pod drive letter for an absolute path on C.
2437							#pod
2438							#pod Current API available since 0.001.
2439							#pod
2440							#pod =cut
2441
2442							sub volume {
2443	687			687	1	1264	my ($self) = @_;
2444	687	100				1690	$self->_splitpath unless defined $self->[VOL];
2445	687					2142	return $self->[VOL];
2446							}
2447
2448							package Path::Tiny::Error;
2449
2450							our @CARP_NOT = qw/Path::Tiny/;
2451
2452	29			29		332	use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 );
	29			49		117
	29					342
	49					7387
2453
2454							sub throw {
2455	27			27		71	my ( $class, $op, $file, $err ) = @_;
2456	27					4671	chomp( my $trace = Carp::shortmess );
2457	27					108	my $msg = "Error $op on '$file': $err$trace\n";
2458	27					547	die bless { op => $op, file => $file, err => $err, msg => $msg }, $class;
2459							}
2460
2461							1;
2462
2463
2464							# vim: ts=4 sts=4 sw=4 et:
2465
2466							__END__