← Index
NYTProf Performance Profile   « line view »
For ../prof.pl
  Run on Thu Dec 15 15:23:56 2022
Reported on Thu Dec 15 15:27:02 2022

Filename/Users/ether/.perlbrew/libs/36.0@std/lib/perl5/Path/Tiny.pm
StatementsExecuted 961 statements in 19.0ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
14113.97ms3.97msPath::Tiny::::CORE:read Path::Tiny::CORE:read (opcode)
14113.73ms3.73msPath::Tiny::::CORE:open Path::Tiny::CORE:open (opcode)
14111.06ms9.55msPath::Tiny::::slurp Path::Tiny::slurp
1411483µs4.38msPath::Tiny::::filehandle Path::Tiny::filehandle
1411234µs295µsPath::Tiny::::_pathify Path::Tiny::_pathify
1422147µs159µsPath::Tiny::::path Path::Tiny::path
2821146µs146µsPath::Tiny::::_get_args Path::Tiny::_get_args
1411134µs134µsPath::Tiny::::CORE:flock Path::Tiny::CORE:flock (opcode)
221107µs107µsPath::Tiny::::CORE:regcomp Path::Tiny::CORE:regcomp (opcode)
142261µs61µsPath::Tiny::::slurp_raw Path::Tiny::slurp_raw
282137µs37µsPath::Tiny::::_is_root Path::Tiny::_is_root
11129µs29µsJSON::Schema::Modern::::BEGIN@1JSON::Schema::Modern::BEGIN@1
141126µs26µsPath::Tiny::::CORE:ftsize Path::Tiny::CORE:ftsize (opcode)
11115µs47µsPath::Tiny::Error::::BEGIN@2415 Path::Tiny::Error::BEGIN@2415
141114µs14µsPath::Tiny::::CORE:subst Path::Tiny::CORE:subst (opcode)
11113µs23µsPath::Tiny::::BEGIN@1613 Path::Tiny::BEGIN@1613
141112µs12µsPath::Tiny::::CORE:match Path::Tiny::CORE:match (opcode)
11110µs83µsPath::Tiny::::BEGIN@19 Path::Tiny::BEGIN@19
1119µs12µsJSON::Schema::Modern::::BEGIN@2JSON::Schema::Modern::BEGIN@2
1118µs35µsPath::Tiny::::BEGIN@29 Path::Tiny::BEGIN@29
1117µs14µsPath::Tiny::::BEGIN@11 Path::Tiny::BEGIN@11
1117µs14µsPath::Tiny::::BEGIN@12 Path::Tiny::BEGIN@12
1117µs10µsPath::Tiny::::BEGIN@13 Path::Tiny::BEGIN@13
1116µs35µsJSON::Schema::Modern::::BEGIN@3JSON::Schema::Modern::BEGIN@3
1116µs27µsflock::::BEGIN@131 flock::BEGIN@131
1115µs27µsPath::Tiny::::BEGIN@37 Path::Tiny::BEGIN@37
1114µs4µsPath::Tiny::::BEGIN@93 Path::Tiny::BEGIN@93
6614µs4µsPath::Tiny::::CORE:qr Path::Tiny::CORE:qr (opcode)
1111µs1µsPath::Tiny::::BEGIN@14 Path::Tiny::BEGIN@14
0000s0sPath::Tiny::Error::::__ANON__[:2415] Path::Tiny::Error::__ANON__[:2415]
0000s0sPath::Tiny::Error::::throw Path::Tiny::Error::throw
0000s0sPath::Tiny::::THAW Path::Tiny::THAW
0000s0sPath::Tiny::::__ANON__[:1348] Path::Tiny::__ANON__[:1348]
0000s0sPath::Tiny::::__ANON__[:1623] Path::Tiny::__ANON__[:1623]
0000s0sPath::Tiny::::__ANON__[:1629] Path::Tiny::__ANON__[:1629]
0000s0sPath::Tiny::::__ANON__[:1642] Path::Tiny::__ANON__[:1642]
0000s0sPath::Tiny::::__ANON__[:1737] Path::Tiny::__ANON__[:1737]
0000s0sPath::Tiny::::__ANON__[:94] Path::Tiny::__ANON__[:94]
0000s0sPath::Tiny::::_ceil Path::Tiny::_ceil
0000s0sPath::Tiny::::_check_PU Path::Tiny::_check_PU
0000s0sPath::Tiny::::_check_UU Path::Tiny::_check_UU
0000s0sPath::Tiny::::_formats Path::Tiny::_formats
0000s0sPath::Tiny::::_human_size Path::Tiny::_human_size
0000s0sPath::Tiny::::_just_filepath Path::Tiny::_just_filepath
0000s0sPath::Tiny::::_non_empty Path::Tiny::_non_empty
0000s0sPath::Tiny::::_parse_file_temp_args Path::Tiny::_parse_file_temp_args
0000s0sPath::Tiny::::_path Path::Tiny::_path
0000s0sPath::Tiny::::_replacment_path Path::Tiny::_replacment_path
0000s0sPath::Tiny::::_resolve_between Path::Tiny::_resolve_between
0000s0sPath::Tiny::::_resolve_symlinks Path::Tiny::_resolve_symlinks
0000s0sPath::Tiny::::_splitpath Path::Tiny::_splitpath
0000s0sPath::Tiny::::_symbolic_chmod Path::Tiny::_symbolic_chmod
0000s0sPath::Tiny::::_throw Path::Tiny::_throw
0000s0sPath::Tiny::::_win32_vol Path::Tiny::_win32_vol
0000s0sPath::Tiny::::absolute Path::Tiny::absolute
0000s0sPath::Tiny::::append Path::Tiny::append
0000s0sPath::Tiny::::append_raw Path::Tiny::append_raw
0000s0sPath::Tiny::::append_utf8 Path::Tiny::append_utf8
0000s0sPath::Tiny::::assert Path::Tiny::assert
0000s0sPath::Tiny::::basename Path::Tiny::basename
0000s0sPath::Tiny::::cached_temp Path::Tiny::cached_temp
0000s0sPath::Tiny::::canonpath Path::Tiny::canonpath
0000s0sPath::Tiny::::child Path::Tiny::child
0000s0sPath::Tiny::::children Path::Tiny::children
0000s0sPath::Tiny::::chmod Path::Tiny::chmod
0000s0sPath::Tiny::::copy Path::Tiny::copy
0000s0sPath::Tiny::::cwd Path::Tiny::cwd
0000s0sPath::Tiny::::digest Path::Tiny::digest
0000s0sPath::Tiny::::dirname Path::Tiny::dirname
0000s0sPath::Tiny::::edit Path::Tiny::edit
0000s0sPath::Tiny::::edit_lines Path::Tiny::edit_lines
0000s0sPath::Tiny::::edit_lines_raw Path::Tiny::edit_lines_raw
0000s0sPath::Tiny::::edit_lines_utf8 Path::Tiny::edit_lines_utf8
0000s0sPath::Tiny::::edit_raw Path::Tiny::edit_raw
0000s0sPath::Tiny::::edit_utf8 Path::Tiny::edit_utf8
0000s0sPath::Tiny::::exists Path::Tiny::exists
0000s0sPath::Tiny::::has_same_bytes Path::Tiny::has_same_bytes
0000s0sPath::Tiny::::is_absolute Path::Tiny::is_absolute
0000s0sPath::Tiny::::is_dir Path::Tiny::is_dir
0000s0sPath::Tiny::::is_file Path::Tiny::is_file
0000s0sPath::Tiny::::is_relative Path::Tiny::is_relative
0000s0sPath::Tiny::::is_rootdir Path::Tiny::is_rootdir
0000s0sPath::Tiny::::iterator Path::Tiny::iterator
0000s0sPath::Tiny::::lines Path::Tiny::lines
0000s0sPath::Tiny::::lines_raw Path::Tiny::lines_raw
0000s0sPath::Tiny::::lines_utf8 Path::Tiny::lines_utf8
0000s0sPath::Tiny::::lstat Path::Tiny::lstat
0000s0sPath::Tiny::::mkdir Path::Tiny::mkdir
0000s0sPath::Tiny::::mkpath Path::Tiny::mkpath
0000s0sPath::Tiny::::move Path::Tiny::move
0000s0sPath::Tiny::::new Path::Tiny::new
0000s0sPath::Tiny::::parent Path::Tiny::parent
0000s0sPath::Tiny::::realpath Path::Tiny::realpath
0000s0sPath::Tiny::::relative Path::Tiny::relative
0000s0sPath::Tiny::::remove Path::Tiny::remove
0000s0sPath::Tiny::::remove_tree Path::Tiny::remove_tree
0000s0sPath::Tiny::::rootdir Path::Tiny::rootdir
0000s0sPath::Tiny::::sibling Path::Tiny::sibling
0000s0sPath::Tiny::::size Path::Tiny::size
0000s0sPath::Tiny::::size_human Path::Tiny::size_human
0000s0sPath::Tiny::::slurp_utf8 Path::Tiny::slurp_utf8
0000s0sPath::Tiny::::spew Path::Tiny::spew
0000s0sPath::Tiny::::spew_raw Path::Tiny::spew_raw
0000s0sPath::Tiny::::spew_utf8 Path::Tiny::spew_utf8
0000s0sPath::Tiny::::stat Path::Tiny::stat
0000s0sPath::Tiny::::stringify Path::Tiny::stringify
0000s0sPath::Tiny::::subsumes Path::Tiny::subsumes
0000s0sPath::Tiny::::tempdir Path::Tiny::tempdir
0000s0sPath::Tiny::::tempfile Path::Tiny::tempfile
0000s0sPath::Tiny::::touch Path::Tiny::touch
0000s0sPath::Tiny::::touchpath Path::Tiny::touchpath
0000s0sPath::Tiny::::visit Path::Tiny::visit
0000s0sPath::Tiny::::volume Path::Tiny::volume
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1253µs129µs
# spent 29µs within JSON::Schema::Modern::BEGIN@1 which was called: # once (29µs+0s) by JSON::Schema::Modern::BEGIN@25 at line 1
use 5.008001;
# spent 29µs making 1 call to JSON::Schema::Modern::BEGIN@1
2241µs215µs
# spent 12µs (9+3) within JSON::Schema::Modern::BEGIN@2 which was called: # once (9µs+3µs) by JSON::Schema::Modern::BEGIN@25 at line 2
use strict;
# spent 12µs making 1 call to JSON::Schema::Modern::BEGIN@2 # spent 3µs making 1 call to strict::import
3240µs264µs
# spent 35µs (6+29) within JSON::Schema::Modern::BEGIN@3 which was called: # once (6µs+29µs) by JSON::Schema::Modern::BEGIN@25 at line 3
use warnings;
# spent 35µs making 1 call to JSON::Schema::Modern::BEGIN@3 # spent 29µs making 1 call to warnings::import
4
5package Path::Tiny;
6# ABSTRACT: File path utility
7
811µsour $VERSION = '0.144';
9
10# Dependencies
11221µs221µs
# spent 14µs (7+7) within Path::Tiny::BEGIN@11 which was called: # once (7µs+7µs) by JSON::Schema::Modern::BEGIN@25 at line 11
use Config;
# spent 14µs making 1 call to Path::Tiny::BEGIN@11 # spent 7µs making 1 call to Config::import
12323µs321µs
# spent 14µs (7+7) within Path::Tiny::BEGIN@12 which was called: # once (7µs+7µs) by JSON::Schema::Modern::BEGIN@25 at line 12
use Exporter 5.57 (qw/import/);
# spent 14µs making 1 call to Path::Tiny::BEGIN@12 # spent 5µs making 1 call to UNIVERSAL::VERSION # spent 2µs making 1 call to Exporter::import
13319µs213µs
# spent 10µs (7+3) within Path::Tiny::BEGIN@13 which was called: # once (7µs+3µs) by JSON::Schema::Modern::BEGIN@25 at line 13
use File::Spec 0.86 (); # shipped with 5.8.1
# spent 10µs making 1 call to Path::Tiny::BEGIN@13 # spent 3µs making 1 call to UNIVERSAL::VERSION
14244µs11µs
# spent 1µs within Path::Tiny::BEGIN@14 which was called: # once (1µs+0s) by JSON::Schema::Modern::BEGIN@25 at line 14
use Carp ();
# spent 1µs making 1 call to Path::Tiny::BEGIN@14
15
1611µsour @EXPORT = qw/path/;
1711µsour @EXPORT_OK = qw/cwd rootdir tempfile tempdir/;
18
19
# spent 83µs (10+73) within Path::Tiny::BEGIN@19 which was called: # once (10µs+73µs) by JSON::Schema::Modern::BEGIN@25 at line 27
use constant {
2010s PATH => 0,
21 CANON => 1,
22 VOL => 2,
23 DIR => 3,
24 FILE => 4,
25 TEMP => 5,
26 IS_WIN32 => ( $^O eq 'MSWin32' ),
27144µs2156µs};
# spent 83µs making 1 call to Path::Tiny::BEGIN@19 # spent 73µs making 1 call to constant::import
28
29
# spent 35µs (8+27) within Path::Tiny::BEGIN@29 which was called: # once (8µs+27µs) by JSON::Schema::Modern::BEGIN@25 at line 33
use overload (
30 q{""} => 'stringify',
31 bool => sub () { 1 },
3210s fallback => 1,
33139µs262µs);
# spent 35µs making 1 call to Path::Tiny::BEGIN@29 # spent 27µs making 1 call to overload::import
34
35# FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol
36sub THAW { return path( $_[2] ) }
374321µs249µs
# spent 27µs (5+22) within Path::Tiny::BEGIN@37 which was called: # once (5µs+22µs) by JSON::Schema::Modern::BEGIN@25 at line 37
{ no warnings 'once'; *TO_JSON = *FREEZE = \&stringify };
# spent 27µs making 1 call to Path::Tiny::BEGIN@37 # spent 22µs making 1 call to warnings::unimport
38
3910smy $HAS_UU; # has Unicode::UTF8; lazily populated
40
41sub _check_UU {
42 local $SIG{__DIE__}; # prevent outer handler from being called
43 !!eval {
44 require Unicode::UTF8;
45 Unicode::UTF8->VERSION(0.58);
46 1;
47 };
48}
49
50my $HAS_PU; # has PerlIO::utf8_strict; lazily populated
51
52sub _check_PU {
53 local $SIG{__DIE__}; # prevent outer handler from being called
54 !!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 require Encode;
58 require PerlIO::utf8_strict;
59 PerlIO::utf8_strict->VERSION(0.003);
60 1;
61 };
62}
63
6417µs12.64msmy $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf};
# spent 2.64ms making 1 call to Config::FETCH
65
66# notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \
6715µs12µsmy $SLASH = qr{[\\/]};
# spent 2µs making 1 call to Path::Tiny::CORE:qr
6812µs10smy $NOTSLASH = qr{[^\\/]};
# spent 0s making 1 call to Path::Tiny::CORE:qr
6912µs11µsmy $DRV_VOL = qr{[a-z]:}i;
# spent 1µs making 1 call to Path::Tiny::CORE:qr
70146µs240µsmy $UNC_VOL = qr{$SLASH $SLASH $NOTSLASH+ $SLASH $NOTSLASH+}x;
# spent 40µs making 1 call to Path::Tiny::CORE:regcomp # spent 0s making 1 call to Path::Tiny::CORE:qr
71173µs267µsmy $WIN32_ROOT = qr{(?: $UNC_VOL $SLASH | $DRV_VOL $SLASH | $SLASH )}x;
# spent 67µs making 1 call to Path::Tiny::CORE:regcomp # spent 0s making 1 call to Path::Tiny::CORE:qr
72
73sub _win32_vol {
74 my ( $path, $drv ) = @_;
75 require Cwd;
76 my $dcwd = eval { Cwd::getdcwd($drv) }; # C: -> C:\some\cwd
77 # getdcwd on non-existent drive returns empty string
78 # so just use the original drive Z: -> Z:
79 $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 $dcwd =~ s{$SLASH?\z}{/};
82 # make the path absolute with dcwd
83 $path =~ s{^$DRV_VOL}{$dcwd};
84 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
# spent 37µs within Path::Tiny::_is_root which was called 28 times, avg 1µs/call: # 14 times (27µs+0s) by Path::Tiny::_pathify at line 282, avg 2µs/call # 14 times (10µs+0s) by Path::Tiny::_pathify at line 294, avg 714ns/call
sub _is_root {
902843µs return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' );
91}
92
93
# spent 4µs within Path::Tiny::BEGIN@93 which was called: # once (4µs+0s) by JSON::Schema::Modern::BEGIN@25 at line 95
BEGIN {
9415µs *_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] };
951215µs14µs}
# spent 4µs making 1 call to Path::Tiny::BEGIN@93
96
97# mode bits encoded for chmod in symbolic mode
9812µsmy %MODEBITS = ( om => 0007, gm => 0070, um => 0700 ); ## no critic
9937µs{ my $m = 0; $MODEBITS{$_} = ( 1 << $m++ ) for qw/ox ow or gx gw gr ux uw ur/ };
100
101sub _symbolic_chmod {
102 my ( $mode, $symbolic ) = @_;
103 for my $clause ( split /,\s*/, $symbolic ) {
104 if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) {
105 my ( $who, $action, $perms ) = ( $1, $2, $3 );
106 $who =~ s/a/ugo/g;
107 for my $w ( split //, $who ) {
108 my $p = 0;
109 $p |= $MODEBITS{"$w$_"} for split //, $perms;
110 if ( $action eq '=' ) {
111 $mode = ( $mode & ~$MODEBITS{"${w}m"} ) | $p;
112 }
113 else {
114 $mode = $action eq "+" ? ( $mode | $p ) : ( $mode & ~$p );
115 }
116 }
117 }
118 else {
119 Carp::croak("Invalid mode clause '$clause' for chmod()");
120 }
121 }
122 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
13124.43ms248µs
# spent 27µs (6+21) within flock::BEGIN@131 which was called: # once (6µs+21µs) by JSON::Schema::Modern::BEGIN@25 at line 131
{ package flock; use warnings::register }
# spent 27µs making 1 call to flock::BEGIN@131 # spent 21µs making 1 call to warnings::register::import
132#>>>
133
13420smy $WARNED_NO_FLOCK = 0;
135
136sub _throw {
137 my ( $self, $function, $file, $msg ) = @_;
138 if ( $function =~ /^flock/
139 && $! =~ /operation not supported|function not implemented/i
140 && !warnings::fatal_enabled('flock') )
141 {
142 if ( !$WARNED_NO_FLOCK ) {
143 warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" );
144 $WARNED_NO_FLOCK++;
145 }
146 }
147 else {
148 $msg = $! unless defined $msg;
149 Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ),
150 $msg );
151 }
152 return;
153}
154
155# cheapo option validation
156
# spent 146µs within Path::Tiny::_get_args which was called 28 times, avg 5µs/call: # 14 times (110µs+0s) by Path::Tiny::slurp at line 2063, avg 8µs/call # 14 times (36µs+0s) by Path::Tiny::filehandle at line 1113, avg 3µs/call
sub _get_args {
1572819µs my ( $raw, @valid ) = @_;
1582817µs if ( defined($raw) && ref($raw) ne 'HASH' ) {
159 my ( undef, undef, undef, $called_as ) = caller(1);
160 $called_as =~ s{^.*::}{};
161 Carp::croak("Options for $called_as must be a hash reference");
162 }
163286µs my $cooked = {};
1642816µs for my $k (@valid) {
1654241µs $cooked->{$k} = delete $raw->{$k} if exists $raw->{$k};
166 }
167288µs if ( keys %$raw ) {
168 my ( undef, undef, undef, $called_as ) = caller(1);
169 $called_as =~ s{^.*::}{};
170 Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) );
171 }
1722849µs 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<Path::Tiny> 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<DEPRECATED>: If and only if the B<first> character of the B<first> argument
195#pod to C<path> is a tilde ('~'), then tilde replacement will be applied to the
196#pod first path segment. A single tilde will be replaced with C<glob('~')> and a
197#pod tilde followed by a username will be replaced with output of
198#pod C<glob('~username')>. B<No other method does tilde expansion on its arguments>.
199#pod See L</Tilde expansion (deprecated)> for more.
200#pod
201#pod On Windows, if the path consists of a drive identifier without a path component
202#pod (C<C:> or C<D:>), it will be expanded to the absolute path of the current
203#pod directory on that volume using C<Cwd::getdcwd()>.
204#pod
205#pod If called with a single C<Path::Tiny> 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
# spent 159µs (147+12) within Path::Tiny::path which was called 14 times, avg 11µs/call: # 8 times (87µs+7µs) by JSON::Schema::Modern::_get_or_load_resource at line 824 of /Users/ether/git/JSON-Schema-Modern/lib/JSON/Schema/Modern.pm, avg 12µs/call # 6 times (60µs+5µs) by JSON::Schema::Modern::Document::OpenAPI::_add_vocab_and_default_schemas at line 204 of JSON/Schema/Modern/Document/OpenAPI.pm, avg 11µs/call
sub path {
223145µs my $path = shift;
224 Carp::croak("Path::Tiny paths require defined, positive-length parts")
2251446µs unless 1 + @_ == grep { defined && length } $path, @_;
226
227 # non-temp Path::Tiny objects are effectively immutable and can be reused
228148µs if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
229 return $path;
230 }
231
232 # stringify objects
233147µs $path = "$path";
234
235 # do any tilde expansions
2361434µs1412µs my ($tilde) = $path =~ m{^(~[^/]*)};
# spent 12µs making 14 calls to Path::Tiny::CORE:match, avg 857ns/call
237144µs if ( defined $tilde ) {
238 # Escape File::Glob metacharacters
239 (my $escaped = $tilde) =~ s/([\[\{\*\?\\])/\\$1/g;
240 require File::Glob;
241 my ($homedir) = File::Glob::bsd_glob($escaped);
242 if (defined $homedir && ! $File::Glob::ERROR) {
243 $homedir =~ tr[\\][/] if IS_WIN32();
244 $path =~ s{^\Q$tilde\E}{$homedir};
245 }
246 }
247
2481413µs unshift @_, $path;
2491469µs14295µs goto &_pathify;
# spent 295µs making 14 calls to Path::Tiny::_pathify, avg 21µs/call
250}
251
252# _path is like path but without tilde expansion
253sub _path {
254 my $path = shift;
255 Carp::croak("Path::Tiny paths require defined, positive-length parts")
256 unless 1 + @_ == grep { defined && length } $path, @_;
257
258 # non-temp Path::Tiny objects are effectively immutable and can be reused
259 if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
260 return $path;
261 }
262
263 # stringify objects
264 $path = "$path";
265
266 unshift @_, $path;
267 goto &_pathify;
268}
269
270# _pathify expects one or more string arguments, then joins and canonicalizes
271# them into an object.
272
# spent 295µs (234+61) within Path::Tiny::_pathify which was called 14 times, avg 21µs/call: # 14 times (234µs+61µs) by JSON::Schema::Modern::Document::OpenAPI::_add_vocab_and_default_schemas or JSON::Schema::Modern::_get_or_load_resource at line 249, avg 21µs/call
sub _pathify {
273144µs my $path = shift;
274
275 # expand relative volume paths on windows; put trailing slash on UNC root
276 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
2821443µs1427µs if (@_) {
# spent 27µs making 14 calls to Path::Tiny::_is_root, avg 2µs/call
283 $path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ );
284 }
285
286
287 # canonicalize, but with unix slashes and put back trailing volume slash
2881479µs1410µs my $cpath = $path = File::Spec->canonpath($path);
# spent 10µs making 14 calls to File::Spec::Unix::canonpath, avg 714ns/call
289 $path =~ tr[\\][/] if IS_WIN32();
290144µs $path = "/" if $path eq '/..'; # for old File::Spec
291 $path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL\z};
292
293 # root paths must always have a trailing slash, but other paths must not
2941420µs1410µs if ( _is_root($path) ) {
# spent 10µs making 14 calls to Path::Tiny::_is_root, avg 714ns/call
295 $path =~ s{/?\z}{/};
296 }
297 else {
2981444µs1414µs $path =~ s{/\z}{};
# spent 14µs making 14 calls to Path::Tiny::CORE:subst, avg 1µs/call
299 }
300
3011474µs 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<path>, 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
315sub new { shift; path(@_) }
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<Path::Tiny> object.
323#pod This is slightly faster than C<< path(".")->absolute >>.
324#pod
325#pod C<cwd> 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
332sub cwd {
333 require Cwd;
334 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<Path::Tiny> object if you're too
343#pod picky for C<path("/")>.
344#pod
345#pod C<rootdir> 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
352sub 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<tempfile> passes the options to C<< File::Temp->new >> and returns a
364#pod C<Path::Tiny> object with the file name. The C<TMPDIR> 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<TEMPLATE> option, you will want to
367#pod disable C<TMPDIR>.)
368#pod
369#pod The resulting C<File::Temp> object is cached. When the C<Path::Tiny> object is
370#pod destroyed, the C<File::Temp> object will be as well.
371#pod
372#pod C<File::Temp> 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<Path::Tiny> lets you ignore that and can take either a leading template or a
375#pod C<TEMPLATE> option and does the right thing.
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<DIR>. If you want it to have
382#pod the C<realpath> instead, pass a leading options hash like this:
383#pod
384#pod $real_temp = tempfile({realpath => 1}, @options);
385#pod
386#pod C<tempdir> is just like C<tempfile>, except it calls
387#pod C<< File::Temp->newdir >> instead.
388#pod
389#pod Both C<tempfile> and C<tempdir> 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<DIR> 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<DIR> is ignored.
402#pod
403#pod B<Note>: 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<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned
407#pod up.
408#pod
409#pod B<Note 2>: 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<Note 3>: 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<Note 4>: The cached object may be accessed with the L</cached_temp> 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
427sub tempfile {
428 my ( $opts, $maybe_template, $args )
429 = _parse_file_temp_args(tempfile => @_);
430
431 # File::Temp->new demands TEMPLATE
432 $args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template;
433
434 require File::Temp;
435 my $temp = File::Temp->new( TMPDIR => 1, %$args );
436 close $temp;
437 my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
438 $self->[TEMP] = $temp; # keep object alive while we are
439 return $self;
440}
441
442sub tempdir {
443 my ( $opts, $maybe_template, $args )
444 = _parse_file_temp_args(tempdir => @_);
445
446 require File::Temp;
447 my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args );
448 my $self = $opts->{realpath} ? _path($temp)->realpath : _path($temp)->absolute;
449 $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 $temp->{REALNAME} = $self->[CANON] if IS_WIN32;
454 return $self;
455}
456
457# normalize the various ways File::Temp does templates
458sub _parse_file_temp_args {
459 my $called_as = shift;
460 if ( @_ && $_[0] eq 'Path::Tiny' ) { shift } # class method
461 elsif ( @_ && eval{$_[0]->isa('Path::Tiny')} ) {
462 my $dir = shift;
463 if (! $dir->is_dir) {
464 $dir->_throw( $called_as, $dir, "is not a directory object" );
465 }
466 push @_, DIR => $dir->stringify; # no overriding
467 }
468 my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
469 $opts = _get_args( $opts, qw/realpath/ );
470
471 my $leading_template = ( scalar(@_) % 2 == 1 ? shift(@_) : '' );
472 my %args = @_;
473 %args = map { uc($_), $args{$_} } keys %args;
474 my @template = (
475 exists $args{TEMPLATE} ? delete $args{TEMPLATE}
476 : $leading_template ? $leading_template
477 : ()
478 );
479
480 return ( $opts, \@template, \%args );
481}
482
483#--------------------------------------------------------------------------#
484# Private methods
485#--------------------------------------------------------------------------#
486
487sub _splitpath {
488 my ($self) = @_;
489 @{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] );
490}
491
492sub _resolve_symlinks {
493 my ($self) = @_;
494 my $new = $self;
495 my ( $count, %seen ) = 0;
496 while ( -l $new->[PATH] ) {
497 if ( $seen{ $new->[PATH] }++ ) {
498 $self->_throw( 'readlink', $self->[PATH], "symlink loop detected" );
499 }
500 if ( ++$count > 100 ) {
501 $self->_throw( 'readlink', $self->[PATH], "maximum symlink depth exceeded" );
502 }
503 my $resolved = readlink $new->[PATH];
504 $new->_throw( 'readlink', $new->[PATH] ) unless defined $resolved;
505 $resolved = _path($resolved);
506 $new = $resolved->is_absolute ? $resolved : $new->sibling($resolved);
507 }
508 return $new;
509}
510
511sub _replacment_path {
512 my ($self) = @_;
513
514 my $unique_suffix = $$ . int( rand( 2**31 ) );
515 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 if ( length $temp->basename > 255 ) {
520 $temp = $self->sibling( "temp" . $unique_suffix );
521 }
522
523 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<Path::Tiny> 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<canonpath>
541#pod in L<File::Spec> would normally do so on your platform. If you need them
542#pod resolved, you must call the more expensive C<realpath> 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
551sub absolute {
552 my ( $self, $base ) = @_;
553
554 # absolute paths handled differently by OS
555 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 return $self if $self->is_absolute;
568 }
569
570 # no base means use current directory as base
571 require Cwd;
572 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 $base = _path($base);
578 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<flock> 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<binmode>: passed to C<binmode()> on the handle used for writing.
595#pod * C<truncate>: truncates the file after locking and before appending
596#pod
597#pod The C<truncate> option is a way to replace the contents of a file
598#pod B<in place>, unlike L</spew> which writes to a temporary file and then
599#pod replaces the original (if it exists).
600#pod
601#pod C<append_raw> is like C<append> with a C<binmode> of C<:unix> for a fast,
602#pod unbuffered, raw write.
603#pod
604#pod C<append_utf8> is like C<append> with an unbuffered C<binmode>
605#pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
606#pod L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, an
607#pod unbuffered, raw append will be done instead on the data encoded with
608#pod C<Unicode::UTF8>.
609#pod
610#pod Current API available since 0.060.
611#pod
612#pod =cut
613
614sub append {
615 my ( $self, @data ) = @_;
616 my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
617 $args = _get_args( $args, qw/binmode truncate/ );
618 my $binmode = $args->{binmode};
619 $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
620 my $mode = $args->{truncate} ? ">" : ">>";
621 my $fh = $self->filehandle( { locked => 1 }, $mode, $binmode );
622 print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data ) or self->_throw('print');
623 close $fh or $self->_throw('close');
624}
625
626sub append_raw {
627 my ( $self, @data ) = @_;
628 my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
629 $args = _get_args( $args, qw/binmode truncate/ );
630 $args->{binmode} = ':unix';
631 append( $self, $args, @data );
632}
633
634sub append_utf8 {
635 my ( $self, @data ) = @_;
636 my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
637 $args = _get_args( $args, qw/binmode truncate/ );
638 if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
639 $args->{binmode} = ":unix";
640 append( $self, $args, map { Unicode::UTF8::encode_utf8($_) } @data );
641 }
642 elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
643 $args->{binmode} = ":unix:utf8_strict";
644 append( $self, $args, @data );
645 }
646 else {
647 $args->{binmode} = ":unix:encoding(UTF-8)";
648 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
667sub assert {
668 my ( $self, $assertion ) = @_;
669 return $self unless $assertion;
670 if ( ref $assertion eq 'CODE' ) {
671 local $_ = $self;
672 $assertion->()
673 or Path::Tiny::Error->throw( "assert", $self->[PATH], "failed assertion" );
674 }
675 else {
676 Carp::croak("argument to assert must be a code reference argument");
677 }
678 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
698sub basename {
699 my ( $self, @suffixes ) = @_;
700 $self->_splitpath unless defined $self->[FILE];
701 my $file = $self->[FILE];
702 for my $s (@suffixes) {
703 my $re = ref($s) eq 'Regexp' ? qr/$s\z/ : qr/\Q$s\E\z/;
704 last if $file =~ s/$re//;
705 }
706 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
721sub canonpath { $_[0]->[CANON] }
722
723#pod =method cached_temp
724#pod
725#pod Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the
726#pod C<Path::Tiny> object was created with C</tempfile> or C</tempdir>.
727#pod If there is no such object, this method throws.
728#pod
729#pod B<WARNING>: 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<Path::Tiny> 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
737sub cached_temp {
738 my $self = shift;
739 $self->_throw( "cached_temp", $self, "has no cached File::Temp object" )
740 unless defined $self->[TEMP];
741 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<Path::Tiny> object relative to the original. Works
750#pod like C<catfile> or C<catdir> from File::Spec, but without caring about
751#pod file or directories.
752#pod
753#pod B<WARNING>: 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</realpath> and check them with L</subsumes>.
757#pod
758#pod Current API available since 0.001.
759#pod
760#pod =cut
761
762sub child {
763 my ( $self, @parts ) = @_;
764 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<Path::Tiny> objects for all files and directories
773#pod within a directory. Excludes "." and ".." automatically.
774#pod
775#pod If an optional C<qr//> 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
786sub children {
787 my ( $self, $filter ) = @_;
788 my $dh;
789 opendir $dh, $self->[PATH] or $self->_throw('opendir');
790 my @children = readdir $dh;
791 closedir $dh or $self->_throw('closedir');
792
793 if ( not defined $filter ) {
794 @children = grep { $_ ne '.' && $_ ne '..' } @children;
795 }
796 elsif ( $filter && ref($filter) eq 'Regexp' ) {
797 @children = grep { $_ ne '.' && $_ ne '..' && $_ =~ $filter } @children;
798 }
799 else {
800 Carp::croak("Invalid argument '$filter' for children()");
801 }
802
803 return map { _path( $self->[PATH], $_ ) } @children;
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</bin/chmod>.
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</bin/chmod>, all three parameters
820#pod are required for each clause, multiple ops are not allowed and permissions
821#pod C<stugoX> are not supported. (See L<File::chmod> for more complex needs.)
822#pod
823#pod Current API available since 0.053.
824#pod
825#pod =cut
826
827sub chmod {
828 my ( $self, $new_mode ) = @_;
829
830 my $mode;
831 if ( $new_mode =~ /\d/ ) {
832 $mode = ( $new_mode =~ /^0/ ? oct($new_mode) : $new_mode );
833 }
834 elsif ( $new_mode =~ /[=+-]/ ) {
835 $mode = _symbolic_chmod( $self->stat->mode & 07777, $new_mode ); ## no critic
836 }
837 else {
838 Carp::croak("Invalid mode argument '$new_mode' for chmod()");
839 }
840
841 CORE::chmod( $mode, $self->[PATH] ) or $self->_throw("chmod");
842
843 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<File::Copy>'s
851#pod C<copy> function. Upon success, returns the C<Path::Tiny> 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?
859sub copy {
860 my ( $self, $dest ) = @_;
861 require File::Copy;
862 File::Copy::copy( $self->[PATH], $dest )
863 or Carp::croak("copy failed for $self to $dest: $!");
864
865 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<chunk_size>. If C<chunk_size> 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<Digest> 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
886sub digest {
887 my ( $self, @opts ) = @_;
888 my $args = ( @opts && ref $opts[0] eq 'HASH' ) ? shift @opts : {};
889 $args = _get_args( $args, qw/chunk_size/ );
890 unshift @opts, 'SHA-256' unless @opts;
891 require Digest;
892 my $digest = Digest->new(@opts);
893 if ( $args->{chunk_size} ) {
894 my $fh = $self->filehandle( { locked => 1 }, "<", ":unix" );
895 my $buf;
896 while (!eof($fh)) {
897 my $rc = read $fh, $buf, $args->{chunk_size};
898 $self->_throw('read') unless defined $rc;
899 $digest->add($buf);
900 }
901 }
902 else {
903 $digest->add( $self->slurp_raw );
904 }
905 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<File::Spec> is inconsistent, the result
915#pod might or might not have a trailing slash. Because of this, this method is
916#pod B<deprecated>.
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
925sub dirname {
926 my ($self) = @_;
927 $self->_splitpath unless defined $self->[DIR];
928 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<slurp>, 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<spew>.
942#pod
943#pod An optional hash reference may be used to pass options. The only option is
944#pod C<binmode>, which is passed to C<slurp> and C<spew>.
945#pod
946#pod C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and
947#pod C<spew_*> methods.
948#pod
949#pod Current API available since 0.077.
950#pod
951#pod =cut
952
953sub edit {
954 my $self = shift;
955 my $cb = shift;
956 my $args = _get_args( shift, qw/binmode/ );
957 Carp::croak("Callback for edit() must be a code reference")
958 unless defined($cb) && ref($cb) eq 'CODE';
959
960 local $_ =
961 $self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () );
962 $cb->();
963 $self->spew( $args, $_ );
964
965 return;
966}
967
968# this is done long-hand to benefit from slurp_utf8 optimizations
969sub edit_utf8 {
970 my ( $self, $cb ) = @_;
971 Carp::croak("Callback for edit_utf8() must be a code reference")
972 unless defined($cb) && ref($cb) eq 'CODE';
973
974 local $_ = $self->slurp_utf8;
975 $cb->();
976 $self->spew_utf8($_);
977
978 return;
979}
980
981sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit }
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<binmode>, which is passed to the method that open handles for reading and
998#pod writing.
999#pod
1000#pod C<edit_lines_raw> is like C<edit_lines> with a buffered C<binmode> of
1001#pod C<:raw>.
1002#pod
1003#pod C<edit_lines_utf8> is like C<edit_lines> with a buffered C<binmode>
1004#pod C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with
1005#pod L<PerlIO::utf8_strict>).
1006#pod
1007#pod Current API available since 0.077.
1008#pod
1009#pod =cut
1010
1011sub edit_lines {
1012 my $self = shift;
1013 my $cb = shift;
1014 my $args = _get_args( shift, qw/binmode/ );
1015 Carp::croak("Callback for edit_lines() must be a code reference")
1016 unless defined($cb) && ref($cb) eq 'CODE';
1017
1018 my $binmode = $args->{binmode};
1019 # get default binmode from caller's lexical scope (see "perldoc open")
1020 $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 my $resolved_path = $self->_resolve_symlinks;
1025 my $temp = $resolved_path->_replacment_path;
1026
1027 my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
1028 my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode );
1029
1030 local $_;
1031 while (! eof($in_fh) ) {
1032 defined( $_ = readline($in_fh) ) or $self->_throw('readline');
1033 $cb->();
1034 $temp_fh->print($_) or self->_throw('print', $temp);
1035 }
1036
1037 close $temp_fh or $self->_throw( 'close', $temp );
1038 close $in_fh or $self->_throw('close');
1039
1040 return $temp->move($resolved_path);
1041}
1042
1043sub edit_lines_raw { $_[2] = { binmode => ":raw" }; goto &edit_lines }
1044
1045sub edit_lines_utf8 {
1046 if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
1047 $_[2] = { binmode => ":raw:utf8_strict" };
1048 }
1049 else {
1050 $_[2] = { binmode => ":raw:encoding(UTF-8)" };
1051 }
1052 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<Note>: C<is_file> 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
1074sub exists { -e $_[0]->[PATH] }
1075
1076sub is_file { -e $_[0]->[PATH] && !-d _ }
1077
1078sub 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<open> call.
1089#pod
1090#pod An optional hash reference may be used to pass options.
1091#pod
1092#pod The C<locked> option governs file locking; if true, handles opened for writing,
1093#pod appending or read-write are locked with C<LOCK_EX>; otherwise, they are
1094#pod locked with C<LOCK_SH>. When using C<locked>, ">" or "+>" modes will delay
1095#pod truncation until after the lock is acquired.
1096#pod
1097#pod The C<exclusive> 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<exclusive> implies C<locked> and will set it for you if you forget it.
1100#pod
1101#pod See C<openr>, C<openw>, C<openrw>, and C<opena> 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
# spent 4.38ms (483µs+3.90) within Path::Tiny::filehandle which was called 14 times, avg 313µs/call: # 14 times (483µs+3.90ms) by Path::Tiny::slurp at line 2066, avg 313µs/call
sub filehandle {
11111411µs my ( $self, @args ) = @_;
11121411µs my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
11131414µs1436µs $args = _get_args( $args, qw/locked exclusive/ );
# spent 36µs making 14 calls to Path::Tiny::_get_args, avg 3µs/call
11141434µs $args->{locked} = 1 if $args->{exclusive};
1115144µs my ( $opentype, $binmode ) = @args;
1116
1117149µs $opentype = "<" unless defined $opentype;
1118 Carp::croak("Invalid file mode '$opentype'")
11191444µs unless grep { $opentype eq $_ } qw/< +< > +> >> +>>/;
1120
1121146µs $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $opentype, -1, 1 ) }
1122 unless defined $binmode;
1123142µs $binmode = "" unless defined $binmode;
1124
1125148µs my ( $fh, $lock, $trunc );
11261413µs if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) {
11271415µs require Fcntl;
1128 # truncating file modes shouldn't truncate until lock acquired
11291473µs if ( grep { $opentype eq $_ } qw( > +> ) ) {
1130 # sysopen in write mode without truncation
1131 my $flags = $opentype eq ">" ? Fcntl::O_WRONLY() : Fcntl::O_RDWR();
1132 $flags |= Fcntl::O_CREAT();
1133 $flags |= Fcntl::O_EXCL() if $args->{exclusive};
1134 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 if ( $binmode =~ s/^:unix// ) {
1139 # eliminate pseudo-layers
1140 binmode( $fh, ":raw" ) or $self->_throw("binmode (:raw)");
1141 # strip off real layers until only :unix is left
1142 while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
1143 binmode( $fh, ":pop" ) or $self->_throw("binmode (:pop)");
1144 }
1145 }
1146
1147 # apply any remaining binmode layers
1148 if ( length $binmode ) {
1149 binmode( $fh, $binmode ) or $self->_throw("binmode ($binmode)");
1150 }
1151
1152 # ask for lock and truncation
1153 $lock = Fcntl::LOCK_EX();
1154 $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 if ( -w $self->[PATH] ) {
1162 $opentype = "+<";
1163 $lock = Fcntl::LOCK_EX();
1164 }
1165 }
1166 else {
1167148µs $lock = $opentype eq "<" ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX();
1168 }
1169 }
1170
1171148µs unless ($fh) {
1172144µs my $mode = $opentype . $binmode;
1173143.86ms143.73ms open $fh, $mode, $self->[PATH] or $self->_throw("open ($mode)");
# spent 3.73ms making 14 calls to Path::Tiny::CORE:open, avg 267µs/call
1174 }
1175
117614177µs14134µs do { flock( $fh, $lock ) or $self->_throw("flock ($lock)") } if $lock;
# spent 134µs making 14 calls to Path::Tiny::CORE:flock, avg 10µs/call
1177145µs do { truncate( $fh, 0 ) or $self->_throw("truncate") } if $trunc;
1178
11791454µs 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<realpath>, 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
1199sub has_same_bytes {
1200 my ($self, $other_path) = @_;
1201 my $other = _path($other_path);
1202
1203 my $fh1 = $self->openr_raw({ locked => 1 });
1204 my $fh2 = $other->openr_raw({ locked => 1 });
1205
1206 # check for directories
1207 if (-d $fh1) {
1208 $self->_throw('has_same_bytes', $self->[PATH], "directory not allowed");
1209 }
1210 if (-d $fh2) {
1211 $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 if ($self->realpath eq $other->realpath) {
1217 return 1
1218 }
1219
1220 # result is 0 for equal, 1 for unequal, -1 for error
1221 require File::Compare;
1222 my $res = File::Compare::compare($fh1, $fh2, 65536);
1223 if ($res < 0) {
1224 $self->_throw('has_same_bytes')
1225 }
1226
1227 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
1241sub is_absolute { substr( $_[0]->dirname, 0, 1 ) eq '/' }
1242
1243sub 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<dirname> is C<q[/]> and the C<basename> is C<q[]>.
1254#pod
1255#pod This works even on C<MSWin32> 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
1264sub is_rootdir {
1265 my ($self) = @_;
1266 $self->_splitpath unless defined $self->[DIR];
1267 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<Path::Tiny> 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<recurse> option is true, the iterator will walk the directory
1286#pod recursively, breadth-first. If the C<follow_symlinks> 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<Path::Iterator::Rule>.
1300#pod
1301#pod See also L</visit>.
1302#pod
1303#pod Current API available since 0.016.
1304#pod
1305#pod =cut
1306
1307sub iterator {
1308 my $self = shift;
1309 my $args = _get_args( shift, qw/recurse follow_symlinks/ );
1310 my @dirs = $self;
1311 my $current;
1312 return sub {
1313 my $next;
1314 while (@dirs) {
1315 if ( ref $dirs[0] eq 'Path::Tiny' ) {
1316 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 shift @dirs and next;
1324 }
1325 $current = $dirs[0];
1326 my $dh;
1327 opendir( $dh, $current->[PATH] )
1328 or $self->_throw( 'opendir', $current->[PATH] );
1329 $dirs[0] = $dh;
1330 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 shift @dirs and next;
1336 }
1337 }
1338 while ( defined( $next = readdir $dirs[0] ) ) {
1339 next if $next eq '.' || $next eq '..';
1340 my $path = $current->child($next);
1341 push @dirs, $path
1342 if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path );
1343 return $path;
1344 }
1345 shift @dirs;
1346 }
1347 return;
1348 };
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<binmode>, C<count> and C<chomp>.
1362#pod
1363#pod If C<binmode> is provided, it will be set on the handle prior to reading.
1364#pod
1365#pod If a positive C<count> is provided, that many lines will be returned from the
1366#pod start of the file. If a negative C<count> is provided, the entire file will be
1367#pod read, but only C<abs(count)> will be kept and returned. If C<abs(count)>
1368#pod exceeds the number of lines in the file, all lines will be returned.
1369#pod
1370#pod If C<chomp> is set, any end-of-line character sequences (C<CR>, C<CRLF>, or
1371#pod C<LF>) will be removed from the lines returned.
1372#pod
1373#pod Because the return is a list, C<lines> 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<lines_raw> is like C<lines> with a C<binmode> 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<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)>
1382#pod (or C<:raw:utf8_strict> with L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
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<openr_utf8> and iterating directly on the handle.
1387#pod
1388#pod Current API available since 0.065.
1389#pod
1390#pod =cut
1391
1392sub lines {
1393 my $self = shift;
1394 my $args = _get_args( shift, qw/binmode chomp count/ );
1395 my $binmode = $args->{binmode};
1396 $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode;
1397 my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
1398 my $chomp = $args->{chomp};
1399 # XXX more efficient to read @lines then chomp(@lines) vs map?
1400 if ( $args->{count} ) {
1401 my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) );
1402 my $line;
1403 while ( !eof($fh) ) {
1404 defined( $line = readline($fh) ) or $self->_throw('readline');
1405
1406 $line =~ s/(?:\x{0d}?\x{0a}|\x{0d})\z// if $chomp;
1407 $result[ $counter++ ] = $line;
1408 # for positive count, terminate after right number of lines
1409 last if $counter == $args->{count};
1410 # for negative count, eventually wrap around in the result array
1411 $counter %= $mod;
1412 }
1413 # reorder results if full and wrapped somewhere in the middle
1414 splice( @result, 0, 0, splice( @result, $counter ) )
1415 if @result == $mod && $counter % $mod;
1416 return @result;
1417 }
1418 elsif ($chomp) {
1419 local $!;
1420 my @lines = map { s/(?:\x{0d}?\x{0a}|\x{0d})\z//; $_ } <$fh>; ## no critic
1421 $self->_throw('readline') if $!;
1422 return @lines;
1423 }
1424 else {
1425 if ( wantarray ) {
1426 local $!;
1427 my @lines = <$fh>;
1428 $self->_throw('readline') if $!;
1429 return @lines;
1430 } else {
1431 local $!;
1432 my $count =()= <$fh>;
1433 $self->_throw('readline') if $!;
1434 return $count;
1435 }
1436 }
1437}
1438
1439sub lines_raw {
1440 my $self = shift;
1441 my $args = _get_args( shift, qw/binmode chomp count/ );
1442 if ( $args->{chomp} && !$args->{count} ) {
1443 return split /\n/, slurp_raw($self); ## no critic
1444 }
1445 else {
1446 $args->{binmode} = ":raw";
1447 return lines( $self, $args );
1448 }
1449}
1450
145113µs11µsmy $CRLF = qr/(?:\x{0d}?\x{0a}|\x{0d})/;
# spent 1µs making 1 call to Path::Tiny::CORE:qr
1452
1453sub lines_utf8 {
1454 my $self = shift;
1455 my $args = _get_args( shift, qw/binmode chomp count/ );
1456 if ( ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) )
1457 && $args->{chomp}
1458 && !$args->{count} )
1459 {
1460 my $slurp = slurp_utf8($self);
1461 $slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF|CR
1462 return split $CRLF, $slurp, -1; ## no critic
1463 }
1464 elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
1465 $args->{binmode} = ":raw:utf8_strict";
1466 return lines( $self, $args );
1467 }
1468 else {
1469 $args->{binmode} = ":raw:encoding(UTF-8)";
1470 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<make_path> from L<File::Path>. An optional hash reference
1480#pod is passed through to C<make_path>. Errors will be trapped and an exception
1481#pod thrown. Returns the the path object to facilitate chaining.
1482#pod
1483#pod B<NOTE>: unlike Perl's builtin C<mkdir>, this will create intermediate paths
1484#pod similar to the Unix C<mkdir -p> 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
1491sub mkdir {
1492 my ( $self, $args ) = @_;
1493 $args = {} unless ref $args eq 'HASH';
1494 my $err;
1495 $args->{error} = \$err unless defined $args->{error};
1496 require File::Path;
1497 my @dirs;
1498 my $ok = eval {
1499 File::Path::make_path( $self->[PATH], $args );
1500 1;
1501 };
1502 if (!$ok) {
1503 $self->_throw('mkdir', $self->[PATH], "error creating path: $@");
1504 }
1505 if ( $err && @$err ) {
1506 my ( $file, $message ) = %{ $err->[0] };
1507 $self->_throw('mkdir', $file, $message);
1508 }
1509 return $self;
1510}
1511
1512#pod =method mkpath (deprecated)
1513#pod
1514#pod Like calling C<mkdir>, but returns the list of directories created or an empty list if
1515#pod the directories already exist, just like C<make_path>.
1516#pod
1517#pod Deprecated in 0.125.
1518#pod
1519#pod =cut
1520
1521sub mkpath {
1522 my ( $self, $args ) = @_;
1523 $args = {} unless ref $args eq 'HASH';
1524 my $err;
1525 $args->{error} = \$err unless defined $args->{error};
1526 require File::Path;
1527 my @dirs = File::Path::make_path( $self->[PATH], $args );
1528 if ( $err && @$err ) {
1529 my ( $file, $message ) = %{ $err->[0] };
1530 Carp::croak("mkpath failed for $file: $message");
1531 }
1532 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<File::Copy>'s
1540#pod C<move> function. Upon success, returns the C<Path::Tiny> 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<rename|perlfunc/rename> function
1555#pod and did not return an object.
1556#pod
1557#pod =cut
1558
1559sub move {
1560 my ( $self, $dest ) = @_;
1561 require File::Copy;
1562 File::Copy::move( $self->[PATH], $dest )
1563 or $self->_throw( 'move', $self->[PATH] . "' -> '$dest" );
1564
1565 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<openr> style methods
1587#pod take a single C<binmode> argument. All of the C<open*> methods have
1588#pod C<open*_raw> and C<open*_utf8> 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<PerlIO::utf8_strict>).
1591#pod
1592#pod An optional hash reference may be used to pass options. The only option is
1593#pod C<locked>. If true, handles opened for writing, appending or read-write are
1594#pod locked with C<LOCK_EX>; otherwise, they are locked for C<LOCK_SH>.
1595#pod
1596#pod $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );
1597#pod
1598#pod See L</filehandle> 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
160513µsmy %opens = (
1606 opena => ">>",
1607 openr => "<",
1608 openw => ">",
1609 openrw => "+<"
1610);
1611
161214µswhile ( my ( $k, $v ) = each %opens ) {
161323.11ms233µs
# spent 23µs (13+10) within Path::Tiny::BEGIN@1613 which was called: # once (13µs+10µs) by JSON::Schema::Modern::BEGIN@25 at line 1613
no strict 'refs';
# spent 23µs making 1 call to Path::Tiny::BEGIN@1613 # spent 10µs making 1 call to strict::unimport
1614 # must check for lexical IO mode hint
1615 *{$k} = sub {
1616 my ( $self, @args ) = @_;
1617 my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1618 $args = _get_args( $args, qw/locked/ );
1619 my ($binmode) = @args;
1620 $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $v, -1, 1 ) }
1621 unless defined $binmode;
1622 $self->filehandle( $args, $v, $binmode );
162346µs };
1624 *{ $k . "_raw" } = sub {
1625 my ( $self, @args ) = @_;
1626 my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1627 $args = _get_args( $args, qw/locked/ );
1628 $self->filehandle( $args, $v, ":raw" );
162947µs };
1630 *{ $k . "_utf8" } = sub {
1631 my ( $self, @args ) = @_;
1632 my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
1633 $args = _get_args( $args, qw/locked/ );
1634 my $layer;
1635 if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
1636 $layer = ":raw:utf8_strict";
1637 }
1638 else {
1639 $layer = ":raw:encoding(UTF-8)";
1640 }
1641 $self->filehandle( $args, $v, $layer );
164247µs };
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<Path::Tiny> 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<parent> by itself is equivalent to
1655#pod C<parent(1)>.
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
1663sub parent {
1664 my ( $self, $level ) = @_;
1665 $level = 1 unless defined $level && $level > 0;
1666 $self->_splitpath unless defined $self->[FILE];
1667 my $parent;
1668 if ( length $self->[FILE] ) {
1669 if ( $self->[FILE] eq '.' || $self->[FILE] eq ".." ) {
1670 $parent = _path( $self->[PATH] . "/.." );
1671 }
1672 else {
1673 $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 if ( $self->[DIR] =~ m{(?:^\.\./|/\.\./|/\.\.\z)} ) {
1680 $parent = _path( $self->[VOL] . $self->[DIR] . "/.." );
1681 }
1682 else {
1683 ( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/};
1684 $parent = _path( $self->[VOL] . $dir );
1685 }
1686 }
1687 else {
1688 $parent = _path( _non_empty( $self->[VOL] ) );
1689 }
1690 return $level == 1 ? $parent : $parent->parent( $level - 1 );
1691}
1692
1693sub _non_empty {
1694 my ($string) = shift;
1695 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<Path::Tiny> object with all symbolic links and upward directory
1704#pod parts resolved using L<Cwd>'s C<realpath>. Compared to C<absolute>, 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<Cwd> 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
1728sub realpath {
1729 my $self = shift;
1730 $self = $self->_resolve_symlinks;
1731 require Cwd;
1732 $self->_splitpath if !defined $self->[FILE];
1733 my $check_parent =
1734 length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..';
1735 my $realpath = eval {
1736 # pure-perl Cwd can carp
1737 local $SIG{__WARN__} = sub { };
1738 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 $self->_throw("resolving realpath")
1742 unless defined $realpath && length $realpath && -e $realpath;
1743 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<Path::Tiny> 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<File::Spec::abs2rel>, 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
1789sub relative {
1790 my ( $self, $base ) = @_;
1791 $base = _path( defined $base && length $base ? $base : '.' );
1792
1793 # relative paths must be converted to absolute first
1794 $self = $self->absolute if $self->is_relative;
1795 $base = $base->absolute if $base->is_relative;
1796
1797 # normalize volumes if they exist
1798 $self = $self->absolute if !length $self->volume && length $base->volume;
1799 $base = $base->absolute if length $self->volume && !length $base->volume;
1800
1801 # can't make paths relative across volumes
1802 if ( !_same( $self->volume, $base->volume ) ) {
1803 Carp::croak("relative() can't cross volumes: '$self' vs '$base'");
1804 }
1805
1806 # if same absolute path, relative is current directory
1807 return _path(".") if _same( $self->[PATH], $base->[PATH] );
1808
1809 # if base is a prefix of self, chop prefix off self
1810 if ( $base->subsumes($self) ) {
1811 $base = "" if $base->is_rootdir;
1812 my $relative = "$self";
1813 $relative =~ s{\A\Q$base/}{};
1814 return _path(".", $relative);
1815 }
1816
1817 # base is not a prefix, so must find a common prefix (even if root)
1818 my ( @common, @self_parts, @base_parts );
1819 @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 if ( $self->is_rootdir ) {
1824 @common = ("");
1825 shift @base_parts;
1826 }
1827 else {
1828 @self_parts = split /\//, $self->_just_filepath;
1829
1830 while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) {
1831 push @common, shift @base_parts;
1832 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 if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) {
1842 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 my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts );
1848 return _path(@new_path);
1849}
1850
1851sub _just_filepath {
1852 my $self = shift;
1853 my $self_vol = $self->volume;
1854 return "$self" if !length $self_vol;
1855
1856 ( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{};
1857
1858 return $self_path;
1859}
1860
1861sub _resolve_between {
1862 my ( $self, $common, $base ) = @_;
1863 my $path = $self->volume . join( "/", @$common );
1864 my $changed = 0;
1865 for my $p (@$base) {
1866 $path .= "/$p";
1867 if ( $p eq '..' ) {
1868 $changed = 1;
1869 if ( -e $path ) {
1870 $path = _path($path)->realpath->[PATH];
1871 }
1872 else {
1873 $path =~ s{/[^/]+/..\z}{/};
1874 }
1875 }
1876 if ( -l $path ) {
1877 $changed = 1;
1878 $path = _path($path)->realpath->[PATH];
1879 }
1880 }
1881 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<unlink>, 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
1896sub remove {
1897 my $self = shift;
1898
1899 return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1900
1901 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<remove_tree> from L<File::Path>, but defaults to C<safe> mode.
1912#pod An optional hash reference is passed through to C<remove_tree>. Errors will be
1913#pod trapped and an exception thrown. Returns the number of directories deleted,
1914#pod just like C<remove_tree>.
1915#pod
1916#pod If you want to remove a directory only if it is empty, use the built-in
1917#pod C<rmdir> 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
1925sub remove_tree {
1926 my ( $self, $args ) = @_;
1927 return 0 if !-e $self->[PATH] && !-l $self->[PATH];
1928 $args = {} unless ref $args eq 'HASH';
1929 my $err;
1930 $args->{error} = \$err unless defined $args->{error};
1931 $args->{safe} = 1 unless defined $args->{safe};
1932 require File::Path;
1933 my $count = File::Path::remove_tree( $self->[PATH], $args );
1934
1935 if ( $err && @$err ) {
1936 my ( $file, $message ) = %{ $err->[0] };
1937 Carp::croak("remove_tree failed for $file: $message");
1938 }
1939 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<Path::Tiny> 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
1955sub sibling {
1956 my $self = shift;
1957 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<size> method is just a wrapper around C<-s>.
1969#pod
1970#pod The C<size_human> method provides a human-readable string similar to
1971#pod C<ls -lh>. Like C<ls>, 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<format>, which has three valid values:
1974#pod
1975#pod =for :list
1976#pod * 'ls' (the default): base-2 sizes, with C<ls> 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<undef>, C<size_human> returns the empty string.
1981#pod
1982#pod Current API available since 0.122.
1983#pod
1984#pod =cut
1985
1986sub size { -s $_[0]->[PATH] }
1987
1988my %formats = (
1989 'ls' => [ 1024, log(1024), [ "", map { " $_" } qw/K M G T/ ] ],
1990 'iec' => [ 1024, log(1024), [ "", map { " $_" } qw/KiB MiB GiB TiB/ ] ],
199119µs 'si' => [ 1000, log(1000), [ "", map { " $_" } qw/kB MB GB TB/ ] ],
1992);
1993
1994sub _formats { return $formats{$_[0]} }
1995
1996sub size_human {
1997 my $self = shift;
1998 my $args = _get_args( shift, qw/format/ );
1999 my $format = defined $args->{format} ? $args->{format} : "ls";
2000 my $fmt_opts = $formats{$format}
2001 or Carp::croak("Invalid format '$format' for size_human()");
2002 my $size = -s $self->[PATH];
2003 return defined $size ? _human_size( $size, @$fmt_opts ) : "";
2004}
2005
2006sub _ceil {
2007 return $_[0] == int($_[0]) ? $_[0] : int($_[0]+1);
2008}
2009
2010sub _human_size {
2011 my ( $size, $base, $log_base, $suffixes ) = @_;
2012 return "0" if $size == 0;
2013
2014 my $mag = int( log($size) / $log_base );
2015 $size /= $base**$mag;
2016 $size =
2017 $mag == 0 ? $size
2018 : length( int($size) ) == 1 ? _ceil( $size * 10 ) / 10
2019 : _ceil($size);
2020 if ( $size >= $base ) {
2021 $size /= $base;
2022 $mag++;
2023 }
2024
2025 my $fmt = ( $mag == 0 || length( int($size) ) > 1 ) ? "%.0f%s" : "%.1f%s";
2026 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<binmode>, which is
2038#pod passed to C<binmode()> on the handle used for reading.
2039#pod
2040#pod C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for
2041#pod a fast, unbuffered, raw read.
2042#pod
2043#pod C<slurp_utf8> is like C<slurp> with a C<binmode> of
2044#pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with
2045#pod L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a
2046#pod unbuffered, raw slurp will be done instead and the result decoded with
2047#pod C<Unicode::UTF8>. 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<Note>: C<slurp> and friends lock the filehandle before slurping. If
2051#pod you plan to slurp from a file created with L<File::Temp>, 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
# spent 9.55ms (1.06+8.49) within Path::Tiny::slurp which was called 14 times, avg 682µs/call: # 14 times (1.06ms+8.49ms) by JSON::Schema::Modern::Document::OpenAPI::_add_vocab_and_default_schemas or JSON::Schema::Modern::_get_or_load_resource at line 2083, avg 682µs/call
sub slurp {
2062145µs my $self = shift;
20631434µs14110µs my $args = _get_args( shift, qw/binmode/ );
# spent 110µs making 14 calls to Path::Tiny::_get_args, avg 8µs/call
2064146µs my $binmode = $args->{binmode};
2065142µs $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode;
20661444µs144.38ms my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
# spent 4.38ms making 14 calls to Path::Tiny::filehandle, avg 313µs/call
20671472µs1426µs if ( ( defined($binmode) ? $binmode : "" ) eq ":unix"
# spent 26µs making 14 calls to Path::Tiny::CORE:ftsize, avg 2µs/call
2068 and my $size = -s $fh )
2069 {
2070142µs my $buf;
2071144.09ms143.97ms my $rc = read $fh, $buf, $size; # File::Slurp in a nutshell
# spent 3.97ms making 14 calls to Path::Tiny::CORE:read, avg 284µs/call
2072147µs $self->_throw('read') unless defined $rc;
207314834µs return $buf;
2074 }
2075 else {
2076 local $/;
2077 my $buf = scalar <$fh>;
2078 $self->_throw('read') unless defined $buf;
2079 return $buf;
2080 }
2081}
2082
20832898µs149.55ms
# spent 61µs within Path::Tiny::slurp_raw which was called 14 times, avg 4µs/call: # 8 times (36µs+0s) by JSON::Schema::Modern::_get_or_load_resource at line 825 of /Users/ether/git/JSON-Schema-Modern/lib/JSON/Schema/Modern.pm, avg 4µs/call # 6 times (25µs+0s) by JSON::Schema::Modern::Document::OpenAPI::_add_vocab_and_default_schemas at line 204 of JSON/Schema/Modern/Document/OpenAPI.pm, avg 4µs/call
sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp }
# spent 9.55ms making 14 calls to Path::Tiny::slurp, avg 682µs/call
2084
2085sub slurp_utf8 {
2086 if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
2087 return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) );
2088 }
2089 elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
2090 $_[1] = { binmode => ":unix:utf8_strict" };
2091 goto &slurp;
2092 }
2093 else {
2094 $_[1] = { binmode => ":unix:encoding(UTF-8)" };
2095 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<binmode>, which is passed to
2110#pod C<binmode()> on the handle used for writing.
2111#pod
2112#pod C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast,
2113#pod unbuffered, raw write.
2114#pod
2115#pod C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>
2116#pod (or C<:unix:utf8_strict> with L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
2117#pod 0.58+ is installed, a raw, unbuffered spew will be done instead on the data
2118#pod encoded with C<Unicode::UTF8>.
2119#pod
2120#pod B<NOTE>: 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</append> with the C<truncate> option.
2125#pod
2126#pod Current API available since 0.011.
2127#pod
2128#pod =cut
2129
2130sub spew {
2131 my ( $self, @data ) = @_;
2132 my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
2133 $args = _get_args( $args, qw/binmode/ );
2134 my $binmode = $args->{binmode};
2135 # get default binmode from caller's lexical scope (see "perldoc open")
2136 $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 my $resolved_path = $self->_resolve_symlinks;
2141 my $temp = $resolved_path->_replacment_path;
2142
2143 my $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
2144 print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data) or self->_throw('print', $temp->[PATH]);
2145 close $fh or $self->_throw( 'close', $temp->[PATH] );
2146
2147 return $temp->move($resolved_path);
2148}
2149
2150sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew }
2151
2152sub spew_utf8 {
2153 if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
2154 my $self = shift;
2155 spew(
2156 $self,
2157 { binmode => ":unix" },
2158 map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_
2159 );
2160 }
2161 elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
2162 splice @_, 1, 0, { binmode => ":unix:utf8_strict" };
2163 goto &spew;
2164 }
2165 else {
2166 splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" };
2167 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<stat> or C<lstat> from L<File::stat>.
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?
2183sub stat {
2184 my $self = shift;
2185 require File::stat;
2186 return File::stat::stat( $self->[PATH] ) || $self->_throw('stat');
2187}
2188
2189sub lstat {
2190 my $self = shift;
2191 require File::stat;
2192 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<canonpath>, 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
2207sub 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<does not> 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<realpath>:
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
2232sub subsumes {
2233 my $self = shift;
2234 Carp::croak("subsumes() requires a defined, positive-length argument")
2235 unless defined $_[0];
2236 my $other = _path(shift);
2237
2238 # normalize absolute vs relative
2239 if ( $self->is_absolute && !$other->is_absolute ) {
2240 $other = $other->absolute;
2241 }
2242 elsif ( $other->is_absolute && !$self->is_absolute ) {
2243 $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 if ( length $self->volume && !length $other->volume ) {
2249 $other = $other->absolute;
2250 }
2251 elsif ( length $other->volume && !length $self->volume ) {
2252 $self = $self->absolute;
2253 }
2254
2255 if ( $self->[PATH] eq '.' ) {
2256 return !!1; # cwd subsumes everything relative
2257 }
2258 elsif ( $self->is_rootdir ) {
2259 # a root directory ("/", "c:/") already ends with a separator
2260 return $other->[PATH] =~ m{^\Q$self->[PATH]\E};
2261 }
2262 else {
2263 # exact match or prefix breaking at a separator
2264 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<touch> 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
2286sub touch {
2287 my ( $self, $epoch ) = @_;
2288 if ( !-e $self->[PATH] ) {
2289 my $fh = $self->openw;
2290 close $fh or $self->_throw('close');
2291 }
2292 if ( defined $epoch ) {
2293 utime $epoch, $epoch, $self->[PATH]
2294 or $self->_throw("utime ($epoch)");
2295 }
2296 else {
2297 # literal undef prevents warnings :-(
2298 utime undef, undef, $self->[PATH]
2299 or $self->_throw("utime ()");
2300 }
2301 return $self;
2302}
2303
2304#pod =method touchpath
2305#pod
2306#pod path("bar/baz/foo.txt")->touchpath;
2307#pod
2308#pod Combines C<mkdir> and C<touch>. Creates the parent directory if it doesn't exist,
2309#pod before touching the file. Returns the path object like C<touch> does.
2310#pod
2311#pod If you need to pass options, use C<mkdir> and C<touch> 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
2319sub touchpath {
2320 my ($self) = @_;
2321 my $parent = $self->parent;
2322 $parent->mkdir unless $parent->exists;
2323 $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</iterator> (which it uses internally):
2334#pod C<recurse> and C<follow_symlinks>. Both default to false.
2335#pod
2336#pod The callback function will receive a C<Path::Tiny> 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<Path::Tiny> 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<reference> 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<Path::Iterator::Rule>.
2370#pod
2371#pod Current API available since 0.062.
2372#pod
2373#pod =cut
2374
2375sub visit {
2376 my $self = shift;
2377 my $cb = shift;
2378 my $args = _get_args( shift, qw/recurse follow_symlinks/ );
2379 Carp::croak("Callback for visit() must be a code reference")
2380 unless defined($cb) && ref($cb) eq 'CODE';
2381 my $next = $self->iterator($args);
2382 my $state = {};
2383 while ( my $file = $next->() ) {
2384 local $_ = $file;
2385 my $r = $cb->( $file, $state );
2386 last if ref($r) eq 'SCALAR' && !$$r;
2387 }
2388 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<File::Spec> would give from C<splitpath> 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<MSWin32>.
2400#pod
2401#pod Current API available since 0.001.
2402#pod
2403#pod =cut
2404
2405sub volume {
2406 my ($self) = @_;
2407 $self->_splitpath unless defined $self->[VOL];
2408 return $self->[VOL];
2409}
2410
2411package Path::Tiny::Error;
2412
241310sour @CARP_NOT = qw/Path::Tiny/;
2414
24152199µs279µs
# spent 47µs (15+32) within Path::Tiny::Error::BEGIN@2415 which was called: # once (15µs+32µs) by JSON::Schema::Modern::BEGIN@25 at line 2415
use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 );
# spent 47µs making 1 call to Path::Tiny::Error::BEGIN@2415 # spent 32µs making 1 call to overload::import
2416
2417sub throw {
2418 my ( $class, $op, $file, $err ) = @_;
2419 chomp( my $trace = Carp::shortmess );
2420 my $msg = "Error $op on '$file': $err$trace\n";
2421 die bless { op => $op, file => $file, err => $err, msg => $msg }, $class;
2422}
2423
2424119µs1;
2425
2426
2427# vim: ts=4 sts=4 sw=4 et:
2428
2429__END__
 
# spent 134µs within Path::Tiny::CORE:flock which was called 14 times, avg 10µs/call: # 14 times (134µs+0s) by Path::Tiny::filehandle at line 1176, avg 10µs/call
sub Path::Tiny::CORE:flock; # opcode
# spent 26µs within Path::Tiny::CORE:ftsize which was called 14 times, avg 2µs/call: # 14 times (26µs+0s) by Path::Tiny::slurp at line 2067, avg 2µs/call
sub Path::Tiny::CORE:ftsize; # opcode
# spent 12µs within Path::Tiny::CORE:match which was called 14 times, avg 857ns/call: # 14 times (12µs+0s) by Path::Tiny::path at line 236, avg 857ns/call
sub Path::Tiny::CORE:match; # opcode
# spent 3.73ms within Path::Tiny::CORE:open which was called 14 times, avg 267µs/call: # 14 times (3.73ms+0s) by Path::Tiny::filehandle at line 1173, avg 267µs/call
sub Path::Tiny::CORE:open; # opcode
# spent 4µs within Path::Tiny::CORE:qr which was called 6 times, avg 667ns/call: # once (2µs+0s) by JSON::Schema::Modern::BEGIN@25 at line 67 # once (1µs+0s) by JSON::Schema::Modern::BEGIN@25 at line 1451 # once (1µs+0s) by JSON::Schema::Modern::BEGIN@25 at line 69 # once (0s+0s) by JSON::Schema::Modern::BEGIN@25 at line 68 # once (0s+0s) by JSON::Schema::Modern::BEGIN@25 at line 70 # once (0s+0s) by JSON::Schema::Modern::BEGIN@25 at line 71
sub Path::Tiny::CORE:qr; # opcode
# spent 3.97ms within Path::Tiny::CORE:read which was called 14 times, avg 284µs/call: # 14 times (3.97ms+0s) by Path::Tiny::slurp at line 2071, avg 284µs/call
sub Path::Tiny::CORE:read; # opcode
# spent 107µs within Path::Tiny::CORE:regcomp which was called 2 times, avg 54µs/call: # once (67µs+0s) by JSON::Schema::Modern::BEGIN@25 at line 71 # once (40µs+0s) by JSON::Schema::Modern::BEGIN@25 at line 70
sub Path::Tiny::CORE:regcomp; # opcode
# spent 14µs within Path::Tiny::CORE:subst which was called 14 times, avg 1µs/call: # 14 times (14µs+0s) by Path::Tiny::_pathify at line 298, avg 1µs/call
sub Path::Tiny::CORE:subst; # opcode
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.