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		2539855	use 5.008001;
	29					417
2	29			29		209	use strict;
	29					53
	29					698
3	29			29		150	use warnings;
	29					55
	29					1690
4
5							package Path::Tiny;
6							# ABSTRACT: File path utility
7
8							our $VERSION = '0.143'; # TRIAL
9
10							# Dependencies
11	29			29		203	use Config;
	29					56
	29					1503
12	29			29		176	use Exporter 5.57 (qw/import/);
	29					428
	29					1080
13	29			29		174	use File::Spec 0.86 (); # shipped with 5.8.1
	29					422
	29					609
14	29			29		141	use Carp ();
	29					61
	29					2262
15
16							our @EXPORT = qw/path/;
17							our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/;
18
19							use constant {
20	29					5010	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		192	};
	29					94
28
29							use overload (
30							q{""} => 'stringify',
31							bool => sub () { 1 },
32	29					181	fallback => 1,
33	29			29		3853	);
	29					3041
34
35							# FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol
36	2			2	0	7	sub THAW { return path( $_[2] ) }
37	29			29		3878	{ no warnings 'once'; TO_JSON = FREEZE = \&stringify };
	29					73
	29					15641
38
39							my $HAS_UU; # has Unicode::UTF8; lazily populated
40
41							sub _check_UU {
42	4			4		21	local $SIG{__DIE__}; # prevent outer handler from being called
43	4					10	!!eval {
44	4					836	require Unicode::UTF8;
45	1					487	Unicode::UTF8->VERSION(0.58);
46	1					9	1;
47							};
48							}
49
50							my $HAS_PU; # has PerlIO::utf8_strict; lazily populated
51
52							sub _check_PU {
53	4			4		2307	local $SIG{__DIE__}; # prevent outer handler from being called
54	4					11	!!eval {
55							# MUST preload Encode or $SIG{__DIE__} localization fails
56							# on some Perl 5.8.8 (maybe other 5.8.*) compiled with -O2.
57	4					1147	require Encode;
58	4					43541	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		6302	return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' );
91							}
92
93							BEGIN {
94	29			29		10560	*_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] };
	337			337		806
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		617736	my ( $mode, $symbolic ) = @_;
103	1173					5490	for my $clause ( split /,\s*/, $symbolic ) {
104	2366	100				9266	if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) {
105	2365					6632	my ( $who, $action, $perms ) = ( $1, $2, $3 );
106	2365					5096	$who =~ s/a/ugo/g;
107	2365					5327	for my $w ( split //, $who ) {
108	7391					8888	my $p = 0;
109	7391					17975	$p \|= $MODEBITS{"$w$_"} for split //, $perms;
110	7391	100				12601	if ( $action eq '=' ) {
111	2081					4061	$mode = ( $mode & ~$MODEBITS{"${w}m"} ) \| $p;
112							}
113							else {
114	5310	100				10165	$mode = $action eq "+" ? ( $mode \| $p ) : ( $mode & ~$p );
115							}
116							}
117							}
118							else {
119	1					99	Carp::croak("Invalid mode clause '$clause' for chmod()");
120							}
121							}
122	1172					4923	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		238	{ package flock; use warnings::register }
	29					83
	29					199236
132							#>>>
133
134							my $WARNED_NO_FLOCK = 0;
135
136							sub _throw {
137	16			16		700	my ( $self, $function, $file, $msg ) = @_;
138	16	50	33			94	if ( $function =~ /^flock/
			33
139							&& $! =~ /operation not supported\|function not implemented/i
140							&& !warnings::fatal_enabled('flock') )
141							{
142	0	0				0	if ( !$WARNED_NO_FLOCK ) {
143	0					0	warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" );
144	0					0	$WARNED_NO_FLOCK++;
145							}
146							}
147							else {
148	16	100				98	$msg = $! unless defined $msg;
149	16	100				133	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		3139	my ( $raw, @valid ) = @_;
158	1435	100	100			5419	if ( defined($raw) && ref($raw) ne 'HASH' ) {
159	6					35	my ( undef, undef, undef, $called_as ) = caller(1);
160	6					37	$called_as =~ s{^.*::}{};
161	6					465	Carp::croak("Options for $called_as must be a hash reference");
162							}
163	1429					2165	my $cooked = {};
164	1429					2542	for my $k (@valid) {
165	2403	100				6252	$cooked->{$k} = delete $raw->{$k} if exists $raw->{$k};
166							}
167	1429	100				3794	if ( keys %$raw ) {
168	8					46	my ( undef, undef, undef, $called_as ) = caller(1);
169	8					50	$called_as =~ s{^.*::}{};
170	8					613	Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) );
171							}
172	1421					2940	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	159892	my $path = shift;
224							Carp::croak("Path::Tiny paths require defined, positive-length parts")
225	294	100				746	unless 1 + @_ == grep { defined && length } $path, @_;
	326	100				2224
226
227							# non-temp Path::Tiny objects are effectively immutable and can be reused
228	289	100	100			1449	if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
			66
229	4					15	return $path;
230							}
231
232							# stringify objects
233	285					508	$path = "$path";
234
235							# do any tilde expansions
236	285					809	my ($tilde) = $path =~ m{^(~[^/]*)};
237	285	100				564	if ( defined $tilde ) {
238							# Escape File::Glob metacharacters
239	28					153	(my $escaped = $tilde) =~ s/([\[\{\*\?\\])/\\$1/g;
240	28					151	require File::Glob;
241	28					1843	my ($homedir) = File::Glob::bsd_glob($escaped);
242	28	50	33			309	if (defined $homedir && ! $File::Glob::ERROR) {
243	28					40	$homedir =~ tr[\\][/] if IS_WIN32();
244	28					443	$path =~ s{^\Q$tilde\E}{$homedir};
245							}
246							}
247
248	285					687	unshift @_, $path;
249	285					898	goto &_pathify;
250							}
251
252							# _path is like path but without tilde expansion
253							sub _path {
254	1684			1684		3186	my $path = shift;
255							Carp::croak("Path::Tiny paths require defined, positive-length parts")
256	1684	50				3542	unless 1 + @_ == grep { defined && length } $path, @_;
	2409	50				8688
257
258							# non-temp Path::Tiny objects are effectively immutable and can be reused
259	1684	100	100			9070	if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
			100
260	118					404	return $path;
261							}
262
263							# stringify objects
264	1566					3221	$path = "$path";
265
266	1566					4598	unshift @_, $path;
267	1566					4436	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		2933	my $path = shift;
274
275							# expand relative volume paths on windows; put trailing slash on UNC root
276	1851					2402	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				3563	if (@_) {
283	612	100				1137	$path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ );
284							}
285
286
287							# canonicalize, but with unix slashes and put back trailing volume slash
288	1851					7203	my $cpath = $path = File::Spec->canonpath($path);
289	1851					2637	$path =~ tr[\\][/] if IS_WIN32();
290	1851	50				3558	$path = "/" if $path eq '/..'; # for old File::Spec
291	1851					2364	$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				3125	if ( _is_root($path) ) {
295	57					283	$path =~ s{/?\z}{/};
296							}
297							else {
298	1794					3564	$path =~ s{/\z}{};
299							}
300
301	1851					8751	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	364	sub new { shift; path(@_) }
	2					4
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	17273	require Cwd;
334	10					111	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	148	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	485646	my ( $opts, $maybe_template, $args )
429							= _parse_file_temp_args(tempfile => @_);
430
431							# File::Temp->new demands TEMPLATE
432	187	100				442	$args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template;
433
434	187					1014	require File::Temp;
435	187					999	my $temp = File::Temp->new( TMPDIR => 1, %$args );
436	187					75286	close $temp;
437	187	100				906	my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
438	187					429	$self->[TEMP] = $temp; # keep object alive while we are
439	187					820	return $self;
440							}
441
442							sub tempdir {
443	21			21	1	38407	my ( $opts, $maybe_template, $args )
444							= _parse_file_temp_args(tempdir => @_);
445
446	21					122	require File::Temp;
447	21					152	my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args );
448	21	100				10275	my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
449	21					64	$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					32	$temp->{REALNAME} = $self->[CANON] if IS_WIN32;
454	21					91	return $self;
455							}
456
457							# normalize the various ways File::Temp does templates
458							sub _parse_file_temp_args {
459	208			208		453	my $called_as = shift;
460	208	100	66			1125	if ( @_ && $_[0] eq 'Path::Tiny' ) { shift } # class method
	201	100	66			321
461	7					864	elsif ( @_ && eval{$_[0]->isa('Path::Tiny')} ) {
462	5					11	my $dir = shift;
463	5	50				14	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			698	my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
469	208					532	$opts = _get_args( $opts, qw/realpath/ );
470
471	208	100				649	my $leading_template = ( scalar(@_) % 2 == 1 ? shift(@_) : '' );
472	208					409	my %args = @_;
473	208					454	%args = map { uc($_), $args{$_} } keys %args;
	14					61
474							my @template = (
475							exists $args{TEMPLATE} ? delete $args{TEMPLATE}
476	208	100				604	: $leading_template ? $leading_template
		100
477							: ()
478							);
479
480	208					638	return ( $opts, \@template, \%args );
481							}
482
483							#--------------------------------------------------------------------------#
484							# Private methods
485							#--------------------------------------------------------------------------#
486
487							sub _splitpath {
488	836			836		1270	my ($self) = @_;
489	836					8368	@{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] );
	836					3176
490							}
491
492							sub _resolve_symlinks {
493	179			179		325	my ($self) = @_;
494	179					316	my $new = $self;
495	179					325	my ( $count, %seen ) = 0;
496	179					2971	while ( -l $new->[PATH] ) {
497	12	100				76	if ( $seen{ $new->[PATH] }++ ) {
498	1					11	$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					126	my $resolved = readlink $new->[PATH];
504	11	50				39	$new->_throw( 'readlink', $new->[PATH] ) unless defined $resolved;
505	11					38	$resolved = _path($resolved);
506	11	100				30	$new = $resolved->is_absolute ? $resolved : $new->sibling($resolved);
507							}
508	178					697	return $new;
509							}
510
511							sub _replacment_path {
512	146			146		275	my ($self) = @_;
513
514	146					650	my $unique_suffix = $$ . int( rand( 2**31 ) );
515	146					526	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				434	if ( length $temp->basename > 255 ) {
520	1					6	$temp = $self->sibling( "temp" . $unique_suffix );
521							}
522
523	146					328	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	1078	my ( $self, $base ) = @_;
553
554							# absolute paths handled differently by OS
555	279					432	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				667	return $self if $self->is_absolute;
568							}
569
570							# no base means use current directory as base
571	70					350	require Cwd;
572	70	100				787	return _path( Cwd::getcwd(), $_[0]->[PATH] ) unless defined $base;
573
574							# relative base should be made absolute; we check is_absolute rather
575							# than unconditionally make base absolute so that "/foo" doesn't become
576							# "C:/foo" on Windows.
577	6					16	$base = _path($base);
578	6	50				13	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	3214	my ( $self, @data ) = @_;
616	47	100	100			232	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
617	47					111	$args = _get_args( $args, qw/binmode truncate/ );
618	46					88	my $binmode = $args->{binmode};
619	46	100	100			329	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
620	46	100				126	my $mode = $args->{truncate} ? ">" : ">>";
621	46					147	my $fh = $self->filehandle( { locked => 1 }, $mode, $binmode );
622	46	100				104	print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data ) or self->_throw('print');
	46	50				111
	91					979
623	46	50				2283	close $fh or $self->_throw('close');
624							}
625
626							sub append_raw {
627	9			9	1	2047	my ( $self, @data ) = @_;
628	9	100	66			60	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
629	9					26	$args = _get_args( $args, qw/binmode truncate/ );
630	9					24	$args->{binmode} = ':unix';
631	9					23	append( $self, $args, @data );
632							}
633
634							sub append_utf8 {
635	9			9	1	32	my ( $self, @data ) = @_;
636	9	100	66			58	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
637	9					28	$args = _get_args( $args, qw/binmode truncate/ );
638	9	50				53	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		50
		100
		50
639	3					8	$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					13	$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				8	return $self unless $assertion;
670	2	50				9	if ( ref $assertion eq 'CODE' ) {
671	2					4	local $_ = $self;
672	2	100				6	$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					16	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	1030	my ( $self, @suffixes ) = @_;
700	169	100				628	$self->_splitpath unless defined $self->[FILE];
701	169					408	my $file = $self->[FILE];
702	169					376	for my $s (@suffixes) {
703	8	100				95	my $re = ref($s) eq 'Regexp' ? qr/$s\z/ : qr/\Q$s\E\z/;
704	8	100				56	last if $file =~ s/$re//;
705							}
706	169					474	return $file;
707							}
708
709							#pod =method canonpath
710							#pod
711							#pod $canonical = path("foo/bar")->canonpath; # foo\bar on Windows
712							#pod
713							#pod Returns a string with the canonical format of the path name for
714							#pod the platform. In particular, this means directory separators
715							#pod will be C<\> on Windows.
716							#pod
717							#pod Current API available since 0.001.
718							#pod
719							#pod =cut
720
721	1			1	1	7	sub canonpath { $_[0]->[CANON] }
722
723							#pod =method cached_temp
724							#pod
725							#pod Returns the cached C or C object if the
726							#pod C object was created with C or C.
727							#pod If there is no such object, this method throws.
728							#pod
729							#pod B: Keeping a reference to, or modifying the cached object may
730							#pod break the behavior documented for temporary files and directories created
731							#pod with C and is not supported. Use at your own risk.
732							#pod
733							#pod Current API available since 0.101.
734							#pod
735							#pod =cut
736
737							sub cached_temp {
738	3			3	1	29	my $self = shift;
739	3	100				11	$self->_throw( "cached_temp", $self, "has no cached File::Temp object" )
740							unless defined $self->[TEMP];
741	2					11	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	30212	my ( $self, @parts ) = @_;
764	417					1033	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	2191	my ( $self, $filter ) = @_;
788	9					15	my $dh;
789	9	50				332	opendir $dh, $self->[PATH] or $self->_throw('opendir');
790	9					247	my @children = readdir $dh;
791	9	50				153	closedir $dh or $self->_throw('closedir');
792
793	9	100	66			64	if ( not defined $filter ) {
		100
794	7	100				19	@children = grep { $_ ne '.' && $_ ne '..' } @children;
	25					116
795							}
796							elsif ( $filter && ref($filter) eq 'Regexp' ) {
797	1	100	100			4	@children = grep { $_ ne '.' && $_ ne '..' && $_ =~ $filter } @children;
	5					43
798							}
799							else {
800	1					218	Carp::croak("Invalid argument '$filter' for children()");
801							}
802
803	8					23	return map { _path( $self->[PATH], $_ ) } @children;
	13					45
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	4900	my ( $self, $new_mode ) = @_;
829
830	6					10	my $mode;
831	6	100				41	if ( $new_mode =~ /\d/ ) {
		100
832	3	100				27	$mode = ( $new_mode =~ /^0/ ? oct($new_mode) : $new_mode );
833							}
834							elsif ( $new_mode =~ /[=+-]/ ) {
835	2					13	$mode = _symbolic_chmod( $self->stat->mode & 07777, $new_mode ); ## no critic
836							}
837							else {
838	1					301	Carp::croak("Invalid mode argument '$new_mode' for chmod()");
839							}
840
841	4	100				461	CORE::chmod( $mode, $self->[PATH] ) or $self->_throw("chmod");
842
843	3					22	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	11	my ( $self, $dest ) = @_;
861	2					11	require File::Copy;
862	2	50				6	File::Copy::copy( $self->[PATH], $dest )
863							or Carp::croak("copy failed for $self to $dest: $!");
864
865	2	100				378	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	95	my ( $self, @opts ) = @_;
888	6	100	100			34	my $args = ( @opts && ref $opts[0] eq 'HASH' ) ? shift @opts : {};
889	6					19	$args = _get_args( $args, qw/chunk_size/ );
890	6	100				20	unshift @opts, 'SHA-256' unless @opts;
891	6					27	require Digest;
892	6					27	my $digest = Digest->new(@opts);
893	6	100				3867	if ( $args->{chunk_size} ) {
894	2					8	my $fh = $self->filehandle( { locked => 1 }, "<", ":unix" );
895	2					15	my $buf;
896	2					47	while (!eof($fh)) {
897	10					113	my $rc = read $fh, $buf, $args->{chunk_size};
898	10	50				31	$self->_throw('read') unless defined $rc;
899	10					130	$digest->add($buf);
900							}
901							}
902							else {
903	4					17	$digest->add( $self->slurp_raw );
904							}
905	6					86	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	2621	my ($self) = @_;
927	798	100				2456	$self->_splitpath unless defined $self->[DIR];
928	798	100				3862	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	37	my $self = shift;
955	6					12	my $cb = shift;
956	6					16	my $args = _get_args( shift, qw/binmode/ );
957	6	50	33			41	Carp::croak("Callback for edit() must be a code reference")
958							unless defined($cb) && ref($cb) eq 'CODE';
959
960							local $_ =
961	6	50				41	$self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () );
962	6					44	$cb->();
963	6					86	$self->spew( $args, $_ );
964
965	6					27	return;
966							}
967
968							# this is done long-hand to benefit from slurp_utf8 optimizations
969							sub edit_utf8 {
970	3			3	1	12	my ( $self, $cb ) = @_;
971	3	50	33			28	Carp::croak("Callback for edit_utf8() must be a code reference")
972							unless defined($cb) && ref($cb) eq 'CODE';
973
974	3					16	local $_ = $self->slurp_utf8;
975	3					22	$cb->();
976	3					56	$self->spew_utf8($_);
977
978	3					12	return;
979							}
980
981	3			3	1	35	sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit }
	3					13
982
983							#pod =method edit_lines, edit_lines_utf8, edit_lines_raw
984							#pod
985							#pod path("foo.txt")->edit_lines( \&callback, $options );
986							#pod path("foo.txt")->edit_lines_utf8( \&callback );
987							#pod path("foo.txt")->edit_lines_raw( \&callback );
988							#pod
989							#pod These are convenience methods that allow "editing" a file's lines using a
990							#pod single callback argument. They iterate over the file: for each line, the
991							#pod line is put into a localized C<$_> variable, the callback function is
992							#pod executed (without arguments) and then C<$_> is written to a temporary file.
993							#pod When iteration is finished, the temporary file is atomically renamed over
994							#pod the original.
995							#pod
996							#pod An optional hash reference may be used to pass options. The only option is
997							#pod C, which is passed to the method that open handles for reading and
998							#pod writing.
999							#pod
1000							#pod C is like C with a buffered C of
1001							#pod C<:raw>.
1002							#pod
1003							#pod C is like C with a buffered C
1004							#pod C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
1005							#pod L).
1006							#pod
1007							#pod Current API available since 0.077.
1008							#pod
1009							#pod =cut
1010
1011							sub edit_lines {
1012	9			9	1	54	my $self = shift;
1013	9					17	my $cb = shift;
1014	9					24	my $args = _get_args( shift, qw/binmode/ );
1015	9	50	33			65	Carp::croak("Callback for edit_lines() must be a code reference")
1016							unless defined($cb) && ref($cb) eq 'CODE';
1017
1018	9					22	my $binmode = $args->{binmode};
1019							# get default binmode from caller's lexical scope (see "perldoc open")
1020	9	50	0			25	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open>'} unless defined $binmode;
1021
1022							# writing needs to follow the link and create the tempfile in the same
1023							# dir for later atomic rename
1024	9					26	my $resolved_path = $self->_resolve_symlinks;
1025	9					43	my $temp = $resolved_path->_replacment_path;
1026
1027	9					44	my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
1028	9					56	my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode );
1029
1030	9					24	local $_;
1031	9					204	while (! eof($in_fh) ) {
1032	36	50				441	defined( $_ = readline($in_fh) ) or $self->_throw('readline');
1033	36					93	$cb->();
1034	36	50				254	$temp_fh->print($_) or self->_throw('print', $temp);
1035							}
1036
1037	9	50				881	close $temp_fh or $self->_throw( 'close', $temp );
1038	9	50				126	close $in_fh or $self->_throw('close');
1039
1040	9					39	return $temp->move($resolved_path);
1041							}
1042
1043	3			3	1	35	sub edit_lines_raw { $_[2] = { binmode => ":raw" }; goto &edit_lines }
	3					11
1044
1045							sub edit_lines_utf8 {
1046	3	50		3	1	48	if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
		50
1047	0					0	$_[2] = { binmode => ":raw:utf8_strict" };
1048							}
1049							else {
1050	3					17	$_[2] = { binmode => ":raw:encoding(UTF-8)" };
1051							}
1052	3					14	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	697	sub exists { -e $_[0]->[PATH] }
1075
1076	32	100		32	1	476	sub is_file { -e $_[0]->[PATH] && !-d _ }
1077
1078	6			6	1	98	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	1356	my ( $self, @args ) = @_;
1112	555	100	66			2358	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1113	555					1240	$args = _get_args( $args, qw/locked exclusive/ );
1114	555	100				1263	$args->{locked} = 1 if $args->{exclusive};
1115	555					1200	my ( $opentype, $binmode ) = @args;
1116
1117	555	100				1099	$opentype = "<" unless defined $opentype;
1118							Carp::croak("Invalid file mode '$opentype'")
1119	555	50				1011	unless grep { $opentype eq $_ } qw/< +< > +> >> +>>/;
	3330					6200
1120
1121	555	100	50			2690	$binmode = ( ( caller(0) )[10] \|\| {} )->{ 'open' . substr( $opentype, -1, 1 ) }
1122							unless defined $binmode;
1123	555	100				1304	$binmode = "" unless defined $binmode;
1124
1125	555					973	my ( $fh, $lock, $trunc );
1126	555	100	66			2839	if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) {
			100
1127	448					2401	require Fcntl;
1128							# truncating file modes shouldn't truncate until lock acquired
1129	448	100	33			763	if ( grep { $opentype eq $_ } qw( > +> ) ) {
	896	50				2988
1130							# sysopen in write mode without truncation
1131	155	50				370	my $flags = $opentype eq ">" ? Fcntl::O_WRONLY() : Fcntl::O_RDWR();
1132	155					260	$flags \|= Fcntl::O_CREAT();
1133	155	100				339	$flags \|= Fcntl::O_EXCL() if $args->{exclusive};
1134	155	100				12586	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				1160	if ( $binmode =~ s/^:unix// ) {
1139							# eliminate pseudo-layers
1140	67	50				470	binmode( $fh, ":raw" ) or $self->_throw("binmode (:raw)");
1141							# strip off real layers until only :unix is left
1142	67					575	while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
1143	67	50				488	binmode( $fh, ":pop" ) or $self->_throw("binmode (:pop)");
1144							}
1145							}
1146
1147							# apply any remaining binmode layers
1148	154	100				403	if ( length $binmode ) {
1149	46	50				551	binmode( $fh, $binmode ) or $self->_throw("binmode ($binmode)");
1150							}
1151
1152							# ask for lock and truncation
1153	154					4038	$lock = Fcntl::LOCK_EX();
1154	154					258	$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				683	$lock = $opentype eq "<" ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX();
1168							}
1169							}
1170
1171	554	100				1184	unless ($fh) {
1172	400					767	my $mode = $opentype . $binmode;
1173	400	100		4		17654	open $fh, $mode, $self->[PATH] or $self->_throw("open ($mode)");
	4					24
	4					8
	4					26
1174							}
1175
1176	551	50				8856	do { flock( $fh, $lock ) or $self->_throw("flock ($lock)") } if $lock;
	444	100				4162
1177	551	50				1421	do { truncate( $fh, 0 ) or $self->_throw("truncate") } if $trunc;
	154	100				3487
1178
1179	551					2649	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	2566	my ($self, $other_path) = @_;
1201	11					22	my $other = _path($other_path);
1202
1203	11					41	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				79	if (-d $fh1) {
1208	3					14	$self->_throw('has_same_bytes', $self->[PATH], "directory not allowed");
1209							}
1210	6	100				60	if (-d $fh2) {
1211	1					6	$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					74	return 1
1218							}
1219
1220							# result is 0 for equal, 1 for unequal, -1 for error
1221	2					464	require File::Compare;
1222	2					1045	my $res = File::Compare::compare($fh1, $fh2, 65536);
1223	2	50				183	if ($res < 0) {
1224	0					0	$self->_throw('has_same_bytes')
1225							}
1226
1227	2					49	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	2266	sub is_absolute { substr( $_[0]->dirname, 0, 1 ) eq '/' }
1242
1243	145			145	1	610	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	282	my ($self) = @_;
1266	164	100				312	$self->_splitpath unless defined $self->[DIR];
1267	164		100			514	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	2438	my $self = shift;
1309	20					68	my $args = _get_args( shift, qw/recurse follow_symlinks/ );
1310	18					63	my @dirs = $self;
1311	18					29	my $current;
1312							return sub {
1313	292			292		1455	my $next;
1314	292					559	while (@dirs) {
1315	347	100				808	if ( ref $dirs[0] eq 'Path::Tiny' ) {
1316	74	100				278	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				7	shift @dirs and next;
1324							}
1325	73					237	$current = $dirs[0];
1326	73					104	my $dh;
1327	73	50				1866	opendir( $dh, $current->[PATH] )
1328							or $self->_throw( 'opendir', $current->[PATH] );
1329	73					186	$dirs[0] = $dh;
1330	73	50	66			809	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					2427	while ( defined( $next = readdir $dirs[0] ) ) {
1339	417	100	100			1678	next if $next eq '.' \|\| $next eq '..';
1340	275					567	my $path = $current->child($next);
1341							push @dirs, $path
1342	275	100	100			873	if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path );
			100
			100
1343	275					1255	return $path;
1344							}
1345	71					928	shift @dirs;
1346							}
1347	17					71	return;
1348	18					107	};
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	8084	my $self = shift;
1394	112					257	my $args = _get_args( shift, qw/binmode chomp count/ );
1395	110					207	my $binmode = $args->{binmode};
1396	110	100	100			741	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open<'} unless defined $binmode;
1397	110					433	my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
1398	110					364	my $chomp = $args->{chomp};
1399							# XXX more efficient to read @lines then chomp(@lines) vs map?
1400	110	100				286	if ( $args->{count} ) {
		100
1401	84					214	my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) );
1402	84					137	my $line;
1403	84					1708	while ( !eof($fh) ) {
1404	216	50				1094	defined( $line = readline($fh) ) or $self->_throw('readline');
1405
1406	216	100				766	$line =~ s/(?:\x{0d}?\x{0a}\|\x{0d})\z// if $chomp;
1407	216					475	$result[ $counter++ ] = $line;
1408							# for positive count, terminate after right number of lines
1409	216	100				431	last if $counter == $args->{count};
1410							# for negative count, eventually wrap around in the result array
1411	180					574	$counter %= $mod;
1412							}
1413							# reorder results if full and wrapped somewhere in the middle
1414	84	100	100			373	splice( @result, 0, 0, splice( @result, $counter ) )
1415							if @result == $mod && $counter % $mod;
1416	84					2249	return @result;
1417							}
1418							elsif ($chomp) {
1419	6					44	local $!;
1420	6					168	my @lines = map { s/(?:\x{0d}?\x{0a}\|\x{0d})\z//; $_ } <$fh>; ## no critic
	21					202
	21					55
1421	6	50				32	$self->_throw('readline') if $!;
1422	6					152	return @lines;
1423							}
1424							else {
1425	20	100				50	if ( wantarray ) {
1426	14					123	local $!;
1427	14					398	my @lines = <$fh>;
1428	14	50				129	$self->_throw('readline') if $!;
1429	14					333	return @lines;
1430							} else {
1431	6					41	local $!;
1432	6					161	my $count =()= <$fh>;
1433	6	50				56	$self->_throw('readline') if $!;
1434	6					132	return $count;
1435							}
1436							}
1437							}
1438
1439							sub lines_raw {
1440	17			17	1	42	my $self = shift;
1441	17					48	my $args = _get_args( shift, qw/binmode chomp count/ );
1442	15	50	33			68	if ( $args->{chomp} && !$args->{count} ) {
1443	0					0	return split /\n/, slurp_raw($self); ## no critic
1444							}
1445							else {
1446	15					31	$args->{binmode} = ":raw";
1447	15					42	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	74	my $self = shift;
1455	35					89	my $args = _get_args( shift, qw/binmode chomp count/ );
1456	33	50	100			213	if ( ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) )
		100	100
		100
		50
1457							&& $args->{chomp}
1458							&& !$args->{count} )
1459							{
1460	2					6	my $slurp = slurp_utf8($self);
1461	2					57	$slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF\|CR
1462	2					31	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					126	$args->{binmode} = ":raw:encoding(UTF-8)";
1470	31					86	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	221	my ( $self, $args ) = @_;
1493	48	100				148	$args = {} unless ref $args eq 'HASH';
1494	48					82	my $err;
1495	48	50				176	$args->{error} = \$err unless defined $args->{error};
1496	48					263	require File::Path;
1497	48					84	my @dirs;
1498	48					83	my $ok = eval {
1499	48					9433	File::Path::make_path( $self->[PATH], $args );
1500	48					217	1;
1501							};
1502	48	50				165	if (!$ok) {
1503	0					0	$self->_throw('mkdir', $self->[PATH], "error creating path: $@");
1504							}
1505	48	50	33			247	if ( $err && @$err ) {
1506	0					0	my ( $file, $message ) = %{ $err->[0] };
	0					0
1507	0					0	$self->_throw('mkdir', $file, $message);
1508							}
1509	48					236	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				10	$args = {} unless ref $args eq 'HASH';
1524	2					3	my $err;
1525	2	50				8	$args->{error} = \$err unless defined $args->{error};
1526	2					13	require File::Path;
1527	2					373	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	366	my ( $self, $dest ) = @_;
1561	149					4519	require File::Copy;
1562	149	100				24614	File::Copy::move( $self->[PATH], $dest )
1563							or $self->_throw( 'move', $self->[PATH] . "' -> '$dest" );
1564
1565	148	100				1755	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		351	no strict 'refs';
	29					60
	29					114155
1614							# must check for lexical IO mode hint
1615							*{$k} = sub {
1616	70			70		11706	my ( $self, @args ) = @_;
1617	70	100	100			319	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1618	70					184	$args = _get_args( $args, qw/locked/ );
1619	70					169	my ($binmode) = @args;
1620	70	100	100			848	$binmode = ( ( caller(0) )[10] \|\| {} )->{ 'open' . substr( $v, -1, 1 ) }
1621							unless defined $binmode;
1622	70					282	$self->filehandle( $args, $v, $binmode );
1623							};
1624							*{ $k . "_raw" } = sub {
1625	39			39		4385	my ( $self, @args ) = @_;
1626	39	100	66			163	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1627	39					107	$args = _get_args( $args, qw/locked/ );
1628	39					113	$self->filehandle( $args, $v, ":raw" );
1629							};
1630							*{ $k . "_utf8" } = sub {
1631	18			18		4227	my ( $self, @args ) = @_;
1632	18	50	33			89	my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1633	18					54	$args = _get_args( $args, qw/locked/ );
1634	18					39	my $layer;
1635	18	50				64	if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
		50
1636	0					0	$layer = ":raw:utf8_strict";
1637							}
1638							else {
1639	18					32	$layer = ":raw:encoding(UTF-8)";
1640							}
1641	18					48	$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	2578	my ( $self, $level ) = @_;
1665	358	100	100			1028	$level = 1 unless defined $level && $level > 0;
1666	358	100				1024	$self->_splitpath unless defined $self->[FILE];
1667	358					520	my $parent;
1668	358	100				773	if ( length $self->[FILE] ) {
		50
1669	316	100	100			1047	if ( $self->[FILE] eq '.' \|\| $self->[FILE] eq ".." ) {
1670	58					152	$parent = _path( $self->[PATH] . "/.." );
1671							}
1672							else {
1673	258					726	$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					112	$parent = _path( $self->[VOL] . $self->[DIR] . "/.." );
1681							}
1682							else {
1683	7					14	( 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				2003	return $level == 1 ? $parent : $parent->parent( $level - 1 );
1691							}
1692
1693							sub _non_empty {
1694	258			258		436	my ($string) = shift;
1695	258	100	66			986	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	689	my $self = shift;
1730	33					109	$self = $self->_resolve_symlinks;
1731	32					173	require Cwd;
1732	32	100				123	$self->_splitpath if !defined $self->[FILE];
1733	32		100			203	my $check_parent =
1734							length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..';
1735	32					65	my $realpath = eval {
1736							# pure-perl Cwd can carp
1737	32			0		237	local $SIG{__WARN__} = sub { };
1738	32	100				293	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			512	$self->_throw("resolving realpath")
			66
1742							unless defined $realpath && length $realpath && -e $realpath;
1743	31	100				139	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	216	my ( $self, $base ) = @_;
1791	72	100	100			281	$base = _path( defined $base && length $base ? $base : '.' );
1792
1793							# relative paths must be converted to absolute first
1794	72	100				190	$self = $self->absolute if $self->is_relative;
1795	72	100				288	$base = $base->absolute if $base->is_relative;
1796
1797							# normalize volumes if they exist
1798	72	50	33			237	$self = $self->absolute if !length $self->volume && length $base->volume;
1799	72	50	33			140	$base = $base->absolute if length $self->volume && !length $base->volume;
1800
1801							# can't make paths relative across volumes
1802	72	50				136	if ( !_same( $self->volume, $base->volume ) ) {
1803	0					0	Carp::croak("relative() can't cross volumes: '$self' vs '$base'");
1804							}
1805
1806							# if same absolute path, relative is current directory
1807	72	100				157	return _path(".") if _same( $self->[PATH], $base->[PATH] );
1808
1809							# if base is a prefix of self, chop prefix off self
1810	66	100				151	if ( $base->subsumes($self) ) {
1811	20	100				57	$base = "" if $base->is_rootdir;
1812	20					47	my $relative = "$self";
1813	20					80	$relative =~ s{\A\Q$base/}{};
1814	20					82	return _path(".", $relative);
1815							}
1816
1817							# base is not a prefix, so must find a common prefix (even if root)
1818	46					111	my ( @common, @self_parts, @base_parts );
1819	46					98	@base_parts = split /\//, $base->_just_filepath;
1820
1821							# if self is rootdir, then common directory is root (shown as empty
1822							# string for later joins); otherwise, must be computed from path parts.
1823	46	100				103	if ( $self->is_rootdir ) {
1824	6					14	@common = ("");
1825	6					12	shift @base_parts;
1826							}
1827							else {
1828	40					72	@self_parts = split /\//, $self->_just_filepath;
1829
1830	40		66			207	while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) {
			100
1831	154					272	push @common, shift @base_parts;
1832	154					463	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				113	if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) {
1842	6					36	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					167	my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts );
1848	40					92	return _path(@new_path);
1849							}
1850
1851							sub _just_filepath {
1852	87			87		124	my $self = shift;
1853	87					123	my $self_vol = $self->volume;
1854	87	50				245	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		91	my ( $self, $common, $base ) = @_;
1863	46					84	my $path = $self->volume . join( "/", @$common );
1864	46					75	my $changed = 0;
1865	46					90	for my $p (@$base) {
1866	141					304	$path .= "/$p";
1867	141	100				244	if ( $p eq '..' ) {
1868	4					8	$changed = 1;
1869	4	100				57	if ( -e $path ) {
1870	2					8	$path = _path($path)->realpath->[PATH];
1871							}
1872							else {
1873	2					21	$path =~ s{/[^/]+/..\z}{/};
1874							}
1875							}
1876	141	100				1801	if ( -l $path ) {
1877	2					11	$changed = 1;
1878	2					7	$path = _path($path)->realpath->[PATH];
1879							}
1880							}
1881	46	100				191	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	1333	my $self = shift;
1898
1899	10	100	100			214	return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1900
1901	9		66			568	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	443	my ( $self, $args ) = @_;
1927	22	100	100			407	return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1928	20	100				85	$args = {} unless ref $args eq 'HASH';
1929	20					48	my $err;
1930	20	50				82	$args->{error} = \$err unless defined $args->{error};
1931	20	100				57	$args->{safe} = 1 unless defined $args->{safe};
1932	20					104	require File::Path;
1933	20					9977	my $count = File::Path::remove_tree( $self->[PATH], $args );
1934
1935	20	50	33			164	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					120	return $count;
1940							}
1941
1942							#pod =method sibling
1943							#pod
1944							#pod $foo = path("/tmp/foo.txt");
1945							#pod $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt
1946							#pod $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt
1947							#pod
1948							#pod Returns a new C object relative to the parent of the original.
1949							#pod This is slightly more efficient than C<< $path->parent->child(...) >>.
1950							#pod
1951							#pod Current API available since 0.058.
1952							#pod
1953							#pod =cut
1954
1955							sub sibling {
1956	6			6	1	13	my $self = shift;
1957	6					16	return _path( $self->parent->[PATH], @_ );
1958							}
1959
1960							#pod =method size, size_human
1961							#pod
1962							#pod my $p = path("foo"); # with size 1025 bytes
1963							#pod
1964							#pod $p->size; # "1025"
1965							#pod $p->size_human; # "1.1 K"
1966							#pod $p->size_human( {format => "iec"} ); # "1.1 KiB"
1967							#pod
1968							#pod Returns the size of a file. The C method is just a wrapper around C<-s>.
1969							#pod
1970							#pod The C method provides a human-readable string similar to
1971							#pod C. Like C, it rounds upwards and provides one decimal place for
1972							#pod single-digit sizes and no decimal places for larger sizes. The only available
1973							#pod option is C, which has three valid values:
1974							#pod
1975							#pod =for :list
1976							#pod * 'ls' (the default): base-2 sizes, with C style single-letter suffixes (K, M, etc.)
1977							#pod * 'iec': base-2 sizes, with IEC binary suffixes (KiB, MiB, etc.)
1978							#pod * 'si': base-10 sizes, with SI decimal suffixes (kB, MB, etc.)
1979							#pod
1980							#pod If C<-s> would return C, C returns the empty string.
1981							#pod
1982							#pod Current API available since 0.122.
1983							#pod
1984							#pod =cut
1985
1986	1			1	1	19	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		73799	sub _formats { return $formats{$_[0]} }
1995
1996							sub size_human {
1997	7			7	1	35	my $self = shift;
1998	7					17	my $args = _get_args( shift, qw/format/ );
1999	7	100				17	my $format = defined $args->{format} ? $args->{format} : "ls";
2000	7	100				198	my $fmt_opts = $formats{$format}
2001							or Carp::croak("Invalid format '$format' for size_human()");
2002	6					100	my $size = -s $self->[PATH];
2003	6	100				50	return defined $size ? _human_size( $size, @$fmt_opts ) : "";
2004							}
2005
2006							sub _ceil {
2007	92	100		92		249	return $_[0] == int($_[0]) ? $_[0] : int($_[0]+1);
2008							}
2009
2010							sub _human_size {
2011	98			98		415	my ( $size, $base, $log_base, $suffixes ) = @_;
2012	98	100				235	return "0" if $size == 0;
2013
2014	95					328	my $mag = int( log($size) / $log_base );
2015	95					172	$size /= $base**$mag;
2016	95	100				318	$size =
		100
2017							$mag == 0 ? $size
2018							: length( int($size) ) == 1 ? _ceil( $size * 10 ) / 10
2019							: _ceil($size);
2020	95	100				252	if ( $size >= $base ) {
2021	9					12	$size /= $base;
2022	9					10	$mag++;
2023							}
2024
2025	95	100	100			377	my $fmt = ( $mag == 0 \|\| length( int($size) ) > 1 ) ? "%.0f%s" : "%.1f%s";
2026	95					735	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	2238	my $self = shift;
2063	116					273	my $args = _get_args( shift, qw/binmode/ );
2064	114					285	my $binmode = $args->{binmode};
2065	114	100	100			594	$binmode = ( ( caller(0) )[10] \|\| {} )->{'open<'} unless defined $binmode;
2066	114					387	my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
2067	113	100	66			932	if ( ( defined($binmode) ? $binmode : "" ) eq ":unix"
		100
2068							and my $size = -s $fh )
2069							{
2070	41					95	my $buf;
2071	41					499	my $rc = read $fh, $buf, $size; # File::Slurp in a nutshell
2072	41	50				189	$self->_throw('read') unless defined $rc;
2073	41					849	return $buf;
2074							}
2075							else {
2076	72					297	local $/;
2077	72					2268	my $buf = scalar <$fh>;
2078	72	50				644	$self->_throw('read') unless defined $buf;
2079	72					1574	return $buf;
2080							}
2081							}
2082
2083	28			28	1	193	sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp }
	28					99
2084
2085							sub slurp_utf8 {
2086	27	100		27	1	555	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		100
		100
		50
2087	10					43	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					79	$_[1] = { binmode => ":unix:encoding(UTF-8)" };
2095	17					66	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	902	my ( $self, @data ) = @_;
2132	138	100	100			711	my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
2133	138					359	$args = _get_args( $args, qw/binmode/ );
2134	137					290	my $binmode = $args->{binmode};
2135							# get default binmode from caller's lexical scope (see "perldoc open")
2136	137	100	100			872	$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					464	my $resolved_path = $self->_resolve_symlinks;
2141	137					358	my $temp = $resolved_path->_replacment_path;
2142
2143	137					530	my $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
2144	136	100				314	print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data) or self->_throw('print', $temp->[PATH]);
	136	50				369
	264					3201
2145	136	50				10982	close $fh or $self->_throw( 'close', $temp->[PATH] );
2146
2147	136					731	return $temp->move($resolved_path);
2148							}
2149
2150	25			25	1	316	sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew }
	25					94
2151
2152							sub spew_utf8 {
2153	33	100		33	1	292	if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
		100
		100
		50
2154	11					20	my $self = shift;
2155							spew(
2156							$self,
2157							{ binmode => ":unix" },
2158	11	100				35	map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_
	31					94
	29					74
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					442	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	1426	my $self = shift;
2185	9					2279	require File::stat;
2186	9		66			28257	return File::stat::stat( $self->[PATH] ) \|\| $self->_throw('stat');
2187							}
2188
2189							sub lstat {
2190	2			2	1	12	my $self = shift;
2191	2					11	require File::stat;
2192	2		66			9	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	132160	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	142	my $self = shift;
2234	96	50				177	Carp::croak("subsumes() requires a defined, positive-length argument")
2235							unless defined $_[0];
2236	96					171	my $other = _path(shift);
2237
2238							# normalize absolute vs relative
2239	96	100	100			203	if ( $self->is_absolute && !$other->is_absolute ) {
		100	100
2240	3					7	$other = $other->absolute;
2241							}
2242							elsif ( $other->is_absolute && !$self->is_absolute ) {
2243	2					7	$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			229	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				276	if ( $self->[PATH] eq '.' ) {
		100
2256	2					11	return !!1; # cwd subsumes everything relative
2257							}
2258							elsif ( $self->is_rootdir ) {
2259							# a root directory ("/", "c:/") already ends with a separator
2260	4					63	return $other->[PATH] =~ m{^\Q$self->[PATH]\E};
2261							}
2262							else {
2263							# exact match or prefix breaking at a separator
2264	90					1714	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	689	my ( $self, $epoch ) = @_;
2288	27	100				710	if ( !-e $self->[PATH] ) {
2289	25					105	my $fh = $self->openw;
2290	25	50				384	close $fh or $self->_throw('close');
2291							}
2292	27	100				105	if ( defined $epoch ) {
2293	1	50				23	utime $epoch, $epoch, $self->[PATH]
2294							or $self->_throw("utime ($epoch)");
2295							}
2296							else {
2297							# literal undef prevents warnings :-(
2298	26	50				434	utime undef, undef, $self->[PATH]
2299							or $self->_throw("utime ()");
2300							}
2301	27					176	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	40	my ($self) = @_;
2321	16					37	my $parent = $self->parent;
2322	16	100				49	$parent->mkdir unless $parent->exists;
2323	16					57	$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	1639	my $self = shift;
2377	14					24	my $cb = shift;
2378	14					39	my $args = _get_args( shift, qw/recurse follow_symlinks/ );
2379	12	50	33			65	Carp::croak("Callback for visit() must be a code reference")
2380							unless defined($cb) && ref($cb) eq 'CODE';
2381	12					47	my $next = $self->iterator($args);
2382	12					37	my $state = {};
2383	12					32	while ( my $file = $next->() ) {
2384	236					359	local $_ = $file;
2385	236					503	my $r = $cb->( $file, $state );
2386	236	100	66			955	last if ref($r) eq 'SCALAR' && !$$r;
2387							}
2388	12					188	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	1028	my ($self) = @_;
2407	687	100				1244	$self->_splitpath unless defined $self->[VOL];
2408	687					1790	return $self->[VOL];
2409							}
2410
2411							package Path::Tiny::Error;
2412
2413							our @CARP_NOT = qw/Path::Tiny/;
2414
2415	29			29		314	use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 );
	29			31		79
	29					299
	31					3800
2416
2417							sub throw {
2418	17			17		67	my ( $class, $op, $file, $err ) = @_;
2419	17					2639	chomp( my $trace = Carp::shortmess );
2420	17					702	my $msg = "Error $op on '$file': $err$trace\n";
2421	17					281	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__