File Coverage

blib/lib/Path/Tiny.pm

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

line	stmt	bran	cond	sub	pod	time	code
1	29			29		2565534	use 5.008001;
	29					418
2	29			29		170	use strict;
	29					58
	29					699
3	29			29		157	use warnings;
	29					53
	29					2096
4
5							package Path::Tiny;
6							# ABSTRACT: File path utility
7
8							our $VERSION = '0.144';
9
10							# Dependencies
11	29			29		195	use Config;
	29					55
	29					1586
12	29			29		198	use Exporter 5.57 (qw/import/);
	29					412
	29					1062
13	29			29		229	use File::Spec 0.86 (); # shipped with 5.8.1
	29					413
	29					654
14	29			29		147	use Carp ();
	29					68
	29					2305
15
16							our @EXPORT = qw/path/;
17							our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/;
18
19							use constant {
20	29					4962	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					59
28
29							use overload (
30							q{""} => 'stringify',
31							bool => sub () { 1 },
32	29					191	fallback => 1,
33	29			29		4088	);
	29					3218
34
35							# FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol
36	2			2	0	7	sub THAW { return path( $_[2] ) }
37	29			29		3822	{ no warnings 'once'; TO_JSON = FREEZE = \&stringify };
	29					60
	29					15980
38
39							my $HAS_UU; # has Unicode::UTF8; lazily populated
40
41							sub _check_UU {
42	4			4		27	local $SIG{__DIE__}; # prevent outer handler from being called
43	4					13	!!eval {
44	4					1085	require Unicode::UTF8;
45	1					819	Unicode::UTF8->VERSION(0.58);
46	1					12	1;
47							};
48							}
49
50							my $HAS_PU; # has PerlIO::utf8_strict; lazily populated
51
52							sub _check_PU {
53	4			4		2537	local $SIG{__DIE__}; # prevent outer handler from being called
54	4					13	!!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					1265	require Encode;
58	4					45546	require PerlIO::utf8_strict;
59	0					0	PerlIO::utf8_strict->VERSION(0.003);
60	0					0	1;
61							};
62							}
63
64							my $HAS_FLOCK = $Config{d_flock} \|\| $Config{d_fcntl_can_lock} \|\| $Config{d_lockf};
65
66							# notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \
67							my $SLASH = qr{[\\/]};
68							my $NOTSLASH = qr{[^\\/]};
69							my $DRV_VOL = qr{[a-z]:}i;
70							my $UNC_VOL = qr{$SLASH $SLASH $NOTSLASH+ $SLASH $NOTSLASH+}x;
71							my $WIN32_ROOT = qr{(?: $UNC_VOL $SLASH \| $DRV_VOL $SLASH \| $SLASH )}x;
72
73							sub _win32_vol {
74	0			0		0	my ( $path, $drv ) = @_;
75	0					0	require Cwd;
76	0					0	my $dcwd = eval { Cwd::getdcwd($drv) }; # C: -> C:\some\cwd
	0					0
77							# getdcwd on non-existent drive returns empty string
78							# so just use the original drive Z: -> Z:
79	0	0	0			0	$dcwd = "$drv" unless defined $dcwd && length $dcwd;
80							# normalize dwcd to end with a slash: might be C:\some\cwd or D:\ or Z:
81	0					0	$dcwd =~ s{$SLASH?\z}{/};
82							# make the path absolute with dcwd
83	0					0	$path =~ s{^$DRV_VOL}{$dcwd};
84	0					0	return $path;
85							}
86
87							# This is a string test for before we have the object; see is_rootdir for well-formed
88							# object test
89							sub _is_root {
90	2463			2463		6185	return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' );
91							}
92
93							BEGIN {
94	29			29		10500	*_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] };
	337			337		829
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		762789	my ( $mode, $symbolic ) = @_;
103	1173					5769	for my $clause ( split /,\s*/, $symbolic ) {
104	2366	100				9639	if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) {
105	2365					6720	my ( $who, $action, $perms ) = ( $1, $2, $3 );
106	2365					5195	$who =~ s/a/ugo/g;
107	2365					5610	for my $w ( split //, $who ) {
108	7391					9332	my $p = 0;
109	7391					18876	$p \|= $MODEBITS{"$w$_"} for split //, $perms;
110	7391	100				13747	if ( $action eq '=' ) {
111	2081					4433	$mode = ( $mode & ~$MODEBITS{"${w}m"} ) \| $p;
112							}
113							else {
114	5310	100				10937	$mode = $action eq "+" ? ( $mode \| $p ) : ( $mode & ~$p );
115							}
116							}
117							}
118							else {
119	1					85	Carp::croak("Invalid mode clause '$clause' for chmod()");
120							}
121							}
122	1172					5499	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		258	{ package flock; use warnings::register }
	29					60
	29					204098
132							#>>>
133
134							my $WARNED_NO_FLOCK = 0;
135
136							sub _throw {
137	16			16		657	my ( $self, $function, $file, $msg ) = @_;
138	16	50	33			84	if ( $function =~ /^flock/
			33
139							&& $! =~ /operation not supported\|function not implemented/i
140							&& !warnings::fatal_enabled('flock') )
141							{
142	0	0				0	if ( !$WARNED_NO_FLOCK ) {
143	0					0	warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" );
144	0					0	$WARNED_NO_FLOCK++;
145							}
146							}
147							else {
148	16	100				102	$msg = $! unless defined $msg;
149	16	100				124	Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ),
150							$msg );
151							}
152	0					0	return;
153							}
154
155							# cheapo option validation
156							sub _get_args {
157	1435			1435		3158	my ( $raw, @valid ) = @_;
158	1435	100	100			5224	if ( defined($raw) && ref($raw) ne 'HASH' ) {
159	6					42	my ( undef, undef, undef, $called_as ) = caller(1);
160	6					39	$called_as =~ s{^.*::}{};
161	6					463	Carp::croak("Options for $called_as must be a hash reference");
162							}
163	1429					2210	my $cooked = {};
164	1429					2522	for my $k (@valid) {
165	2403	100				6196	$cooked->{$k} = delete $raw->{$k} if exists $raw->{$k};
166							}
167	1429	100				4090	if ( keys %$raw ) {
168	8					49	my ( undef, undef, undef, $called_as ) = caller(1);
169	8					59	$called_as =~ s{^.*::}{};
170	8					619	Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) );
171							}
172	1421					3020	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	160405	my $path = shift;
224							Carp::croak("Path::Tiny paths require defined, positive-length parts")
225	294	100				745	unless 1 + @_ == grep { defined && length } $path, @_;
	326	100				2218
226
227							# non-temp Path::Tiny objects are effectively immutable and can be reused
228	289	100	100			1358	if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
			66
229	4					20	return $path;
230							}
231
232							# stringify objects
233	285					483	$path = "$path";
234
235							# do any tilde expansions
236	285					865	my ($tilde) = $path =~ m{^(~[^/]*)};
237	285	100				636	if ( defined $tilde ) {
238							# Escape File::Glob metacharacters
239	28					139	(my $escaped = $tilde) =~ s/([\[\{\*\?\\])/\\$1/g;
240	28					147	require File::Glob;
241	28					1772	my ($homedir) = File::Glob::bsd_glob($escaped);
242	28	50	33			280	if (defined $homedir && ! $File::Glob::ERROR) {
243	28					38	$homedir =~ tr[\\][/] if IS_WIN32();
244	28					463	$path =~ s{^\Q$tilde\E}{$homedir};
245							}
246							}
247
248	285					668	unshift @_, $path;
249	285					902	goto &_pathify;
250							}
251
252							# _path is like path but without tilde expansion
253							sub _path {
254	1684			1684		3272	my $path = shift;
255							Carp::croak("Path::Tiny paths require defined, positive-length parts")
256	1684	50				3484	unless 1 + @_ == grep { defined && length } $path, @_;
	2409	50				8542
257
258							# non-temp Path::Tiny objects are effectively immutable and can be reused
259	1684	100	100			8618	if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
			100
260	118					379	return $path;
261							}
262
263							# stringify objects
264	1566					3228	$path = "$path";
265
266	1566					4559	unshift @_, $path;
267	1566					4410	goto &_pathify;
268							}
269
270							# _pathify expects one or more string arguments, then joins and canonicalizes
271							# them into an object.
272							sub _pathify {
273	1851			1851		2972	my $path = shift;
274
275							# expand relative volume paths on windows; put trailing slash on UNC root
276	1851					2401	if ( IS_WIN32() ) {
277							$path = _win32_vol( $path, $1 ) if $path =~ m{^($DRV_VOL)(?:$NOTSLASH\|\z)};
278							$path .= "/" if $path =~ m{^$UNC_VOL\z};
279							}
280
281							# concatenations stringifies objects, too
282	1851	100				3553	if (@_) {
283	612	100				1136	$path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ );
284							}
285
286
287							# canonicalize, but with unix slashes and put back trailing volume slash
288	1851					7242	my $cpath = $path = File::Spec->canonpath($path);
289	1851					2523	$path =~ tr[\\][/] if IS_WIN32();
290	1851	50				3500	$path = "/" if $path eq '/..'; # for old File::Spec
291	1851					2250	$path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL\z};
292
293							# root paths must always have a trailing slash, but other paths must not
294	1851	100				3127	if ( _is_root($path) ) {
295	57					269	$path =~ s{/?\z}{/};
296							}
297							else {
298	1794					3748	$path =~ s{/\z}{};
299							}
300
301	1851					8628	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	359	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	17432	require Cwd;
334	10					108	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	158	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	486056	my ( $opts, $maybe_template, $args )
429							= _parse_file_temp_args(tempfile => @_);
430
431							# File::Temp->new demands TEMPLATE
432	187	100				428	$args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template;
433
434	187					957	require File::Temp;
435	187					983	my $temp = File::Temp->new( TMPDIR => 1, %$args );
436	187					73825	close $temp;
437	187	100				888	my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
438	187					415	$self->[TEMP] = $temp; # keep object alive while we are
439	187					815	return $self;
440							}
441
442							sub tempdir {
443	21			21	1	37894	my ( $opts, $maybe_template, $args )
444							= _parse_file_temp_args(tempdir => @_);
445
446	21					120	require File::Temp;
447	21					158	my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args );
448	21	100				9950	my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
449	21					70	$self->[TEMP] = $temp; # keep object alive while we are
450							# Some ActiveState Perls for Windows break Cwd in ways that lead
451							# File::Temp to get confused about what path to remove; this
452							# monkey-patches the object with our own view of the absolute path
453	21					30	$temp->{REALNAME} = $self->[CANON] if IS_WIN32;
454	21					114	return $self;
455							}
456
457							# normalize the various ways File::Temp does templates
458							sub _parse_file_temp_args {
459	208			208		425	my $called_as = shift;
460	208	100	66			1107	if ( @_ && $_[0] eq 'Path::Tiny' ) { shift } # class method
	201	100	66			305
461	7					54	elsif ( @_ && eval{$_[0]->isa('Path::Tiny')} ) {
462	5					6	my $dir = shift;
463	5	50				15	if (! $dir->is_dir) {
464	0					0	$dir->_throw( $called_as, $dir, "is not a directory object" );
465							}
466	5					24	push @_, DIR => $dir->stringify; # no overriding
467							}
468	208	100	100			706	my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
469	208					472	$opts = _get_args( $opts, qw/realpath/ );
470
471	208	100				596	my $leading_template = ( scalar(@_) % 2 == 1 ? shift(@_) : '' );
472	208					383	my %args = @_;
473	208					503	%args = map { uc($_), $args{$_} } keys %args;
	14					56
474							my @template = (
475							exists $args{TEMPLATE} ? delete $args{TEMPLATE}
476	208	100				539	: $leading_template ? $leading_template
		100
477							: ()
478							);
479
480	208					660	return ( $opts, \@template, \%args );
481							}
482
483							#--------------------------------------------------------------------------#
484							# Private methods
485							#--------------------------------------------------------------------------#
486
487							sub _splitpath {
488	836			836		1254	my ($self) = @_;
489	836					8299	@{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] );
	836					3166
490							}
491
492							sub _resolve_symlinks {
493	179			179		306	my ($self) = @_;
494	179					252	my $new = $self;
495	179					344	my ( $count, %seen ) = 0;
496	179					2882	while ( -l $new->[PATH] ) {
497	12	100				94	if ( $seen{ $new->[PATH] }++ ) {
498	1					6	$self->_throw( 'readlink', $self->[PATH], "symlink loop detected" );
499							}
500	11	50				32	if ( ++$count > 100 ) {
501	0					0	$self->_throw( 'readlink', $self->[PATH], "maximum symlink depth exceeded" );
502							}
503	11					116	my $resolved = readlink $new->[PATH];
504	11	50				37	$new->_throw( 'readlink', $new->[PATH] ) unless defined $resolved;
505	11					26	$resolved = _path($resolved);
506	11	100				39	$new = $resolved->is_absolute ? $resolved : $new->sibling($resolved);
507							}
508	178					682	return $new;
509							}
510
511							sub _replacment_path {
512	146			146		278	my ($self) = @_;
513
514	146					704	my $unique_suffix = $$ . int( rand( 2**31 ) );
515	146					512	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				365	if ( length $temp->basename > 255 ) {
520	1					5	$temp = $self->sibling( "temp" . $unique_suffix );
521							}
522
523	146					278	return $temp;
524							}
525
526							#--------------------------------------------------------------------------#
527							# Public methods
528							#--------------------------------------------------------------------------#
529
530							#pod =method absolute
531							#pod
532							#pod $abs = path("foo/bar")->absolute;
533							#pod $abs = path("foo/bar")->absolute("/tmp");
534							#pod
535							#pod Returns a new C object with an absolute path (or itself if already
536							#pod absolute). If no argument is given, the current directory is used as the
537							#pod absolute base path. If an argument is given, it will be converted to an
538							#pod absolute path (if it is not already) and used as the absolute base path.
539							#pod
540							#pod This will not resolve upward directories ("foo/../bar") unless C
541							#pod in L would normally do so on your platform. If you need them
542							#pod resolved, you must call the more expensive C method instead.
543							#pod
544							#pod On Windows, an absolute path without a volume component will have it added
545							#pod based on the current drive.
546							#pod
547							#pod Current API available since 0.101.
548							#pod
549							#pod =cut
550
551							sub absolute {
552	279			279	1	974	my ( $self, $base ) = @_;
553
554							# absolute paths handled differently by OS
555	279					367	if (IS_WIN32) {
556							return $self if length $self->volume;
557							# add missing volume
558							if ( $self->is_absolute ) {
559							require Cwd;
560							# use Win32::GetCwd not Cwd::getdcwd because we're sure
561							# to have the former but not necessarily the latter
562							my ($drv) = Win32::GetCwd() =~ /^($DRV_VOL \| $UNC_VOL)/x;
563							return _path( $drv . $self->[PATH] );
564							}
565							}
566							else {
567	279	100				589	return $self if $self->is_absolute;
568							}
569
570							# no base means use current directory as base
571	70					357	require Cwd;
572	70	100				769	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					20	$base = _path($base);
578	6	50				20	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	3250	my ( $self, @data ) = @_;
616	47	100	100			222	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
617	47					106	$args = _get_args( $args, qw/binmode truncate/ );
618	46					91	my $binmode = $args->{binmode};
619	46	100	100			266	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
620	46	100				129	my $mode = $args->{truncate} ? ">" : ">>";
621	46					147	my $fh = $self->filehandle( { locked => 1 }, $mode, $binmode );
622	46	100				105	print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data ) or self->_throw('print');
	46	50				122
	91					927
623	46	50				2160	close $fh or $self->_throw('close');
624							}
625
626							sub append_raw {
627	9			9	1	1939	my ( $self, @data ) = @_;
628	9	100	66			54	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
629	9					27	$args = _get_args( $args, qw/binmode truncate/ );
630	9					21	$args->{binmode} = ':unix';
631	9					22	append( $self, $args, @data );
632							}
633
634							sub append_utf8 {
635	9			9	1	32	my ( $self, @data ) = @_;
636	9	100	66			54	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
637	9					27	$args = _get_args( $args, qw/binmode truncate/ );
638	9	50				43	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		50
		100
		50
639	3					7	$args->{binmode} = ":unix";
640	3					7	append( $self, $args, map { Unicode::UTF8::encode_utf8($_) } @data );
	9					29
641							}
642							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
643	0					0	$args->{binmode} = ":unix:utf8_strict";
644	0					0	append( $self, $args, @data );
645							}
646							else {
647	6					12	$args->{binmode} = ":unix:encoding(UTF-8)";
648	6					16	append( $self, $args, @data );
649							}
650							}
651
652							#pod =method assert
653							#pod
654							#pod $path = path("foo.txt")->assert( sub { $_->exists } );
655							#pod
656							#pod Returns the invocant after asserting that a code reference argument returns
657							#pod true. When the assertion code reference runs, it will have the invocant
658							#pod object in the C<$_> variable. If it returns false, an exception will be
659							#pod thrown. The assertion code reference may also throw its own exception.
660							#pod
661							#pod If no assertion is provided, the invocant is returned without error.
662							#pod
663							#pod Current API available since 0.062.
664							#pod
665							#pod =cut
666
667							sub assert {
668	2			2	1	5	my ( $self, $assertion ) = @_;
669	2	50				6	return $self unless $assertion;
670	2	50				8	if ( ref $assertion eq 'CODE' ) {
671	2					4	local $_ = $self;
672	2	100				5	$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	993	my ( $self, @suffixes ) = @_;
700	169	100				637	$self->_splitpath unless defined $self->[FILE];
701	169					338	my $file = $self->[FILE];
702	169					360	for my $s (@suffixes) {
703	8	100				98	my $re = ref($s) eq 'Regexp' ? qr/$s\z/ : qr/\Q$s\E\z/;
704	8	100				87	last if $file =~ s/$re//;
705							}
706	169					479	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	8	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	21	my $self = shift;
739	3	100				12	$self->_throw( "cached_temp", $self, "has no cached File::Temp object" )
740							unless defined $self->[TEMP];
741	2					8	return $self->[TEMP];
742							}
743
744							#pod =method child
745							#pod
746							#pod $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
747							#pod $file = path("/tmp")->child(@parts);
748							#pod
749							#pod Returns a new C object relative to the original. Works
750							#pod like C or C from File::Spec, but without caring about
751							#pod file or directories.
752							#pod
753							#pod B: because the argument could contain C<..> or refer to symlinks,
754							#pod there is no guarantee that the new path refers to an actual descendent of
755							#pod the original. If this is important to you, transform parent and child with
756							#pod L and check them with L.
757							#pod
758							#pod Current API available since 0.001.
759							#pod
760							#pod =cut
761
762							sub child {
763	417			417	1	28565	my ( $self, @parts ) = @_;
764	417					1001	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	2008	my ( $self, $filter ) = @_;
788	9					15	my $dh;
789	9	50				342	opendir $dh, $self->[PATH] or $self->_throw('opendir');
790	9					232	my @children = readdir $dh;
791	9	50				158	closedir $dh or $self->_throw('closedir');
792
793	9	100	66			52	if ( not defined $filter ) {
		100
794	7	100				28	@children = grep { $_ ne '.' && $_ ne '..' } @children;
	25					120
795							}
796							elsif ( $filter && ref($filter) eq 'Regexp' ) {
797	1	100	100			4	@children = grep { $_ ne '.' && $_ ne '..' && $_ =~ $filter } @children;
	5					42
798							}
799							else {
800	1					169	Carp::croak("Invalid argument '$filter' for children()");
801							}
802
803	8					19	return map { _path( $self->[PATH], $_ ) } @children;
	13					48
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	4412	my ( $self, $new_mode ) = @_;
829
830	6					10	my $mode;
831	6	100				36	if ( $new_mode =~ /\d/ ) {
		100
832	3	100				19	$mode = ( $new_mode =~ /^0/ ? oct($new_mode) : $new_mode );
833							}
834							elsif ( $new_mode =~ /[=+-]/ ) {
835	2					10	$mode = _symbolic_chmod( $self->stat->mode & 07777, $new_mode ); ## no critic
836							}
837							else {
838	1					174	Carp::croak("Invalid mode argument '$new_mode' for chmod()");
839							}
840
841	4	100				102	CORE::chmod( $mode, $self->[PATH] ) or $self->_throw("chmod");
842
843	3					26	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	29	my ( $self, $dest ) = @_;
861	2					9	require File::Copy;
862	2	50				14	File::Copy::copy( $self->[PATH], $dest )
863							or Carp::croak("copy failed for $self to $dest: $!");
864
865	2	100				364	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	111	my ( $self, @opts ) = @_;
888	6	100	100			33	my $args = ( @opts && ref $opts[0] eq 'HASH' ) ? shift @opts : {};
889	6					33	$args = _get_args( $args, qw/chunk_size/ );
890	6	100				19	unshift @opts, 'SHA-256' unless @opts;
891	6					31	require Digest;
892	6					28	my $digest = Digest->new(@opts);
893	6	100				3841	if ( $args->{chunk_size} ) {
894	2					8	my $fh = $self->filehandle( { locked => 1 }, "<", ":unix" );
895	2					5	my $buf;
896	2					50	while (!eof($fh)) {
897	10					82	my $rc = read $fh, $buf, $args->{chunk_size};
898	10	50				30	$self->_throw('read') unless defined $rc;
899	10					129	$digest->add($buf);
900							}
901							}
902							else {
903	4					20	$digest->add( $self->slurp_raw );
904							}
905	6					83	return $digest->hexdigest;
906							}
907
908							#pod =method dirname (deprecated)
909							#pod
910							#pod $name = path("/tmp/foo.txt")->dirname; # "/tmp/"
911							#pod
912							#pod Returns the directory portion you would get from calling
913							#pod C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a
914							#pod parent directory portion. Because L is inconsistent, the result
915							#pod might or might not have a trailing slash. Because of this, this method is
916							#pod B.
917							#pod
918							#pod A better, more consistently approach is likely C<< $path->parent->stringify >>,
919							#pod which will not have a trailing slash except for a root directory.
920							#pod
921							#pod Deprecated in 0.056.
922							#pod
923							#pod =cut
924
925							sub dirname {
926	798			798	1	2570	my ($self) = @_;
927	798	100				2428	$self->_splitpath unless defined $self->[DIR];
928	798	100				3920	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	46	my $self = shift;
955	6					11	my $cb = shift;
956	6					17	my $args = _get_args( shift, qw/binmode/ );
957	6	50	33			35	Carp::croak("Callback for edit() must be a code reference")
958							unless defined($cb) && ref($cb) eq 'CODE';
959
960							local $_ =
961	6	50				30	$self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () );
962	6					39	$cb->();
963	6					73	$self->spew( $args, $_ );
964
965	6					25	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			25	Carp::croak("Callback for edit_utf8() must be a code reference")
972							unless defined($cb) && ref($cb) eq 'CODE';
973
974	3					14	local $_ = $self->slurp_utf8;
975	3					20	$cb->();
976	3					50	$self->spew_utf8($_);
977
978	3					12	return;
979							}
980
981	3			3	1	38	sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit }
	3					12
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	43	my $self = shift;
1013	9					16	my $cb = shift;
1014	9					22	my $args = _get_args( shift, qw/binmode/ );
1015	9	50	33			51	Carp::croak("Callback for edit_lines() must be a code reference")
1016							unless defined($cb) && ref($cb) eq 'CODE';
1017
1018	9					28	my $binmode = $args->{binmode};
1019							# get default binmode from caller's lexical scope (see "perldoc open")
1020	9	50	0			22	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
1021
1022							# writing needs to follow the link and create the tempfile in the same
1023							# dir for later atomic rename
1024	9					21	my $resolved_path = $self->_resolve_symlinks;
1025	9					35	my $temp = $resolved_path->_replacment_path;
1026
1027	9					40	my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
1028	9					51	my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode );
1029
1030	9					26	local $_;
1031	9					184	while (! eof($in_fh) ) {
1032	36	50				419	defined( $_ = readline($in_fh) ) or $self->_throw('readline');
1033	36					130	$cb->();
1034	36	50				326	$temp_fh->print($_) or self->_throw('print', $temp);
1035							}
1036
1037	9	50				978	close $temp_fh or $self->_throw( 'close', $temp );
1038	9	50				122	close $in_fh or $self->_throw('close');
1039
1040	9					40	return $temp->move($resolved_path);
1041							}
1042
1043	3			3	1	42	sub edit_lines_raw { $_[2] = { binmode => ":raw" }; goto &edit_lines }
	3					10
1044
1045							sub edit_lines_utf8 {
1046	3	50		3	1	56	if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
		50
1047	0					0	$_[2] = { binmode => ":raw:utf8_strict" };
1048							}
1049							else {
1050	3					13	$_[2] = { binmode => ":raw:encoding(UTF-8)" };
1051							}
1052	3					15	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	640	sub exists { -e $_[0]->[PATH] }
1075
1076	32	100		32	1	438	sub is_file { -e $_[0]->[PATH] && !-d _ }
1077
1078	6			6	1	97	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	1336	my ( $self, @args ) = @_;
1112	555	100	66			2242	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1113	555					1165	$args = _get_args( $args, qw/locked exclusive/ );
1114	555	100				1232	$args->{locked} = 1 if $args->{exclusive};
1115	555					1117	my ( $opentype, $binmode ) = @args;
1116
1117	555	100				1106	$opentype = "<" unless defined $opentype;
1118							Carp::croak("Invalid file mode '$opentype'")
1119	555	50				1044	unless grep { $opentype eq $_ } qw/< +< > +> >> +>>/;
	3330					6140
1120
1121	555	100	50			2649	$binmode = ( ( caller(0) )[10] \|\| {} )->{ 'open' . substr( $opentype, -1, 1 ) }
1122							unless defined $binmode;
1123	555	100				1278	$binmode = "" unless defined $binmode;
1124
1125	555					942	my ( $fh, $lock, $trunc );
1126	555	100	66			2665	if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) {
			100
1127	448					2216	require Fcntl;
1128							# truncating file modes shouldn't truncate until lock acquired
1129	448	100	33			751	if ( grep { $opentype eq $_ } qw( > +> ) ) {
	896	50				2559
1130							# sysopen in write mode without truncation
1131	155	50				363	my $flags = $opentype eq ">" ? Fcntl::O_WRONLY() : Fcntl::O_RDWR();
1132	155					265	$flags \|= Fcntl::O_CREAT();
1133	155	100				342	$flags \|= Fcntl::O_EXCL() if $args->{exclusive};
1134	155	100				14649	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				1095	if ( $binmode =~ s/^:unix// ) {
1139							# eliminate pseudo-layers
1140	67	50				411	binmode( $fh, ":raw" ) or $self->_throw("binmode (:raw)");
1141							# strip off real layers until only :unix is left
1142	67					531	while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
1143	67	50				503	binmode( $fh, ":pop" ) or $self->_throw("binmode (:pop)");
1144							}
1145							}
1146
1147							# apply any remaining binmode layers
1148	154	100				390	if ( length $binmode ) {
1149	46	50				565	binmode( $fh, $binmode ) or $self->_throw("binmode ($binmode)");
1150							}
1151
1152							# ask for lock and truncation
1153	154					3892	$lock = Fcntl::LOCK_EX();
1154	154					270	$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				670	$lock = $opentype eq "<" ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX();
1168							}
1169							}
1170
1171	554	100				1086	unless ($fh) {
1172	400					760	my $mode = $opentype . $binmode;
1173	400	100		4		17220	open $fh, $mode, $self->[PATH] or $self->_throw("open ($mode)");
	4					30
	4					8
	4					24
1174							}
1175
1176	551	50				8659	do { flock( $fh, $lock ) or $self->_throw("flock ($lock)") } if $lock;
	444	100				4168
1177	551	50				1327	do { truncate( $fh, 0 ) or $self->_throw("truncate") } if $trunc;
	154	100				3282
1178
1179	551					2690	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	2724	my ($self, $other_path) = @_;
1201	11					22	my $other = _path($other_path);
1202
1203	11					38	my $fh1 = $self->openr_raw({ locked => 1 });
1204	10					44	my $fh2 = $other->openr_raw({ locked => 1 });
1205
1206							# check for directories
1207	9	100				78	if (-d $fh1) {
1208	3					18	$self->_throw('has_same_bytes', $self->[PATH], "directory not allowed");
1209							}
1210	6	100				61	if (-d $fh2) {
1211	1					7	$self->_throw('has_same_bytes', $other->[PATH], "directory not allowed");
1212							}
1213
1214							# Now that handles are open, we know the inputs are readable files that
1215							# exist, so it's safe to compare via realpath
1216	5	100				17	if ($self->realpath eq $other->realpath) {
1217	3					83	return 1
1218							}
1219
1220							# result is 0 for equal, 1 for unequal, -1 for error
1221	2					466	require File::Compare;
1222	2					1054	my $res = File::Compare::compare($fh1, $fh2, 65536);
1223	2	50				185	if ($res < 0) {
1224	0					0	$self->_throw('has_same_bytes')
1225							}
1226
1227	2					50	return $res == 0;
1228							}
1229
1230							#pod =method is_absolute, is_relative
1231							#pod
1232							#pod if ( path("/tmp")->is_absolute ) { ... }
1233							#pod if ( path("/tmp")->is_relative ) { ... }
1234							#pod
1235							#pod Booleans for whether the path appears absolute or relative.
1236							#pod
1237							#pod Current API available since 0.001.
1238							#pod
1239							#pod =cut
1240
1241	647			647	1	2209	sub is_absolute { substr( $_[0]->dirname, 0, 1 ) eq '/' }
1242
1243	145			145	1	612	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	272	my ($self) = @_;
1266	164	100				364	$self->_splitpath unless defined $self->[DIR];
1267	164		100			517	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	1649	my $self = shift;
1309	20					44	my $args = _get_args( shift, qw/recurse follow_symlinks/ );
1310	18					50	my @dirs = $self;
1311	18					26	my $current;
1312							return sub {
1313	292			292		1145	my $next;
1314	292					559	while (@dirs) {
1315	347	100				820	if ( ref $dirs[0] eq 'Path::Tiny' ) {
1316	74	100				271	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	73					243	$current = $dirs[0];
1326	73					95	my $dh;
1327	73	50				1771	opendir( $dh, $current->[PATH] )
1328							or $self->_throw( 'opendir', $current->[PATH] );
1329	73					193	$dirs[0] = $dh;
1330	73	50	66			785	if ( -l $current->[PATH] && !$args->{follow_symlinks} ) {
1331							# Symlink attack! It was a real dir, but is now a symlink!
1332							# N.B. we check after opendir so the attacker has to win
1333							# two races: replace dir with symlink before opendir and
1334							# replace symlink with dir before -l check above
1335	0	0				0	shift @dirs and next;
1336							}
1337							}
1338	346					2253	while ( defined( $next = readdir $dirs[0] ) ) {
1339	417	100	100			1750	next if $next eq '.' \|\| $next eq '..';
1340	275					610	my $path = $current->child($next);
1341							push @dirs, $path
1342	275	100	100			875	if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path );
			100
			100
1343	275					1284	return $path;
1344							}
1345	71					915	shift @dirs;
1346							}
1347	17					63	return;
1348	18					125	};
1349							}
1350
1351							#pod =method lines, lines_raw, lines_utf8
1352							#pod
1353							#pod @contents = path("/tmp/foo.txt")->lines;
1354							#pod @contents = path("/tmp/foo.txt")->lines(\%options);
1355							#pod @contents = path("/tmp/foo.txt")->lines_raw;
1356							#pod @contents = path("/tmp/foo.txt")->lines_utf8;
1357							#pod
1358							#pod @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } );
1359							#pod
1360							#pod Returns a list of lines from a file. Optionally takes a hash-reference of
1361							#pod options. Valid options are C, C and C.
1362							#pod
1363							#pod If C is provided, it will be set on the handle prior to reading.
1364							#pod
1365							#pod If a positive C is provided, that many lines will be returned from the
1366							#pod start of the file. If a negative C is provided, the entire file will be
1367							#pod read, but only C will be kept and returned. If C
1368							#pod exceeds the number of lines in the file, all lines will be returned.
1369							#pod
1370							#pod If C is set, any end-of-line character sequences (C, C, or
1371							#pod C) will be removed from the lines returned.
1372							#pod
1373							#pod Because the return is a list, C in scalar context will return the number
1374							#pod of lines (and throw away the data).
1375							#pod
1376							#pod $number_of_lines = path("/tmp/foo.txt")->lines;
1377							#pod
1378							#pod C is like C with a C of C<:raw>. We use C<:raw>
1379							#pod instead of C<:unix> so PerlIO buffering can manage reading by line.
1380							#pod
1381							#pod C is like C with a C of C<:raw:encoding(UTF-8)>
1382							#pod (or C<:raw:utf8_strict> with L). If L
1383							#pod 0.58+ is installed, a raw, unbuffered UTF-8 slurp will be done and then the
1384							#pod lines will be split. This is actually faster than relying on
1385							#pod IO layers, though a bit memory intensive. If memory use is a
1386							#pod concern, consider C and iterating directly on the handle.
1387							#pod
1388							#pod Current API available since 0.065.
1389							#pod
1390							#pod =cut
1391
1392							sub lines {
1393	112			112	1	7566	my $self = shift;
1394	112					287	my $args = _get_args( shift, qw/binmode chomp count/ );
1395	110					221	my $binmode = $args->{binmode};
1396	110	100	100			690	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open<'} unless defined $binmode;
1397	110					384	my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
1398	110					296	my $chomp = $args->{chomp};
1399							# XXX more efficient to read @lines then chomp(@lines) vs map?
1400	110	100				281	if ( $args->{count} ) {
		100
1401	84					210	my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) );
1402	84					119	my $line;
1403	84					1671	while ( !eof($fh) ) {
1404	216	50				1105	defined( $line = readline($fh) ) or $self->_throw('readline');
1405
1406	216	100				698	$line =~ s/(?:\x{0d}?\x{0a}\|\x{0d})\z// if $chomp;
1407	216					506	$result[ $counter++ ] = $line;
1408							# for positive count, terminate after right number of lines
1409	216	100				427	last if $counter == $args->{count};
1410							# for negative count, eventually wrap around in the result array
1411	180					647	$counter %= $mod;
1412							}
1413							# reorder results if full and wrapped somewhere in the middle
1414	84	100	100			382	splice( @result, 0, 0, splice( @result, $counter ) )
1415							if @result == $mod && $counter % $mod;
1416	84					2352	return @result;
1417							}
1418							elsif ($chomp) {
1419	6					43	local $!;
1420	6					161	my @lines = map { s/(?:\x{0d}?\x{0a}\|\x{0d})\z//; $_ } <$fh>; ## no critic
	21					192
	21					54
1421	6	50				53	$self->_throw('readline') if $!;
1422	6					152	return @lines;
1423							}
1424							else {
1425	20	100				46	if ( wantarray ) {
1426	14					117	local $!;
1427	14					387	my @lines = <$fh>;
1428	14	50				156	$self->_throw('readline') if $!;
1429	14					398	return @lines;
1430							} else {
1431	6					40	local $!;
1432	6					171	my $count =()= <$fh>;
1433	6	50				39	$self->_throw('readline') if $!;
1434	6					174	return $count;
1435							}
1436							}
1437							}
1438
1439							sub lines_raw {
1440	17			17	1	38	my $self = shift;
1441	17					70	my $args = _get_args( shift, qw/binmode chomp count/ );
1442	15	50	33			64	if ( $args->{chomp} && !$args->{count} ) {
1443	0					0	return split /\n/, slurp_raw($self); ## no critic
1444							}
1445							else {
1446	15					32	$args->{binmode} = ":raw";
1447	15					38	return lines( $self, $args );
1448							}
1449							}
1450
1451							my $CRLF = qr/(?:\x{0d}?\x{0a}\|\x{0d})/;
1452
1453							sub lines_utf8 {
1454	35			35	1	79	my $self = shift;
1455	35					87	my $args = _get_args( shift, qw/binmode chomp count/ );
1456	33	50	100			204	if ( ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) )
		100	100
		100
		50
1457							&& $args->{chomp}
1458							&& !$args->{count} )
1459							{
1460	2					7	my $slurp = slurp_utf8($self);
1461	2					114	$slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF\|CR
1462	2					45	return split $CRLF, $slurp, -1; ## no critic
1463							}
1464							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
1465	0					0	$args->{binmode} = ":raw:utf8_strict";
1466	0					0	return lines( $self, $args );
1467							}
1468							else {
1469	31					71	$args->{binmode} = ":raw:encoding(UTF-8)";
1470	31					77	return lines( $self, $args );
1471							}
1472							}
1473
1474							#pod =method mkdir
1475							#pod
1476							#pod path("foo/bar/baz")->mkdir;
1477							#pod path("foo/bar/baz")->mkdir( \%options );
1478							#pod
1479							#pod Like calling C from L. An optional hash reference
1480							#pod is passed through to C. Errors will be trapped and an exception
1481							#pod thrown. Returns the the path object to facilitate chaining.
1482							#pod
1483							#pod B: unlike Perl's builtin C, this will create intermediate paths
1484							#pod similar to the Unix C command. It will not error if applied to an
1485							#pod existing directory.
1486							#pod
1487							#pod Current API available since 0.125.
1488							#pod
1489							#pod =cut
1490
1491							sub mkdir {
1492	48			48	1	196	my ( $self, $args ) = @_;
1493	48	100				149	$args = {} unless ref $args eq 'HASH';
1494	48					74	my $err;
1495	48	50				171	$args->{error} = \$err unless defined $args->{error};
1496	48					246	require File::Path;
1497	48					80	my @dirs;
1498	48					78	my $ok = eval {
1499	48					9707	File::Path::make_path( $self->[PATH], $args );
1500	48					221	1;
1501							};
1502	48	50				153	if (!$ok) {
1503	0					0	$self->_throw('mkdir', $self->[PATH], "error creating path: $@");
1504							}
1505	48	50	33			266	if ( $err && @$err ) {
1506	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1507	0					0	$self->_throw('mkdir', $file, $message);
1508							}
1509	48					268	return $self;
1510							}
1511
1512							#pod =method mkpath (deprecated)
1513							#pod
1514							#pod Like calling C, but returns the list of directories created or an empty list if
1515							#pod the directories already exist, just like C.
1516							#pod
1517							#pod Deprecated in 0.125.
1518							#pod
1519							#pod =cut
1520
1521							sub mkpath {
1522	2			2	1	6	my ( $self, $args ) = @_;
1523	2	100				7	$args = {} unless ref $args eq 'HASH';
1524	2					3	my $err;
1525	2	50				7	$args->{error} = \$err unless defined $args->{error};
1526	2					12	require File::Path;
1527	2					337	my @dirs = File::Path::make_path( $self->[PATH], $args );
1528	2	50	33			16	if ( $err && @$err ) {
1529	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1530	0					0	Carp::croak("mkpath failed for $file: $message");
1531							}
1532	2					12	return @dirs;
1533							}
1534
1535							#pod =method move
1536							#pod
1537							#pod path("foo.txt")->move("bar.txt");
1538							#pod
1539							#pod Moves the current path to the given destination using L's
1540							#pod C function. Upon success, returns the C object for the
1541							#pod newly moved file.
1542							#pod
1543							#pod If the destination already exists and is a directory, and the source is not a
1544							#pod directory, then the source file will be renamed into the directory
1545							#pod specified by the destination.
1546							#pod
1547							#pod If possible, move() will simply rename the file. Otherwise, it
1548							#pod copies the file to the new location and deletes the original. If an
1549							#pod error occurs during this copy-and-delete process, you may be left
1550							#pod with a (possibly partial) copy of the file under the destination
1551							#pod name.
1552							#pod
1553							#pod Current API available since 0.124. Prior versions used Perl's
1554							#pod -built-in (and less robust) L function
1555							#pod and did not return an object.
1556							#pod
1557							#pod =cut
1558
1559							sub move {
1560	149			149	1	342	my ( $self, $dest ) = @_;
1561	149					4314	require File::Copy;
1562	149	100				24050	File::Copy::move( $self->[PATH], $dest )
1563							or $self->_throw( 'move', $self->[PATH] . "' -> '$dest" );
1564
1565	148	100				2290	return -d $dest ? _path( $dest, $self->basename ) : _path($dest);
1566							}
1567
1568							#pod =method openr, openw, openrw, opena
1569							#pod
1570							#pod $fh = path("foo.txt")->openr($binmode); # read
1571							#pod $fh = path("foo.txt")->openr_raw;
1572							#pod $fh = path("foo.txt")->openr_utf8;
1573							#pod
1574							#pod $fh = path("foo.txt")->openw($binmode); # write
1575							#pod $fh = path("foo.txt")->openw_raw;
1576							#pod $fh = path("foo.txt")->openw_utf8;
1577							#pod
1578							#pod $fh = path("foo.txt")->opena($binmode); # append
1579							#pod $fh = path("foo.txt")->opena_raw;
1580							#pod $fh = path("foo.txt")->opena_utf8;
1581							#pod
1582							#pod $fh = path("foo.txt")->openrw($binmode); # read/write
1583							#pod $fh = path("foo.txt")->openrw_raw;
1584							#pod $fh = path("foo.txt")->openrw_utf8;
1585							#pod
1586							#pod Returns a file handle opened in the specified mode. The C style methods
1587							#pod take a single C argument. All of the C methods have
1588							#pod C and C equivalents that use buffered I/O layers C<:raw>
1589							#pod and C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
1590							#pod L).
1591							#pod
1592							#pod An optional hash reference may be used to pass options. The only option is
1593							#pod C. If true, handles opened for writing, appending or read-write are
1594							#pod locked with C; otherwise, they are locked for C.
1595							#pod
1596							#pod $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );
1597							#pod
1598							#pod See L for more on locking.
1599							#pod
1600							#pod Current API available since 0.011.
1601							#pod
1602							#pod =cut
1603
1604							# map method names to corresponding open mode
1605							my %opens = (
1606							opena => ">>",
1607							openr => "<",
1608							openw => ">",
1609							openrw => "+<"
1610							);
1611
1612							while ( my ( $k, $v ) = each %opens ) {
1613	29			29		291	no strict 'refs';
	29					68
	29					116486
1614							# must check for lexical IO mode hint
1615							*{$k} = sub {
1616	70			70		11351	my ( $self, @args ) = @_;
1617	70	100	100			303	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1618	70					187	$args = _get_args( $args, qw/locked/ );
1619	70					136	my ($binmode) = @args;
1620	70	100	100			814	$binmode = ( ( caller(0) )[10] \|\| {} )->{ 'open' . substr( $v, -1, 1 ) }
1621							unless defined $binmode;
1622	70					272	$self->filehandle( $args, $v, $binmode );
1623							};
1624							*{ $k . "_raw" } = sub {
1625	39			39		4139	my ( $self, @args ) = @_;
1626	39	100	66			166	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1627	39					108	$args = _get_args( $args, qw/locked/ );
1628	39					100	$self->filehandle( $args, $v, ":raw" );
1629							};
1630							*{ $k . "_utf8" } = sub {
1631	18			18		4169	my ( $self, @args ) = @_;
1632	18	50	33			85	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1633	18					48	$args = _get_args( $args, qw/locked/ );
1634	18					44	my $layer;
1635	18	50				49	if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
		50
1636	0					0	$layer = ":raw:utf8_strict";
1637							}
1638							else {
1639	18					31	$layer = ":raw:encoding(UTF-8)";
1640							}
1641	18					50	$self->filehandle( $args, $v, $layer );
1642							};
1643							}
1644
1645							#pod =method parent
1646							#pod
1647							#pod $parent = path("foo/bar/baz")->parent; # foo/bar
1648							#pod $parent = path("foo/wibble.txt")->parent; # foo
1649							#pod
1650							#pod $parent = path("foo/bar/baz")->parent(2); # foo
1651							#pod
1652							#pod Returns a C object corresponding to the parent directory of the
1653							#pod original directory or file. An optional positive integer argument is the number
1654							#pod of parent directories upwards to return. C by itself is equivalent to
1655							#pod C.
1656							#pod
1657							#pod Current API available since 0.014.
1658							#pod
1659							#pod =cut
1660
1661							# XXX this is ugly and coverage is incomplete. I think it's there for windows
1662							# so need to check coverage there and compare
1663							sub parent {
1664	358			358	1	2284	my ( $self, $level ) = @_;
1665	358	100	100			1022	$level = 1 unless defined $level && $level > 0;
1666	358	100				986	$self->_splitpath unless defined $self->[FILE];
1667	358					521	my $parent;
1668	358	100				788	if ( length $self->[FILE] ) {
		50
1669	316	100	100			1013	if ( $self->[FILE] eq '.' \|\| $self->[FILE] eq ".." ) {
1670	58					159	$parent = _path( $self->[PATH] . "/.." );
1671							}
1672							else {
1673	258					797	$parent = _path( _non_empty( $self->[VOL] . $self->[DIR] ) );
1674							}
1675							}
1676							elsif ( length $self->[DIR] ) {
1677							# because of symlinks, any internal updir requires us to
1678							# just add more updirs at the end
1679	42	100				176	if ( $self->[DIR] =~ m{(?:^\.\./\|/\.\./\|/\.\.\z)} ) {
1680	35					106	$parent = _path( $self->[VOL] . $self->[DIR] . "/.." );
1681							}
1682							else {
1683	7					15	( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/};
1684	7					22	$parent = _path( $self->[VOL] . $dir );
1685							}
1686							}
1687							else {
1688	0					0	$parent = _path( _non_empty( $self->[VOL] ) );
1689							}
1690	358	100				1984	return $level == 1 ? $parent : $parent->parent( $level - 1 );
1691							}
1692
1693							sub _non_empty {
1694	258			258		446	my ($string) = shift;
1695	258	100	66			968	return ( ( defined($string) && length($string) ) ? $string : "." );
1696							}
1697
1698							#pod =method realpath
1699							#pod
1700							#pod $real = path("/baz/foo/../bar")->realpath;
1701							#pod $real = path("foo/../bar")->realpath;
1702							#pod
1703							#pod Returns a new C object with all symbolic links and upward directory
1704							#pod parts resolved using L's C. Compared to C, this is
1705							#pod more expensive as it must actually consult the filesystem.
1706							#pod
1707							#pod If the parent path can't be resolved (e.g. if it includes directories that
1708							#pod don't exist), an exception will be thrown:
1709							#pod
1710							#pod $real = path("doesnt_exist/foo")->realpath; # dies
1711							#pod
1712							#pod However, if the parent path exists and only the last component (e.g. filename)
1713							#pod doesn't exist, the realpath will be the realpath of the parent plus the
1714							#pod non-existent last component:
1715							#pod
1716							#pod $real = path("./aasdlfasdlf")->realpath; # works
1717							#pod
1718							#pod The underlying L module usually worked this way on Unix, but died on
1719							#pod Windows (and some Unixes) if the full path didn't exist. As of version 0.064,
1720							#pod it's safe to use anywhere.
1721							#pod
1722							#pod Current API available since 0.001.
1723							#pod
1724							#pod =cut
1725
1726							# Win32 and some Unixes need parent path resolved separately so realpath
1727							# doesn't throw an error resolving non-existent basename
1728							sub realpath {
1729	33			33	1	560	my $self = shift;
1730	33					105	$self = $self->_resolve_symlinks;
1731	32					173	require Cwd;
1732	32	100				124	$self->_splitpath if !defined $self->[FILE];
1733	32		100			194	my $check_parent =
1734							length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..';
1735	32					61	my $realpath = eval {
1736							# pure-perl Cwd can carp
1737	32			0		220	local $SIG{__WARN__} = sub { };
1738	32	100				282	Cwd::realpath( $check_parent ? $self->parent->[PATH] : $self->[PATH] );
1739							};
1740							# parent realpath must exist; not all Cwd::realpath will error if it doesn't
1741	32	100	33			554	$self->_throw("resolving realpath")
			66
1742							unless defined $realpath && length $realpath && -e $realpath;
1743	31	100				140	return ( $check_parent ? _path( $realpath, $self->[FILE] ) : _path($realpath) );
1744							}
1745
1746							#pod =method relative
1747							#pod
1748							#pod $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
1749							#pod
1750							#pod Returns a C object with a path relative to a new base path
1751							#pod given as an argument. If no argument is given, the current directory will
1752							#pod be used as the new base path.
1753							#pod
1754							#pod If either path is already relative, it will be made absolute based on the
1755							#pod current directly before determining the new relative path.
1756							#pod
1757							#pod The algorithm is roughly as follows:
1758							#pod
1759							#pod =for :list
1760							#pod * If the original and new base path are on different volumes, an exception
1761							#pod will be thrown.
1762							#pod * If the original and new base are identical, the relative path is C<".">.
1763							#pod * If the new base subsumes the original, the relative path is the original
1764							#pod path with the new base chopped off the front
1765							#pod * If the new base does not subsume the original, a common prefix path is
1766							#pod determined (possibly the root directory) and the relative path will
1767							#pod consist of updirs (C<"..">) to reach the common prefix, followed by the
1768							#pod original path less the common prefix.
1769							#pod
1770							#pod Unlike C, in the last case above, the calculation based
1771							#pod on a common prefix takes into account symlinks that could affect the updir
1772							#pod process. Given an original path "/A/B" and a new base "/A/C",
1773							#pod (where "A", "B" and "C" could each have multiple path components):
1774							#pod
1775							#pod =for :list
1776							#pod * Symlinks in "A" don't change the result unless the last component of A is
1777							#pod a symlink and the first component of "C" is an updir.
1778							#pod * Symlinks in "B" don't change the result and will exist in the result as
1779							#pod given.
1780							#pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into
1781							#pod account the possibility that not all path components might exist on the
1782							#pod filesystem.
1783							#pod
1784							#pod Current API available since 0.001. New algorithm (that accounts for
1785							#pod symlinks) available since 0.079.
1786							#pod
1787							#pod =cut
1788
1789							sub relative {
1790	72			72	1	191	my ( $self, $base ) = @_;
1791	72	100	100			282	$base = _path( defined $base && length $base ? $base : '.' );
1792
1793							# relative paths must be converted to absolute first
1794	72	100				205	$self = $self->absolute if $self->is_relative;
1795	72	100				200	$base = $base->absolute if $base->is_relative;
1796
1797							# normalize volumes if they exist
1798	72	50	33			218	$self = $self->absolute if !length $self->volume && length $base->volume;
1799	72	50	33			137	$base = $base->absolute if length $self->volume && !length $base->volume;
1800
1801							# can't make paths relative across volumes
1802	72	50				131	if ( !_same( $self->volume, $base->volume ) ) {
1803	0					0	Carp::croak("relative() can't cross volumes: '$self' vs '$base'");
1804							}
1805
1806							# if same absolute path, relative is current directory
1807	72	100				155	return _path(".") if _same( $self->[PATH], $base->[PATH] );
1808
1809							# if base is a prefix of self, chop prefix off self
1810	66	100				158	if ( $base->subsumes($self) ) {
1811	20	100				58	$base = "" if $base->is_rootdir;
1812	20					44	my $relative = "$self";
1813	20					77	$relative =~ s{\A\Q$base/}{};
1814	20					86	return _path(".", $relative);
1815							}
1816
1817							# base is not a prefix, so must find a common prefix (even if root)
1818	46					109	my ( @common, @self_parts, @base_parts );
1819	46					115	@base_parts = split /\//, $base->_just_filepath;
1820
1821							# if self is rootdir, then common directory is root (shown as empty
1822							# string for later joins); otherwise, must be computed from path parts.
1823	46	100				101	if ( $self->is_rootdir ) {
1824	6					15	@common = ("");
1825	6					9	shift @base_parts;
1826							}
1827							else {
1828	40					68	@self_parts = split /\//, $self->_just_filepath;
1829
1830	40		66			206	while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) {
			100
1831	154					258	push @common, shift @base_parts;
1832	154					459	shift @self_parts;
1833							}
1834							}
1835
1836							# if there are any symlinks from common to base, we have a problem, as
1837							# you can't guarantee that updir from base reaches the common prefix;
1838							# we must resolve symlinks and try again; likewise, any updirs are
1839							# a problem as it throws off calculation of updirs needed to get from
1840							# self's path to the common prefix.
1841	46	100				126	if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) {
1842	6					34	return $self->relative($new_base);
1843							}
1844
1845							# otherwise, symlinks in common or from common to A don't matter as
1846							# those don't involve updirs
1847	40					204	my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts );
1848	40					104	return _path(@new_path);
1849							}
1850
1851							sub _just_filepath {
1852	87			87		129	my $self = shift;
1853	87					129	my $self_vol = $self->volume;
1854	87	50				224	return "$self" if !length $self_vol;
1855
1856	0					0	( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{};
1857
1858	0					0	return $self_path;
1859							}
1860
1861							sub _resolve_between {
1862	46			46		89	my ( $self, $common, $base ) = @_;
1863	46					86	my $path = $self->volume . join( "/", @$common );
1864	46					82	my $changed = 0;
1865	46					91	for my $p (@$base) {
1866	141					278	$path .= "/$p";
1867	141	100				244	if ( $p eq '..' ) {
1868	4					10	$changed = 1;
1869	4	100				51	if ( -e $path ) {
1870	2					11	$path = _path($path)->realpath->[PATH];
1871							}
1872							else {
1873	2					24	$path =~ s{/[^/]+/..\z}{/};
1874							}
1875							}
1876	141	100				1904	if ( -l $path ) {
1877	2					5	$changed = 1;
1878	2					18	$path = _path($path)->realpath->[PATH];
1879							}
1880							}
1881	46	100				197	return $changed ? _path($path) : undef;
1882							}
1883
1884							#pod =method remove
1885							#pod
1886							#pod path("foo.txt")->remove;
1887							#pod
1888							#pod This is just like C, except for its error handling: if the path does
1889							#pod not exist, it returns false; if deleting the file fails, it throws an
1890							#pod exception.
1891							#pod
1892							#pod Current API available since 0.012.
1893							#pod
1894							#pod =cut
1895
1896							sub remove {
1897	10			10	1	1102	my $self = shift;
1898
1899	10	100	100			227	return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1900
1901	9		66			798	return unlink( $self->[PATH] ) \|\| $self->_throw('unlink');
1902							}
1903
1904							#pod =method remove_tree
1905							#pod
1906							#pod # directory
1907							#pod path("foo/bar/baz")->remove_tree;
1908							#pod path("foo/bar/baz")->remove_tree( \%options );
1909							#pod path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove
1910							#pod
1911							#pod Like calling C from L, but defaults to C mode.
1912							#pod An optional hash reference is passed through to C. Errors will be
1913							#pod trapped and an exception thrown. Returns the number of directories deleted,
1914							#pod just like C.
1915							#pod
1916							#pod If you want to remove a directory only if it is empty, use the built-in
1917							#pod C function instead.
1918							#pod
1919							#pod rmdir path("foo/bar/baz/");
1920							#pod
1921							#pod Current API available since 0.013.
1922							#pod
1923							#pod =cut
1924
1925							sub remove_tree {
1926	22			22	1	338	my ( $self, $args ) = @_;
1927	22	100	100			398	return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1928	20	100				79	$args = {} unless ref $args eq 'HASH';
1929	20					33	my $err;
1930	20	50				77	$args->{error} = \$err unless defined $args->{error};
1931	20	100				57	$args->{safe} = 1 unless defined $args->{safe};
1932	20					158	require File::Path;
1933	20					10354	my $count = File::Path::remove_tree( $self->[PATH], $args );
1934
1935	20	50	33			154	if ( $err && @$err ) {
1936	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1937	0					0	Carp::croak("remove_tree failed for $file: $message");
1938							}
1939	20					137	return $count;
1940							}
1941
1942							#pod =method sibling
1943							#pod
1944							#pod $foo = path("/tmp/foo.txt");
1945							#pod $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt
1946							#pod $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt
1947							#pod
1948							#pod Returns a new C object relative to the parent of the original.
1949							#pod This is slightly more efficient than C<< $path->parent->child(...) >>.
1950							#pod
1951							#pod Current API available since 0.058.
1952							#pod
1953							#pod =cut
1954
1955							sub sibling {
1956	6			6	1	12	my $self = shift;
1957	6					16	return _path( $self->parent->[PATH], @_ );
1958							}
1959
1960							#pod =method size, size_human
1961							#pod
1962							#pod my $p = path("foo"); # with size 1025 bytes
1963							#pod
1964							#pod $p->size; # "1025"
1965							#pod $p->size_human; # "1.1 K"
1966							#pod $p->size_human( {format => "iec"} ); # "1.1 KiB"
1967							#pod
1968							#pod Returns the size of a file. The C method is just a wrapper around C<-s>.
1969							#pod
1970							#pod The C method provides a human-readable string similar to
1971							#pod C. Like C, it rounds upwards and provides one decimal place for
1972							#pod single-digit sizes and no decimal places for larger sizes. The only available
1973							#pod option is C, which has three valid values:
1974							#pod
1975							#pod =for :list
1976							#pod * 'ls' (the default): base-2 sizes, with C style single-letter suffixes (K, M, etc.)
1977							#pod * 'iec': base-2 sizes, with IEC binary suffixes (KiB, MiB, etc.)
1978							#pod * 'si': base-10 sizes, with SI decimal suffixes (kB, MB, etc.)
1979							#pod
1980							#pod If C<-s> would return C, C returns the empty string.
1981							#pod
1982							#pod Current API available since 0.122.
1983							#pod
1984							#pod =cut
1985
1986	1			1	1	22	sub size { -s $_[0]->[PATH] }
1987
1988							my %formats = (
1989							'ls' => [ 1024, log(1024), [ "", map { " $_" } qw/K M G T/ ] ],
1990							'iec' => [ 1024, log(1024), [ "", map { " $_" } qw/KiB MiB GiB TiB/ ] ],
1991							'si' => [ 1000, log(1000), [ "", map { " $_" } qw/kB MB GB TB/ ] ],
1992							);
1993
1994	93			93		60802	sub _formats { return $formats{$_[0]} }
1995
1996							sub size_human {
1997	7			7	1	25	my $self = shift;
1998	7					16	my $args = _get_args( shift, qw/format/ );
1999	7	100				18	my $format = defined $args->{format} ? $args->{format} : "ls";
2000	7	100				193	my $fmt_opts = $formats{$format}
2001							or Carp::croak("Invalid format '$format' for size_human()");
2002	6					93	my $size = -s $self->[PATH];
2003	6	100				38	return defined $size ? _human_size( $size, @$fmt_opts ) : "";
2004							}
2005
2006							sub _ceil {
2007	92	100		92		234	return $_[0] == int($_[0]) ? $_[0] : int($_[0]+1);
2008							}
2009
2010							sub _human_size {
2011	98			98		381	my ( $size, $base, $log_base, $suffixes ) = @_;
2012	98	100				229	return "0" if $size == 0;
2013
2014	95					352	my $mag = int( log($size) / $log_base );
2015	95					163	$size /= $base**$mag;
2016	95	100				333	$size =
		100
2017							$mag == 0 ? $size
2018							: length( int($size) ) == 1 ? _ceil( $size * 10 ) / 10
2019							: _ceil($size);
2020	95	100				210	if ( $size >= $base ) {
2021	9					14	$size /= $base;
2022	9					12	$mag++;
2023							}
2024
2025	95	100	100			409	my $fmt = ( $mag == 0 \|\| length( int($size) ) > 1 ) ? "%.0f%s" : "%.1f%s";
2026	95					676	return sprintf( $fmt, $size, $suffixes->[$mag] );
2027							}
2028
2029							#pod =method slurp, slurp_raw, slurp_utf8
2030							#pod
2031							#pod $data = path("foo.txt")->slurp;
2032							#pod $data = path("foo.txt")->slurp( {binmode => ":raw"} );
2033							#pod $data = path("foo.txt")->slurp_raw;
2034							#pod $data = path("foo.txt")->slurp_utf8;
2035							#pod
2036							#pod Reads file contents into a scalar. Takes an optional hash reference which may
2037							#pod be used to pass options. The only available option is C, which is
2038							#pod passed to C on the handle used for reading.
2039							#pod
2040							#pod C is like C with a C of C<:unix> for
2041							#pod a fast, unbuffered, raw read.
2042							#pod
2043							#pod C is like C with a C of
2044							#pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
2045							#pod L). If L 0.58+ is installed, a
2046							#pod unbuffered, raw slurp will be done instead and the result decoded with
2047							#pod C. This is just as strict and is roughly an order of
2048							#pod magnitude faster than using C<:encoding(UTF-8)>.
2049							#pod
2050							#pod B: C and friends lock the filehandle before slurping. If
2051							#pod you plan to slurp from a file created with L, be sure to
2052							#pod close other handles or open without locking to avoid a deadlock:
2053							#pod
2054							#pod my $tempfile = File::Temp->new(EXLOCK => 0);
2055							#pod my $guts = path($tempfile)->slurp;
2056							#pod
2057							#pod Current API available since 0.004.
2058							#pod
2059							#pod =cut
2060
2061							sub slurp {
2062	116			116	1	2268	my $self = shift;
2063	116					255	my $args = _get_args( shift, qw/binmode/ );
2064	114					228	my $binmode = $args->{binmode};
2065	114	100	100			598	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open<'} unless defined $binmode;
2066	114					382	my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
2067	113	100	66			914	if ( ( defined($binmode) ? $binmode : "" ) eq ":unix"
		100
2068							and my $size = -s $fh )
2069							{
2070	41					87	my $buf;
2071	41					507	my $rc = read $fh, $buf, $size; # File::Slurp in a nutshell
2072	41	50				132	$self->_throw('read') unless defined $rc;
2073	41					827	return $buf;
2074							}
2075							else {
2076	72					291	local $/;
2077	72					2165	my $buf = scalar <$fh>;
2078	72	50				600	$self->_throw('read') unless defined $buf;
2079	72					1450	return $buf;
2080							}
2081							}
2082
2083	28			28	1	168	sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp }
	28					91
2084
2085							sub slurp_utf8 {
2086	27	100		27	1	2177	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		100
		100
		50
2087	10					41	return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) );
2088							}
2089							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
2090	0					0	$_[1] = { binmode => ":unix:utf8_strict" };
2091	0					0	goto &slurp;
2092							}
2093							else {
2094	17					74	$_[1] = { binmode => ":unix:encoding(UTF-8)" };
2095	17					56	goto &slurp;
2096							}
2097							}
2098
2099							#pod =method spew, spew_raw, spew_utf8
2100							#pod
2101							#pod path("foo.txt")->spew(@data);
2102							#pod path("foo.txt")->spew(\@data);
2103							#pod path("foo.txt")->spew({binmode => ":raw"}, @data);
2104							#pod path("foo.txt")->spew_raw(@data);
2105							#pod path("foo.txt")->spew_utf8(@data);
2106							#pod
2107							#pod Writes data to a file atomically. The file is written to a temporary file in
2108							#pod the same directory, then renamed over the original. An optional hash reference
2109							#pod may be used to pass options. The only option is C, which is passed to
2110							#pod C on the handle used for writing.
2111							#pod
2112							#pod C is like C with a C of C<:unix> for a fast,
2113							#pod unbuffered, raw write.
2114							#pod
2115							#pod C is like C with a C of C<:unix:encoding(UTF-8)>
2116							#pod (or C<:unix:utf8_strict> with L). If L
2117							#pod 0.58+ is installed, a raw, unbuffered spew will be done instead on the data
2118							#pod encoded with C.
2119							#pod
2120							#pod B: because the file is written to a temporary file and then renamed, the
2121							#pod new file will wind up with permissions based on your current umask. This is a
2122							#pod feature to protect you from a race condition that would otherwise give
2123							#pod different permissions than you might expect. If you really want to keep the
2124							#pod original mode flags, use L with the C option.
2125							#pod
2126							#pod Current API available since 0.011.
2127							#pod
2128							#pod =cut
2129
2130							sub spew {
2131	138			138	1	868	my ( $self, @data ) = @_;
2132	138	100	100			666	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
2133	138					360	$args = _get_args( $args, qw/binmode/ );
2134	137					269	my $binmode = $args->{binmode};
2135							# get default binmode from caller's lexical scope (see "perldoc open")
2136	137	100	100			870	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
2137
2138							# writing needs to follow the link and create the tempfile in the same
2139							# dir for later atomic rename
2140	137					387	my $resolved_path = $self->_resolve_symlinks;
2141	137					338	my $temp = $resolved_path->_replacment_path;
2142
2143	137					547	my $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
2144	136	100				310	print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data) or self->_throw('print', $temp->[PATH]);
	136	50				387
	264					3105
2145	136	50				10399	close $fh or $self->_throw( 'close', $temp->[PATH] );
2146
2147	136					734	return $temp->move($resolved_path);
2148							}
2149
2150	25			25	1	270	sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew }
	25					76
2151
2152							sub spew_utf8 {
2153	33	100		33	1	323	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		100
		100
		50
2154	11					22	my $self = shift;
2155							spew(
2156							$self,
2157							{ binmode => ":unix" },
2158	11	100				50	map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_
	31					97
	29					78
2159							);
2160							}
2161							elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
2162	0					0	splice @_, 1, 0, { binmode => ":unix:utf8_strict" };
2163	0					0	goto &spew;
2164							}
2165							else {
2166	22					363	splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" };
2167	22					75	goto &spew;
2168							}
2169							}
2170
2171							#pod =method stat, lstat
2172							#pod
2173							#pod $stat = path("foo.txt")->stat;
2174							#pod $stat = path("/some/symlink")->lstat;
2175							#pod
2176							#pod Like calling C or C from L.
2177							#pod
2178							#pod Current API available since 0.001.
2179							#pod
2180							#pod =cut
2181
2182							# XXX break out individual stat() components as subs?
2183							sub stat {
2184	9			9	1	992	my $self = shift;
2185	9					2016	require File::stat;
2186	9		66			27780	return File::stat::stat( $self->[PATH] ) \|\| $self->_throw('stat');
2187							}
2188
2189							sub lstat {
2190	2			2	1	9	my $self = shift;
2191	2					11	require File::stat;
2192	2		66			10	return File::stat::lstat( $self->[PATH] ) \|\| $self->_throw('lstat');
2193							}
2194
2195							#pod =method stringify
2196							#pod
2197							#pod $path = path("foo.txt");
2198							#pod say $path->stringify; # same as "$path"
2199							#pod
2200							#pod Returns a string representation of the path. Unlike C, this method
2201							#pod returns the path standardized with Unix-style C directory separators.
2202							#pod
2203							#pod Current API available since 0.001.
2204							#pod
2205							#pod =cut
2206
2207	2685	100		2685	1	129319	sub stringify { $_[0]->[PATH] =~ /^~/ ? './' . $_[0]->[PATH] : $_[0]->[PATH] }
2208
2209							#pod =method subsumes
2210							#pod
2211							#pod path("foo/bar")->subsumes("foo/bar/baz"); # true
2212							#pod path("/foo/bar")->subsumes("/foo/baz"); # false
2213							#pod
2214							#pod Returns true if the first path is a prefix of the second path at a directory
2215							#pod boundary.
2216							#pod
2217							#pod This B resolve parent directory entries (C<..>) or symlinks:
2218							#pod
2219							#pod path("foo/bar")->subsumes("foo/bar/../baz"); # true
2220							#pod
2221							#pod If such things are important to you, ensure that both paths are resolved to
2222							#pod the filesystem with C:
2223							#pod
2224							#pod my $p1 = path("foo/bar")->realpath;
2225							#pod my $p2 = path("foo/bar/../baz")->realpath;
2226							#pod if ( $p1->subsumes($p2) ) { ... }
2227							#pod
2228							#pod Current API available since 0.048.
2229							#pod
2230							#pod =cut
2231
2232							sub subsumes {
2233	96			96	1	146	my $self = shift;
2234	96	50				179	Carp::croak("subsumes() requires a defined, positive-length argument")
2235							unless defined $_[0];
2236	96					160	my $other = _path(shift);
2237
2238							# normalize absolute vs relative
2239	96	100	100			221	if ( $self->is_absolute && !$other->is_absolute ) {
		100	100
2240	3					9	$other = $other->absolute;
2241							}
2242							elsif ( $other->is_absolute && !$self->is_absolute ) {
2243	2					6	$self = $self->absolute;
2244							}
2245
2246							# normalize volume vs non-volume; do this after absolute path
2247							# adjustments above since that might add volumes already
2248	96	50	33			225	if ( length $self->volume && !length $other->volume ) {
		50	33
2249	0					0	$other = $other->absolute;
2250							}
2251							elsif ( length $other->volume && !length $self->volume ) {
2252	0					0	$self = $self->absolute;
2253							}
2254
2255	96	100				248	if ( $self->[PATH] eq '.' ) {
		100
2256	2					13	return !!1; # cwd subsumes everything relative
2257							}
2258							elsif ( $self->is_rootdir ) {
2259							# a root directory ("/", "c:/") already ends with a separator
2260	4					74	return $other->[PATH] =~ m{^\Q$self->[PATH]\E};
2261							}
2262							else {
2263							# exact match or prefix breaking at a separator
2264	90					1717	return $other->[PATH] =~ m{^\Q$self->[PATH]\E(?:/\|\z)};
2265							}
2266							}
2267
2268							#pod =method touch
2269							#pod
2270							#pod path("foo.txt")->touch;
2271							#pod path("foo.txt")->touch($epoch_secs);
2272							#pod
2273							#pod Like the Unix C utility. Creates the file if it doesn't exist, or else
2274							#pod changes the modification and access times to the current time. If the first
2275							#pod argument is the epoch seconds then it will be used.
2276							#pod
2277							#pod Returns the path object so it can be easily chained with other methods:
2278							#pod
2279							#pod # won't die if foo.txt doesn't exist
2280							#pod $content = path("foo.txt")->touch->slurp;
2281							#pod
2282							#pod Current API available since 0.015.
2283							#pod
2284							#pod =cut
2285
2286							sub touch {
2287	27			27	1	512	my ( $self, $epoch ) = @_;
2288	27	100				729	if ( !-e $self->[PATH] ) {
2289	25					95	my $fh = $self->openw;
2290	25	50				366	close $fh or $self->_throw('close');
2291							}
2292	27	100				101	if ( defined $epoch ) {
2293	1	50				32	utime $epoch, $epoch, $self->[PATH]
2294							or $self->_throw("utime ($epoch)");
2295							}
2296							else {
2297							# literal undef prevents warnings :-(
2298	26	50				449	utime undef, undef, $self->[PATH]
2299							or $self->_throw("utime ()");
2300							}
2301	27					169	return $self;
2302							}
2303
2304							#pod =method touchpath
2305							#pod
2306							#pod path("bar/baz/foo.txt")->touchpath;
2307							#pod
2308							#pod Combines C and C. Creates the parent directory if it doesn't exist,
2309							#pod before touching the file. Returns the path object like C does.
2310							#pod
2311							#pod If you need to pass options, use C and C separately:
2312							#pod
2313							#pod path("bar/baz")->mkdir( \%options )->child("foo.txt")->touch($epoch_secs);
2314							#pod
2315							#pod Current API available since 0.022.
2316							#pod
2317							#pod =cut
2318
2319							sub touchpath {
2320	16			16	1	34	my ($self) = @_;
2321	16					46	my $parent = $self->parent;
2322	16	100				39	$parent->mkdir unless $parent->exists;
2323	16					83	$self->touch;
2324							}
2325
2326							#pod =method visit
2327							#pod
2328							#pod path("/tmp")->visit( \&callback, \%options );
2329							#pod
2330							#pod Executes a callback for each child of a directory. It returns a hash
2331							#pod reference with any state accumulated during iteration.
2332							#pod
2333							#pod The options are the same as for L (which it uses internally):
2334							#pod C and C. Both default to false.
2335							#pod
2336							#pod The callback function will receive a C object as the first argument
2337							#pod and a hash reference to accumulate state as the second argument. For example:
2338							#pod
2339							#pod # collect files sizes
2340							#pod my $sizes = path("/tmp")->visit(
2341							#pod sub {
2342							#pod my ($path, $state) = @_;
2343							#pod return if $path->is_dir;
2344							#pod $state->{$path} = -s $path;
2345							#pod },
2346							#pod { recurse => 1 }
2347							#pod );
2348							#pod
2349							#pod For convenience, the C object will also be locally aliased as the
2350							#pod C<$_> global variable:
2351							#pod
2352							#pod # print paths matching /foo/
2353							#pod path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} );
2354							#pod
2355							#pod If the callback returns a B to a false scalar value, iteration will
2356							#pod terminate. This is not the same as "pruning" a directory search; this just
2357							#pod stops all iteration and returns the state hash reference.
2358							#pod
2359							#pod # find up to 10 files larger than 100K
2360							#pod my $files = path("/tmp")->visit(
2361							#pod sub {
2362							#pod my ($path, $state) = @_;
2363							#pod $state->{$path}++ if -s $path > 102400
2364							#pod return \0 if keys %$state == 10;
2365							#pod },
2366							#pod { recurse => 1 }
2367							#pod );
2368							#pod
2369							#pod If you want more flexible iteration, use a module like L.
2370							#pod
2371							#pod Current API available since 0.062.
2372							#pod
2373							#pod =cut
2374
2375							sub visit {
2376	14			14	1	1472	my $self = shift;
2377	14					26	my $cb = shift;
2378	14					38	my $args = _get_args( shift, qw/recurse follow_symlinks/ );
2379	12	50	33			74	Carp::croak("Callback for visit() must be a code reference")
2380							unless defined($cb) && ref($cb) eq 'CODE';
2381	12					33	my $next = $self->iterator($args);
2382	12					50	my $state = {};
2383	12					34	while ( my $file = $next->() ) {
2384	236					346	local $_ = $file;
2385	236					490	my $r = $cb->( $file, $state );
2386	236	100	66			974	last if ref($r) eq 'SCALAR' && !$$r;
2387							}
2388	12					186	return $state;
2389							}
2390
2391							#pod =method volume
2392							#pod
2393							#pod $vol = path("/tmp/foo.txt")->volume; # ""
2394							#pod $vol = path("C:/tmp/foo.txt")->volume; # "C:"
2395							#pod
2396							#pod Returns the volume portion of the path. This is equivalent
2397							#pod to what L would give from C and thus
2398							#pod usually is the empty string on Unix-like operating systems or the
2399							#pod drive letter for an absolute path on C.
2400							#pod
2401							#pod Current API available since 0.001.
2402							#pod
2403							#pod =cut
2404
2405							sub volume {
2406	687			687	1	1050	my ($self) = @_;
2407	687	100				1251	$self->_splitpath unless defined $self->[VOL];
2408	687					1755	return $self->[VOL];
2409							}
2410
2411							package Path::Tiny::Error;
2412
2413							our @CARP_NOT = qw/Path::Tiny/;
2414
2415	29			29		331	use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 );
	29			31		87
	29					305
	31					3712
2416
2417							sub throw {
2418	17			17		57	my ( $class, $op, $file, $err ) = @_;
2419	17					2742	chomp( my $trace = Carp::shortmess );
2420	17					720	my $msg = "Error $op on '$file': $err$trace\n";
2421	17					280	die bless { op => $op, file => $file, err => $err, msg => $msg }, $class;
2422							}
2423
2424							1;
2425
2426
2427							# vim: ts=4 sts=4 sw=4 et:
2428
2429							__END__