and the C is C. #pod #pod This works even on C with drives and UNC volumes: #pod #pod path("C:/")->is_rootdir; # true #pod path("//server/share/")->is_rootdir; #true #pod #pod Current API available since 0.038. #pod #pod =cut sub is_rootdir { my ($self) = @_; $self->_splitpath unless defined $self->[DIR]; return $self->[DIR] eq '/' && $self->[FILE] eq ''; } #pod =method iterator #pod #pod $iter = path("/tmp")->iterator( \%options ); #pod #pod Returns a code reference that walks a directory lazily. Each invocation #pod returns a C object or undef when the iterator is exhausted. #pod #pod $iter = path("/tmp")->iterator; #pod while ( $path = $iter->() ) { #pod ... #pod } #pod #pod The current and parent directory entries ("." and "..") will not #pod be included. #pod #pod If the C option is true, the iterator will walk the directory #pod recursively, breadth-first. If the C option is also true, #pod directory links will be followed recursively. There is no protection against #pod loops when following links. If a directory is not readable, it will not be #pod followed. #pod #pod The default is the same as: #pod #pod $iter = path("/tmp")->iterator( { #pod recurse => 0, #pod follow_symlinks => 0, #pod } ); #pod #pod For a more powerful, recursive iterator with built-in loop avoidance, see #pod L. #pod #pod See also L. #pod #pod Current API available since 0.016. #pod #pod =cut sub iterator { my $self = shift; my $args = _get_args( shift, qw/recurse follow_symlinks/ ); my @dirs = $self; my $current; return sub { my $next; while (@dirs) { if ( ref $dirs[0] eq 'Path::Tiny' ) { if ( !-r $dirs[0] ) { # Directory is missing or not readable, so skip it. There # is still a race condition possible between the check and # the opendir, but we can't easily differentiate between # error cases that are OK to skip and those that we want # to be exceptions, so we live with the race and let opendir # be fatal. shift @dirs and next; } $current = $dirs[0]; my $dh; opendir( $dh, $current->[PATH] ) or $self->_throw( 'opendir', $current->[PATH] ); $dirs[0] = $dh; if ( -l $current->[PATH] && !$args->{follow_symlinks} ) { # Symlink attack! It was a real dir, but is now a symlink! # N.B. we check *after* opendir so the attacker has to win # two races: replace dir with symlink before opendir and # replace symlink with dir before -l check above shift @dirs and next; } } while ( defined( $next = readdir $dirs[0] ) ) { next if $next eq '.' || $next eq '..'; my $path = $current->child($next); push @dirs, $path if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path ); return $path; } shift @dirs; } return; }; } #pod =method lines, lines_raw, lines_utf8 #pod #pod @contents = path("/tmp/foo.txt")->lines; #pod @contents = path("/tmp/foo.txt")->lines(\%options); #pod @contents = path("/tmp/foo.txt")->lines_raw; #pod @contents = path("/tmp/foo.txt")->lines_utf8; #pod #pod @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } ); #pod #pod Returns a list of lines from a file. Optionally takes a hash-reference of #pod options. Valid options are C, C and C. #pod #pod If C is provided, it will be set on the handle prior to reading. #pod #pod If a positive C is provided, that many lines will be returned from the #pod start of the file. If a negative C is provided, the entire file will be #pod read, but only C will be kept and returned. If C #pod exceeds the number of lines in the file, all lines will be returned. #pod #pod If C is set, any end-of-line character sequences (C, C, or #pod C) will be removed from the lines returned. #pod #pod Because the return is a list, C in scalar context will return the number #pod of lines (and throw away the data). #pod #pod $number_of_lines = path("/tmp/foo.txt")->lines; #pod #pod C is like C with a C of C<:raw>. We use C<:raw> #pod instead of C<:unix> so PerlIO buffering can manage reading by line. #pod #pod C is like C with a C of C<:raw:encoding(UTF-8)> #pod (or C<:raw:utf8_strict> with L). If L #pod 0.58+ is installed, a raw, unbuffered UTF-8 slurp will be done and then the #pod lines will be split. This is actually faster than relying on #pod IO layers, though a bit memory intensive. If memory use is a #pod concern, consider C and iterating directly on the handle. #pod #pod Current API available since 0.065. #pod #pod =cut sub lines { my $self = shift; my $args = _get_args( shift, qw/binmode chomp count/ ); my $binmode = $args->{binmode}; $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode; my $fh = $self->filehandle( { locked => 1 }, "<", $binmode ); my $chomp = $args->{chomp}; # XXX more efficient to read @lines then chomp(@lines) vs map? if ( $args->{count} ) { my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) ); my $line; while ( !eof($fh) ) { defined( $line = readline($fh) ) or $self->_throw('readline'); $line =~ s/(?:\x{0d}?\x{0a}|\x{0d})\z// if $chomp; $result[ $counter++ ] = $line; # for positive count, terminate after right number of lines last if $counter == $args->{count}; # for negative count, eventually wrap around in the result array $counter %= $mod; } # reorder results if full and wrapped somewhere in the middle splice( @result, 0, 0, splice( @result, $counter ) ) if @result == $mod && $counter % $mod; return @result; } elsif ($chomp) { local $!; my @lines = map { s/(?:\x{0d}?\x{0a}|\x{0d})\z//; $_ } <$fh>; ## no critic $self->_throw('readline') if $!; return @lines; } else { if ( wantarray ) { local $!; my @lines = <$fh>; $self->_throw('readline') if $!; return @lines; } else { local $!; my $count =()= <$fh>; $self->_throw('readline') if $!; return $count; } } } sub lines_raw { my $self = shift; my $args = _get_args( shift, qw/binmode chomp count/ ); if ( $args->{chomp} && !$args->{count} ) { return split /\n/, slurp_raw($self); ## no critic } else { $args->{binmode} = ":raw"; return lines( $self, $args ); } } my $CRLF = qr/(?:\x{0d}?\x{0a}|\x{0d})/; sub lines_utf8 { my $self = shift; my $args = _get_args( shift, qw/binmode chomp count/ ); if ( ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) && $args->{chomp} && !$args->{count} ) { my $slurp = slurp_utf8($self); $slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF|CR return split $CRLF, $slurp, -1; ## no critic } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { $args->{binmode} = ":raw:utf8_strict"; return lines( $self, $args ); } else { $args->{binmode} = ":raw:encoding(UTF-8)"; return lines( $self, $args ); } } #pod =method mkdir #pod #pod path("foo/bar/baz")->mkdir; #pod path("foo/bar/baz")->mkdir( \%options ); #pod #pod Like calling C from L. An optional hash reference #pod is passed through to C. Errors will be trapped and an exception #pod thrown. Returns the the path object to facilitate chaining. #pod #pod B: unlike Perl's builtin C, this will create intermediate paths #pod similar to the Unix C command. It will not error if applied to an #pod existing directory. #pod #pod Current API available since 0.125. #pod #pod =cut sub mkdir { my ( $self, $args ) = @_; $args = {} unless ref $args eq 'HASH'; my $err; $args->{error} = \$err unless defined $args->{error}; require File::Path; my @dirs; my $ok = eval { File::Path::make_path( $self->[PATH], $args ); 1; }; if (!$ok) { $self->_throw('mkdir', $self->[PATH], "error creating path: $@"); } if ( $err && @$err ) { my ( $file, $message ) = %{ $err->[0] }; $self->_throw('mkdir', $file, $message); } return $self; } #pod =method mkpath (deprecated) #pod #pod Like calling C, but returns the list of directories created or an empty list if #pod the directories already exist, just like C. #pod #pod Deprecated in 0.125. #pod #pod =cut sub mkpath { my ( $self, $args ) = @_; $args = {} unless ref $args eq 'HASH'; my $err; $args->{error} = \$err unless defined $args->{error}; require File::Path; my @dirs = File::Path::make_path( $self->[PATH], $args ); if ( $err && @$err ) { my ( $file, $message ) = %{ $err->[0] }; Carp::croak("mkpath failed for $file: $message"); } return @dirs; } #pod =method move #pod #pod path("foo.txt")->move("bar.txt"); #pod #pod Moves the current path to the given destination using L's #pod C function. Upon success, returns the C object for the #pod newly moved file. #pod #pod If the destination already exists and is a directory, and the source is not a #pod directory, then the source file will be renamed into the directory #pod specified by the destination. #pod #pod If possible, move() will simply rename the file. Otherwise, it #pod copies the file to the new location and deletes the original. If an #pod error occurs during this copy-and-delete process, you may be left #pod with a (possibly partial) copy of the file under the destination #pod name. #pod #pod Current API available since 0.124. Prior versions used Perl's #pod -built-in (and less robust) L function #pod and did not return an object. #pod #pod =cut sub move { my ( $self, $dest ) = @_; require File::Copy; File::Copy::move( $self->[PATH], $dest ) or $self->_throw( 'move', $self->[PATH] . "' -> '$dest" ); return -d $dest ? _path( $dest, $self->basename ) : _path($dest); } #pod =method openr, openw, openrw, opena #pod #pod $fh = path("foo.txt")->openr($binmode); # read #pod $fh = path("foo.txt")->openr_raw; #pod $fh = path("foo.txt")->openr_utf8; #pod #pod $fh = path("foo.txt")->openw($binmode); # write #pod $fh = path("foo.txt")->openw_raw; #pod $fh = path("foo.txt")->openw_utf8; #pod #pod $fh = path("foo.txt")->opena($binmode); # append #pod $fh = path("foo.txt")->opena_raw; #pod $fh = path("foo.txt")->opena_utf8; #pod #pod $fh = path("foo.txt")->openrw($binmode); # read/write #pod $fh = path("foo.txt")->openrw_raw; #pod $fh = path("foo.txt")->openrw_utf8; #pod #pod Returns a file handle opened in the specified mode. The C style methods #pod take a single C argument. All of the C methods have #pod C and C equivalents that use buffered I/O layers C<:raw> #pod and C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with #pod L). #pod #pod An optional hash reference may be used to pass options. The only option is #pod C. If true, handles opened for writing, appending or read-write are #pod locked with C; otherwise, they are locked for C. #pod #pod $fh = path("foo.txt")->openrw_utf8( { locked => 1 } ); #pod #pod See L for more on locking. #pod #pod Current API available since 0.011. #pod #pod =cut # map method names to corresponding open mode my %opens = ( opena => ">>", openr => "<", openw => ">", openrw => "+<" ); while ( my ( $k, $v ) = each %opens ) { no strict 'refs'; # must check for lexical IO mode hint *{$k} = sub { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked/ ); my ($binmode) = @args; $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $v, -1, 1 ) } unless defined $binmode; $self->filehandle( $args, $v, $binmode ); }; *{ $k . "_raw" } = sub { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked/ ); $self->filehandle( $args, $v, ":raw" ); }; *{ $k . "_utf8" } = sub { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked/ ); my $layer; if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { $layer = ":raw:utf8_strict"; } else { $layer = ":raw:encoding(UTF-8)"; } $self->filehandle( $args, $v, $layer ); }; } #pod =method parent #pod #pod $parent = path("foo/bar/baz")->parent; # foo/bar #pod $parent = path("foo/wibble.txt")->parent; # foo #pod #pod $parent = path("foo/bar/baz")->parent(2); # foo #pod #pod Returns a C object corresponding to the parent directory of the #pod original directory or file. An optional positive integer argument is the number #pod of parent directories upwards to return. C by itself is equivalent to #pod C. #pod #pod Current API available since 0.014. #pod #pod =cut # XXX this is ugly and coverage is incomplete. I think it's there for windows # so need to check coverage there and compare sub parent { my ( $self, $level ) = @_; $level = 1 unless defined $level && $level > 0; $self->_splitpath unless defined $self->[FILE]; my $parent; if ( length $self->[FILE] ) { if ( $self->[FILE] eq '.' || $self->[FILE] eq ".." ) { $parent = _path( $self->[PATH] . "/.." ); } else { $parent = _path( _non_empty( $self->[VOL] . $self->[DIR] ) ); } } elsif ( length $self->[DIR] ) { # because of symlinks, any internal updir requires us to # just add more updirs at the end if ( $self->[DIR] =~ m{(?:^\.\./|/\.\./|/\.\.\z)} ) { $parent = _path( $self->[VOL] . $self->[DIR] . "/.." ); } else { ( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/}; $parent = _path( $self->[VOL] . $dir ); } } else { $parent = _path( _non_empty( $self->[VOL] ) ); } return $level == 1 ? $parent : $parent->parent( $level - 1 ); } sub _non_empty { my ($string) = shift; return ( ( defined($string) && length($string) ) ? $string : "." ); } #pod =method realpath #pod #pod $real = path("/baz/foo/../bar")->realpath; #pod $real = path("foo/../bar")->realpath; #pod #pod Returns a new C object with all symbolic links and upward directory #pod parts resolved using L's C. Compared to C, this is #pod more expensive as it must actually consult the filesystem. #pod #pod If the parent path can't be resolved (e.g. if it includes directories that #pod don't exist), an exception will be thrown: #pod #pod $real = path("doesnt_exist/foo")->realpath; # dies #pod #pod However, if the parent path exists and only the last component (e.g. filename) #pod doesn't exist, the realpath will be the realpath of the parent plus the #pod non-existent last component: #pod #pod $real = path("./aasdlfasdlf")->realpath; # works #pod #pod The underlying L module usually worked this way on Unix, but died on #pod Windows (and some Unixes) if the full path didn't exist. As of version 0.064, #pod it's safe to use anywhere. #pod #pod Current API available since 0.001. #pod #pod =cut # Win32 and some Unixes need parent path resolved separately so realpath # doesn't throw an error resolving non-existent basename sub realpath { my $self = shift; $self = $self->_resolve_symlinks; require Cwd; $self->_splitpath if !defined $self->[FILE]; my $check_parent = length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..'; my $realpath = eval { # pure-perl Cwd can carp local $SIG{__WARN__} = sub { }; Cwd::realpath( $check_parent ? $self->parent->[PATH] : $self->[PATH] ); }; # parent realpath must exist; not all Cwd::realpath will error if it doesn't $self->_throw("resolving realpath") unless defined $realpath && length $realpath && -e $realpath; return ( $check_parent ? _path( $realpath, $self->[FILE] ) : _path($realpath) ); } #pod =method relative #pod #pod $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar #pod #pod Returns a C object with a path relative to a new base path #pod given as an argument. If no argument is given, the current directory will #pod be used as the new base path. #pod #pod If either path is already relative, it will be made absolute based on the #pod current directly before determining the new relative path. #pod #pod The algorithm is roughly as follows: #pod #pod =for :list #pod * If the original and new base path are on different volumes, an exception #pod will be thrown. #pod * If the original and new base are identical, the relative path is C<".">. #pod * If the new base subsumes the original, the relative path is the original #pod path with the new base chopped off the front #pod * If the new base does not subsume the original, a common prefix path is #pod determined (possibly the root directory) and the relative path will #pod consist of updirs (C<"..">) to reach the common prefix, followed by the #pod original path less the common prefix. #pod #pod Unlike C, in the last case above, the calculation based #pod on a common prefix takes into account symlinks that could affect the updir #pod process. Given an original path "/A/B" and a new base "/A/C", #pod (where "A", "B" and "C" could each have multiple path components): #pod #pod =for :list #pod * Symlinks in "A" don't change the result unless the last component of A is #pod a symlink and the first component of "C" is an updir. #pod * Symlinks in "B" don't change the result and will exist in the result as #pod given. #pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into #pod account the possibility that not all path components might exist on the #pod filesystem. #pod #pod Current API available since 0.001. New algorithm (that accounts for #pod symlinks) available since 0.079. #pod #pod =cut sub relative { my ( $self, $base ) = @_; $base = _path( defined $base && length $base ? $base : '.' ); # relative paths must be converted to absolute first $self = $self->absolute if $self->is_relative; $base = $base->absolute if $base->is_relative; # normalize volumes if they exist $self = $self->absolute if !length $self->volume && length $base->volume; $base = $base->absolute if length $self->volume && !length $base->volume; # can't make paths relative across volumes if ( !_same( $self->volume, $base->volume ) ) { Carp::croak("relative() can't cross volumes: '$self' vs '$base'"); } # if same absolute path, relative is current directory return _path(".") if _same( $self->[PATH], $base->[PATH] ); # if base is a prefix of self, chop prefix off self if ( $base->subsumes($self) ) { $base = "" if $base->is_rootdir; my $relative = "$self"; $relative =~ s{\A\Q$base/}{}; return _path(".", $relative); } # base is not a prefix, so must find a common prefix (even if root) my ( @common, @self_parts, @base_parts ); @base_parts = split /\//, $base->_just_filepath; # if self is rootdir, then common directory is root (shown as empty # string for later joins); otherwise, must be computed from path parts. if ( $self->is_rootdir ) { @common = (""); shift @base_parts; } else { @self_parts = split /\//, $self->_just_filepath; while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) { push @common, shift @base_parts; shift @self_parts; } } # if there are any symlinks from common to base, we have a problem, as # you can't guarantee that updir from base reaches the common prefix; # we must resolve symlinks and try again; likewise, any updirs are # a problem as it throws off calculation of updirs needed to get from # self's path to the common prefix. if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) { return $self->relative($new_base); } # otherwise, symlinks in common or from common to A don't matter as # those don't involve updirs my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts ); return _path(@new_path); } sub _just_filepath { my $self = shift; my $self_vol = $self->volume; return "$self" if !length $self_vol; ( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{}; return $self_path; } sub _resolve_between { my ( $self, $common, $base ) = @_; my $path = $self->volume . join( "/", @$common ); my $changed = 0; for my $p (@$base) { $path .= "/$p"; if ( $p eq '..' ) { $changed = 1; if ( -e $path ) { $path = _path($path)->realpath->[PATH]; } else { $path =~ s{/[^/]+/..\z}{/}; } } if ( -l $path ) { $changed = 1; $path = _path($path)->realpath->[PATH]; } } return $changed ? _path($path) : undef; } #pod =method remove #pod #pod path("foo.txt")->remove; #pod #pod This is just like C, except for its error handling: if the path does #pod not exist, it returns false; if deleting the file fails, it throws an #pod exception. #pod #pod Current API available since 0.012. #pod #pod =cut sub remove { my $self = shift; return 0 if !-e $self->[PATH] && !-l $self->[PATH]; return unlink( $self->[PATH] ) || $self->_throw('unlink'); } #pod =method remove_tree #pod #pod # directory #pod path("foo/bar/baz")->remove_tree; #pod path("foo/bar/baz")->remove_tree( \%options ); #pod path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove #pod #pod Like calling C from L, but defaults to C mode. #pod An optional hash reference is passed through to C. Errors will be #pod trapped and an exception thrown. Returns the number of directories deleted, #pod just like C. #pod #pod If you want to remove a directory only if it is empty, use the built-in #pod C function instead. #pod #pod rmdir path("foo/bar/baz/"); #pod #pod Current API available since 0.013. #pod #pod =cut sub remove_tree { my ( $self, $args ) = @_; return 0 if !-e $self->[PATH] && !-l $self->[PATH]; $args = {} unless ref $args eq 'HASH'; my $err; $args->{error} = \$err unless defined $args->{error}; $args->{safe} = 1 unless defined $args->{safe}; require File::Path; my $count = File::Path::remove_tree( $self->[PATH], $args ); if ( $err && @$err ) { my ( $file, $message ) = %{ $err->[0] }; Carp::croak("remove_tree failed for $file: $message"); } return $count; } #pod =method sibling #pod #pod $foo = path("/tmp/foo.txt"); #pod $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt #pod $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt #pod #pod Returns a new C object relative to the parent of the original. #pod This is slightly more efficient than C<< $path->parent->child(...) >>. #pod #pod Current API available since 0.058. #pod #pod =cut sub sibling { my $self = shift; return _path( $self->parent->[PATH], @_ ); } #pod =method size, size_human #pod #pod my $p = path("foo"); # with size 1025 bytes #pod #pod $p->size; # "1025" #pod $p->size_human; # "1.1 K" #pod $p->size_human( {format => "iec"} ); # "1.1 KiB" #pod #pod Returns the size of a file. The C method is just a wrapper around C<-s>. #pod #pod The C method provides a human-readable string similar to #pod C. Like C, it rounds upwards and provides one decimal place for #pod single-digit sizes and no decimal places for larger sizes. The only available #pod option is C, which has three valid values: #pod #pod =for :list #pod * 'ls' (the default): base-2 sizes, with C style single-letter suffixes (K, M, etc.) #pod * 'iec': base-2 sizes, with IEC binary suffixes (KiB, MiB, etc.) #pod * 'si': base-10 sizes, with SI decimal suffixes (kB, MB, etc.) #pod #pod If C<-s> would return C, C returns the empty string. #pod #pod Current API available since 0.122. #pod #pod =cut sub size { -s $_[0]->[PATH] } my %formats = ( 'ls' => [ 1024, log(1024), [ "", map { " $_" } qw/K M G T/ ] ], 'iec' => [ 1024, log(1024), [ "", map { " $_" } qw/KiB MiB GiB TiB/ ] ], 'si' => [ 1000, log(1000), [ "", map { " $_" } qw/kB MB GB TB/ ] ], ); sub _formats { return $formats{$_[0]} } sub size_human { my $self = shift; my $args = _get_args( shift, qw/format/ ); my $format = defined $args->{format} ? $args->{format} : "ls"; my $fmt_opts = $formats{$format} or Carp::croak("Invalid format '$format' for size_human()"); my $size = -s $self->[PATH]; return defined $size ? _human_size( $size, @$fmt_opts ) : ""; } sub _ceil { return $_[0] == int($_[0]) ? $_[0] : int($_[0]+1); } sub _human_size { my ( $size, $base, $log_base, $suffixes ) = @_; return "0" if $size == 0; my $mag = int( log($size) / $log_base ); $size /= $base**$mag; $size = $mag == 0 ? $size : length( int($size) ) == 1 ? _ceil( $size * 10 ) / 10 : _ceil($size); if ( $size >= $base ) { $size /= $base; $mag++; } my $fmt = ( $mag == 0 || length( int($size) ) > 1 ) ? "%.0f%s" : "%.1f%s"; return sprintf( $fmt, $size, $suffixes->[$mag] ); } #pod =method slurp, slurp_raw, slurp_utf8 #pod #pod $data = path("foo.txt")->slurp; #pod $data = path("foo.txt")->slurp( {binmode => ":raw"} ); #pod $data = path("foo.txt")->slurp_raw; #pod $data = path("foo.txt")->slurp_utf8; #pod #pod Reads file contents into a scalar. Takes an optional hash reference which may #pod be used to pass options. The only available option is C, which is #pod passed to C on the handle used for reading. #pod #pod C is like C with a C of C<:unix> for #pod a fast, unbuffered, raw read. #pod #pod C is like C with a C of #pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with #pod L). If L 0.58+ is installed, a #pod unbuffered, raw slurp will be done instead and the result decoded with #pod C. This is just as strict and is roughly an order of #pod magnitude faster than using C<:encoding(UTF-8)>. #pod #pod B: C and friends lock the filehandle before slurping. If #pod you plan to slurp from a file created with L, be sure to #pod close other handles or open without locking to avoid a deadlock: #pod #pod my $tempfile = File::Temp->new(EXLOCK => 0); #pod my $guts = path($tempfile)->slurp; #pod #pod Current API available since 0.004. #pod #pod =cut sub slurp { my $self = shift; my $args = _get_args( shift, qw/binmode/ ); my $binmode = $args->{binmode}; $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode; my $fh = $self->filehandle( { locked => 1 }, "<", $binmode ); if ( ( defined($binmode) ? $binmode : "" ) eq ":unix" and my $size = -s $fh ) { my $buf; my $rc = read $fh, $buf, $size; # File::Slurp in a nutshell $self->_throw('read') unless defined $rc; return $buf; } else { local $/; my $buf = scalar <$fh>; $self->_throw('read') unless defined $buf; return $buf; } } sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp } sub slurp_utf8 { if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) { return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) ); } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { $_[1] = { binmode => ":unix:utf8_strict" }; goto &slurp; } else { $_[1] = { binmode => ":unix:encoding(UTF-8)" }; goto &slurp; } } #pod =method spew, spew_raw, spew_utf8 #pod #pod path("foo.txt")->spew(@data); #pod path("foo.txt")->spew(\@data); #pod path("foo.txt")->spew({binmode => ":raw"}, @data); #pod path("foo.txt")->spew_raw(@data); #pod path("foo.txt")->spew_utf8(@data); #pod #pod Writes data to a file atomically. The file is written to a temporary file in #pod the same directory, then renamed over the original. An optional hash reference #pod may be used to pass options. The only option is C, which is passed to #pod C on the handle used for writing. #pod #pod C is like C with a C of C<:unix> for a fast, #pod unbuffered, raw write. #pod #pod C is like C with a C of C<:unix:encoding(UTF-8)> #pod (or C<:unix:utf8_strict> with L). If L #pod 0.58+ is installed, a raw, unbuffered spew will be done instead on the data #pod encoded with C. #pod #pod B: because the file is written to a temporary file and then renamed, the #pod new file will wind up with permissions based on your current umask. This is a #pod feature to protect you from a race condition that would otherwise give #pod different permissions than you might expect. If you really want to keep the #pod original mode flags, use L with the C option. #pod #pod Current API available since 0.011. #pod #pod =cut sub spew { my ( $self, @data ) = @_; my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {}; $args = _get_args( $args, qw/binmode/ ); my $binmode = $args->{binmode}; # get default binmode from caller's lexical scope (see "perldoc open") $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode; # writing needs to follow the link and create the tempfile in the same # dir for later atomic rename my $resolved_path = $self->_resolve_symlinks; my $temp = $resolved_path->_replacment_path; my $fh; my $ok = eval { $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode ); 1 }; if (!$ok) { my $msg = ref($@) eq 'Path::Tiny::Error' ? "error opening temp file '$@->{file}' for atomic write: $@->{err}" : "error opening temp file for atomic write: $@"; $self->_throw('spew', $self->[PATH], $msg); } print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data) or self->_throw('print', $temp->[PATH]); close $fh or $self->_throw( 'close', $temp->[PATH] ); return $temp->move($resolved_path); } sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew } sub spew_utf8 { if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) { my $self = shift; spew( $self, { binmode => ":unix" }, map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_ ); } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { splice @_, 1, 0, { binmode => ":unix:utf8_strict" }; goto &spew; } else { splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" }; goto &spew; } } #pod =method stat, lstat #pod #pod $stat = path("foo.txt")->stat; #pod $stat = path("/some/symlink")->lstat; #pod #pod Like calling C or C from L. #pod #pod Current API available since 0.001. #pod #pod =cut # XXX break out individual stat() components as subs? sub stat { my $self = shift; require File::stat; return File::stat::stat( $self->[PATH] ) || $self->_throw('stat'); } sub lstat { my $self = shift; require File::stat; return File::stat::lstat( $self->[PATH] ) || $self->_throw('lstat'); } #pod =method stringify #pod #pod $path = path("foo.txt"); #pod say $path->stringify; # same as "$path" #pod #pod Returns a string representation of the path. Unlike C, this method #pod returns the path standardized with Unix-style C> directory separators. #pod #pod Current API available since 0.001. #pod #pod =cut sub stringify { $_[0]->[PATH] =~ /^~/ ? './' . $_[0]->[PATH] : $_[0]->[PATH] } #pod =method subsumes #pod #pod path("foo/bar")->subsumes("foo/bar/baz"); # true #pod path("/foo/bar")->subsumes("/foo/baz"); # false #pod #pod Returns true if the first path is a prefix of the second path at a directory #pod boundary. #pod #pod This B resolve parent directory entries (C<..>) or symlinks: #pod #pod path("foo/bar")->subsumes("foo/bar/../baz"); # true #pod #pod If such things are important to you, ensure that both paths are resolved to #pod the filesystem with C: #pod #pod my $p1 = path("foo/bar")->realpath; #pod my $p2 = path("foo/bar/../baz")->realpath; #pod if ( $p1->subsumes($p2) ) { ... } #pod #pod Current API available since 0.048. #pod #pod =cut sub subsumes { my $self = shift; Carp::croak("subsumes() requires a defined, positive-length argument") unless defined $_[0]; my $other = _path(shift); # normalize absolute vs relative if ( $self->is_absolute && !$other->is_absolute ) { $other = $other->absolute; } elsif ( $other->is_absolute && !$self->is_absolute ) { $self = $self->absolute; } # normalize volume vs non-volume; do this after absolute path # adjustments above since that might add volumes already if ( length $self->volume && !length $other->volume ) { $other = $other->absolute; } elsif ( length $other->volume && !length $self->volume ) { $self = $self->absolute; } if ( $self->[PATH] eq '.' ) { return !!1; # cwd subsumes everything relative } elsif ( $self->is_rootdir ) { # a root directory ("/", "c:/") already ends with a separator return $other->[PATH] =~ m{^\Q$self->[PATH]\E}; } else { # exact match or prefix breaking at a separator return $other->[PATH] =~ m{^\Q$self->[PATH]\E(?:/|\z)}; } } #pod =method touch #pod #pod path("foo.txt")->touch; #pod path("foo.txt")->touch($epoch_secs); #pod #pod Like the Unix C utility. Creates the file if it doesn't exist, or else #pod changes the modification and access times to the current time. If the first #pod argument is the epoch seconds then it will be used. #pod #pod Returns the path object so it can be easily chained with other methods: #pod #pod # won't die if foo.txt doesn't exist #pod $content = path("foo.txt")->touch->slurp; #pod #pod Current API available since 0.015. #pod #pod =cut sub touch { my ( $self, $epoch ) = @_; if ( !-e $self->[PATH] ) { my $fh = $self->openw; close $fh or $self->_throw('close'); } if ( defined $epoch ) { utime $epoch, $epoch, $self->[PATH] or $self->_throw("utime ($epoch)"); } else { # literal undef prevents warnings :-( utime undef, undef, $self->[PATH] or $self->_throw("utime ()"); } return $self; } #pod =method touchpath #pod #pod path("bar/baz/foo.txt")->touchpath; #pod #pod Combines C and C. Creates the parent directory if it doesn't exist, #pod before touching the file. Returns the path object like C does. #pod #pod If you need to pass options, use C and C separately: #pod #pod path("bar/baz")->mkdir( \%options )->child("foo.txt")->touch($epoch_secs); #pod #pod Current API available since 0.022. #pod #pod =cut sub touchpath { my ($self) = @_; my $parent = $self->parent; $parent->mkdir unless $parent->exists; $self->touch; } #pod =method visit #pod #pod path("/tmp")->visit( \&callback, \%options ); #pod #pod Executes a callback for each child of a directory. It returns a hash #pod reference with any state accumulated during iteration. #pod #pod The options are the same as for L (which it uses internally): #pod C and C. Both default to false. #pod #pod The callback function will receive a C object as the first argument #pod and a hash reference to accumulate state as the second argument. For example: #pod #pod # collect files sizes #pod my $sizes = path("/tmp")->visit( #pod sub { #pod my ($path, $state) = @_; #pod return if $path->is_dir; #pod $state->{$path} = -s $path; #pod }, #pod { recurse => 1 } #pod ); #pod #pod For convenience, the C object will also be locally aliased as the #pod C<$_> global variable: #pod #pod # print paths matching /foo/ #pod path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} ); #pod #pod If the callback returns a B to a false scalar value, iteration will #pod terminate. This is not the same as "pruning" a directory search; this just #pod stops all iteration and returns the state hash reference. #pod #pod # find up to 10 files larger than 100K #pod my $files = path("/tmp")->visit( #pod sub { #pod my ($path, $state) = @_; #pod $state->{$path}++ if -s $path > 102400 #pod return \0 if keys %$state == 10; #pod }, #pod { recurse => 1 } #pod ); #pod #pod If you want more flexible iteration, use a module like L. #pod #pod Current API available since 0.062. #pod #pod =cut sub visit { my $self = shift; my $cb = shift; my $args = _get_args( shift, qw/recurse follow_symlinks/ ); Carp::croak("Callback for visit() must be a code reference") unless defined($cb) && ref($cb) eq 'CODE'; my $next = $self->iterator($args); my $state = {}; while ( my $file = $next->() ) { local $_ = $file; my $r = $cb->( $file, $state ); last if ref($r) eq 'SCALAR' && !$$r; } return $state; } #pod =method volume #pod #pod $vol = path("/tmp/foo.txt")->volume; # "" #pod $vol = path("C:/tmp/foo.txt")->volume; # "C:" #pod #pod Returns the volume portion of the path. This is equivalent #pod to what L would give from C and thus #pod usually is the empty string on Unix-like operating systems or the #pod drive letter for an absolute path on C. #pod #pod Current API available since 0.001. #pod #pod =cut sub volume { my ($self) = @_; $self->_splitpath unless defined $self->[VOL]; return $self->[VOL]; } package Path::Tiny::Error; our @CARP_NOT = qw/Path::Tiny/; use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 ); sub throw { my ( $class, $op, $file, $err ) = @_; chomp( my $trace = Carp::shortmess ); my $msg = "Error $op on '$file': $err$trace\n"; die bless { op => $op, file => $file, err => $err, msg => $msg }, $class; } 1; # vim: ts=4 sts=4 sw=4 et: __END__ =pod =encoding UTF-8 =head1 NAME Path::Tiny - File path utility =head1 VERSION version 0.146 =head1 SYNOPSIS use Path::Tiny; # Creating Path::Tiny objects my $dir = path("/tmp"); my $foo = path("foo.txt"); my $subdir = $dir->child("foo"); my $bar = $subdir->child("bar.txt"); # Stringifies as cleaned up path my $file = path("./foo.txt"); print $file; # "foo.txt" # Reading files my $guts = $file->slurp; $guts = $file->slurp_utf8; my @lines = $file->lines; @lines = $file->lines_utf8; my ($head) = $file->lines( {count => 1} ); my ($tail) = $file->lines( {count => -1} ); # Writing files $bar->spew( @data ); $bar->spew_utf8( @data ); # Reading directories for ( $dir->children ) { ... } my $iter = $dir->iterator; while ( my $next = $iter->() ) { ... } =head1 DESCRIPTION This module provides a small, fast utility for working with file paths. It is friendlier to use than L and provides easy access to functions from several other core file handling modules. It aims to be smaller and faster than many alternatives on CPAN, while helping people do many common things in consistent and less error-prone ways. Path::Tiny does not try to work for anything except Unix-like and Win32 platforms. Even then, it might break if you try something particularly obscure or tortuous. (Quick! What does this mean: C<< ///../../..//./././a//b/.././c/././ >>? And how does it differ on Win32?) All paths are forced to have Unix-style forward slashes. Stringifying the object gives you back the path (after some clean up). File input/output methods C handles before reading or writing, as appropriate (if supported by the platform and/or filesystem). The C<*_utf8> methods (C, C, etc.) operate in raw mode. On Windows, that means they will not have CRLF translation from the C<:crlf> IO layer. Installing L 0.58 or later will speed up C<*_utf8> situations in many cases and is highly recommended. Alternatively, installing L 0.003 or later will be used in place of the default C<:encoding(UTF-8)>. This module depends heavily on PerlIO layers for correct operation and thus requires Perl 5.008001 or later. =head1 CONSTRUCTORS =head2 path $path = path("foo/bar"); $path = path("/tmp", "file.txt"); # list $path = path("."); # cwd Constructs a C object. It doesn't matter if you give a file or directory path. It's still up to you to call directory-like methods only on directories and file-like methods only on files. This function is exported automatically by default. The first argument must be defined and have non-zero length or an exception will be thrown. This prevents subtle, dangerous errors with code like C<< path( maybe_undef() )->remove_tree >>. B: If and only if the B character of the B argument to C is a tilde ('~'), then tilde replacement will be applied to the first path segment. A single tilde will be replaced with C and a tilde followed by a username will be replaced with output of C. B. See L for more. On Windows, if the path consists of a drive identifier without a path component (C or C), it will be expanded to the absolute path of the current directory on that volume using C. If called with a single C argument, the original is returned unless the original is holding a temporary file or directory reference in which case a stringified copy is made. $path = path("foo/bar"); $temp = Path::Tiny->tempfile; $p2 = path($path); # like $p2 = $path $t2 = path($temp); # like $t2 = path( "$temp" ) This optimizes copies without proliferating references unexpectedly if a copy is made by code outside your control. Current API available since 0.017. =head2 new $path = Path::Tiny->new("foo/bar"); This is just like C, but with method call overhead. (Why would you do that?) Current API available since 0.001. =head2 cwd $path = Path::Tiny->cwd; # path( Cwd::getcwd ) $path = cwd; # optional export Gives you the absolute path to the current directory as a C object. This is slightly faster than C<< path(".")->absolute >>. C may be exported on request and used as a function instead of as a method. Current API available since 0.018. =head2 rootdir $path = Path::Tiny->rootdir; # / $path = rootdir; # optional export Gives you C<< File::Spec->rootdir >> as a C object if you're too picky for C. C may be exported on request and used as a function instead of as a method. Current API available since 0.018. =head2 tempfile, tempdir $temp = Path::Tiny->tempfile( @options ); $temp = Path::Tiny->tempdir( @options ); $temp = $dirpath->tempfile( @options ); $temp = $dirpath->tempdir( @options ); $temp = tempfile( @options ); # optional export $temp = tempdir( @options ); # optional export C passes the options to C<< File::Temp->new >> and returns a C object with the file name. The C option will be enabled by default, but you can override that by passing C<< TMPDIR => 0 >> along with the options. (If you use an absolute C option, you will want to disable C.) The resulting C object is cached. When the C object is destroyed, the C object will be as well. C annoyingly requires you to specify a custom template in slightly different ways depending on which function or method you call, but C lets you ignore that and can take either a leading template or a C option and does the right thing. $temp = Path::Tiny->tempfile( "customXXXXXXXX" ); # ok $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok The tempfile path object will be normalized to have an absolute path, even if created in a relative directory using C. If you want it to have the C instead, pass a leading options hash like this: $real_temp = tempfile({realpath => 1}, @options); C is just like C, except it calls C<< File::Temp->newdir >> instead. Both C and C may be exported on request and used as functions instead of as methods. The methods can be called on an instances representing a directory. In this case, the directory is used as the base to create the temporary file/directory, setting the C option in File::Temp. my $target_dir = path('/to/destination'); my $tempfile = $target_dir->tempfile('foobarXXXXXX'); $tempfile->spew('A lot of data...'); # not atomic $tempfile->move($target_dir->child('foobar')); # hopefully atomic In this case, any value set for option C is ignored. B: for tempfiles, the filehandles from File::Temp are closed and not reused. This is not as secure as using File::Temp handles directly, but is less prone to deadlocks or access problems on some platforms. Think of what C gives you to be just a temporary file B that gets cleaned up. B: if you don't want these cleaned up automatically when the object is destroyed, File::Temp requires different options for directories and files. Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for files. B: Don't lose the temporary object by chaining a method call instead of storing it: my $lost = tempdir()->child("foo"); # tempdir cleaned up right away B: The cached object may be accessed with the L method. Keeping a reference to, or modifying the cached object may break the behavior documented above and is not supported. Use at your own risk. Current API available since 0.119. =head1 METHODS =head2 absolute $abs = path("foo/bar")->absolute; $abs = path("foo/bar")->absolute("/tmp"); Returns a new C object with an absolute path (or itself if already absolute). If no argument is given, the current directory is used as the absolute base path. If an argument is given, it will be converted to an absolute path (if it is not already) and used as the absolute base path. This will not resolve upward directories ("foo/../bar") unless C in L would normally do so on your platform. If you need them resolved, you must call the more expensive C method instead. On Windows, an absolute path without a volume component will have it added based on the current drive. Current API available since 0.101. =head2 append, append_raw, append_utf8 path("foo.txt")->append(@data); path("foo.txt")->append(\@data); path("foo.txt")->append({binmode => ":raw"}, @data); path("foo.txt")->append_raw(@data); path("foo.txt")->append_utf8(@data); Appends data to a file. The file is locked with C
. #pod #pod This works even on C with drives and UNC volumes: #pod #pod path("C:/")->is_rootdir; # true #pod path("//server/share/")->is_rootdir; #true #pod #pod Current API available since 0.038. #pod #pod =cut sub is_rootdir { my ($self) = @_; $self->_splitpath unless defined $self->[DIR]; return $self->[DIR] eq '/' && $self->[FILE] eq ''; } #pod =method iterator #pod #pod $iter = path("/tmp")->iterator( \%options ); #pod #pod Returns a code reference that walks a directory lazily. Each invocation #pod returns a C object or undef when the iterator is exhausted. #pod #pod $iter = path("/tmp")->iterator; #pod while ( $path = $iter->() ) { #pod ... #pod } #pod #pod The current and parent directory entries ("." and "..") will not #pod be included. #pod #pod If the C option is true, the iterator will walk the directory #pod recursively, breadth-first. If the C option is also true, #pod directory links will be followed recursively. There is no protection against #pod loops when following links. If a directory is not readable, it will not be #pod followed. #pod #pod The default is the same as: #pod #pod $iter = path("/tmp")->iterator( { #pod recurse => 0, #pod follow_symlinks => 0, #pod } ); #pod #pod For a more powerful, recursive iterator with built-in loop avoidance, see #pod L. #pod #pod See also L. #pod #pod Current API available since 0.016. #pod #pod =cut sub iterator { my $self = shift; my $args = _get_args( shift, qw/recurse follow_symlinks/ ); my @dirs = $self; my $current; return sub { my $next; while (@dirs) { if ( ref $dirs[0] eq 'Path::Tiny' ) { if ( !-r $dirs[0] ) { # Directory is missing or not readable, so skip it. There # is still a race condition possible between the check and # the opendir, but we can't easily differentiate between # error cases that are OK to skip and those that we want # to be exceptions, so we live with the race and let opendir # be fatal. shift @dirs and next; } $current = $dirs[0]; my $dh; opendir( $dh, $current->[PATH] ) or $self->_throw( 'opendir', $current->[PATH] ); $dirs[0] = $dh; if ( -l $current->[PATH] && !$args->{follow_symlinks} ) { # Symlink attack! It was a real dir, but is now a symlink! # N.B. we check *after* opendir so the attacker has to win # two races: replace dir with symlink before opendir and # replace symlink with dir before -l check above shift @dirs and next; } } while ( defined( $next = readdir $dirs[0] ) ) { next if $next eq '.' || $next eq '..'; my $path = $current->child($next); push @dirs, $path if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path ); return $path; } shift @dirs; } return; }; } #pod =method lines, lines_raw, lines_utf8 #pod #pod @contents = path("/tmp/foo.txt")->lines; #pod @contents = path("/tmp/foo.txt")->lines(\%options); #pod @contents = path("/tmp/foo.txt")->lines_raw; #pod @contents = path("/tmp/foo.txt")->lines_utf8; #pod #pod @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } ); #pod #pod Returns a list of lines from a file. Optionally takes a hash-reference of #pod options. Valid options are C, C and C. #pod #pod If C is provided, it will be set on the handle prior to reading. #pod #pod If a positive C is provided, that many lines will be returned from the #pod start of the file. If a negative C is provided, the entire file will be #pod read, but only C will be kept and returned. If C #pod exceeds the number of lines in the file, all lines will be returned. #pod #pod If C is set, any end-of-line character sequences (C, C, or #pod C) will be removed from the lines returned. #pod #pod Because the return is a list, C in scalar context will return the number #pod of lines (and throw away the data). #pod #pod $number_of_lines = path("/tmp/foo.txt")->lines; #pod #pod C is like C with a C of C<:raw>. We use C<:raw> #pod instead of C<:unix> so PerlIO buffering can manage reading by line. #pod #pod C is like C with a C of C<:raw:encoding(UTF-8)> #pod (or C<:raw:utf8_strict> with L). If L #pod 0.58+ is installed, a raw, unbuffered UTF-8 slurp will be done and then the #pod lines will be split. This is actually faster than relying on #pod IO layers, though a bit memory intensive. If memory use is a #pod concern, consider C and iterating directly on the handle. #pod #pod Current API available since 0.065. #pod #pod =cut sub lines { my $self = shift; my $args = _get_args( shift, qw/binmode chomp count/ ); my $binmode = $args->{binmode}; $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode; my $fh = $self->filehandle( { locked => 1 }, "<", $binmode ); my $chomp = $args->{chomp}; # XXX more efficient to read @lines then chomp(@lines) vs map? if ( $args->{count} ) { my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) ); my $line; while ( !eof($fh) ) { defined( $line = readline($fh) ) or $self->_throw('readline'); $line =~ s/(?:\x{0d}?\x{0a}|\x{0d})\z// if $chomp; $result[ $counter++ ] = $line; # for positive count, terminate after right number of lines last if $counter == $args->{count}; # for negative count, eventually wrap around in the result array $counter %= $mod; } # reorder results if full and wrapped somewhere in the middle splice( @result, 0, 0, splice( @result, $counter ) ) if @result == $mod && $counter % $mod; return @result; } elsif ($chomp) { local $!; my @lines = map { s/(?:\x{0d}?\x{0a}|\x{0d})\z//; $_ } <$fh>; ## no critic $self->_throw('readline') if $!; return @lines; } else { if ( wantarray ) { local $!; my @lines = <$fh>; $self->_throw('readline') if $!; return @lines; } else { local $!; my $count =()= <$fh>; $self->_throw('readline') if $!; return $count; } } } sub lines_raw { my $self = shift; my $args = _get_args( shift, qw/binmode chomp count/ ); if ( $args->{chomp} && !$args->{count} ) { return split /\n/, slurp_raw($self); ## no critic } else { $args->{binmode} = ":raw"; return lines( $self, $args ); } } my $CRLF = qr/(?:\x{0d}?\x{0a}|\x{0d})/; sub lines_utf8 { my $self = shift; my $args = _get_args( shift, qw/binmode chomp count/ ); if ( ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) && $args->{chomp} && !$args->{count} ) { my $slurp = slurp_utf8($self); $slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF|CR return split $CRLF, $slurp, -1; ## no critic } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { $args->{binmode} = ":raw:utf8_strict"; return lines( $self, $args ); } else { $args->{binmode} = ":raw:encoding(UTF-8)"; return lines( $self, $args ); } } #pod =method mkdir #pod #pod path("foo/bar/baz")->mkdir; #pod path("foo/bar/baz")->mkdir( \%options ); #pod #pod Like calling C from L. An optional hash reference #pod is passed through to C. Errors will be trapped and an exception #pod thrown. Returns the the path object to facilitate chaining. #pod #pod B: unlike Perl's builtin C, this will create intermediate paths #pod similar to the Unix C command. It will not error if applied to an #pod existing directory. #pod #pod Current API available since 0.125. #pod #pod =cut sub mkdir { my ( $self, $args ) = @_; $args = {} unless ref $args eq 'HASH'; my $err; $args->{error} = \$err unless defined $args->{error}; require File::Path; my @dirs; my $ok = eval { File::Path::make_path( $self->[PATH], $args ); 1; }; if (!$ok) { $self->_throw('mkdir', $self->[PATH], "error creating path: $@"); } if ( $err && @$err ) { my ( $file, $message ) = %{ $err->[0] }; $self->_throw('mkdir', $file, $message); } return $self; } #pod =method mkpath (deprecated) #pod #pod Like calling C, but returns the list of directories created or an empty list if #pod the directories already exist, just like C. #pod #pod Deprecated in 0.125. #pod #pod =cut sub mkpath { my ( $self, $args ) = @_; $args = {} unless ref $args eq 'HASH'; my $err; $args->{error} = \$err unless defined $args->{error}; require File::Path; my @dirs = File::Path::make_path( $self->[PATH], $args ); if ( $err && @$err ) { my ( $file, $message ) = %{ $err->[0] }; Carp::croak("mkpath failed for $file: $message"); } return @dirs; } #pod =method move #pod #pod path("foo.txt")->move("bar.txt"); #pod #pod Moves the current path to the given destination using L's #pod C function. Upon success, returns the C object for the #pod newly moved file. #pod #pod If the destination already exists and is a directory, and the source is not a #pod directory, then the source file will be renamed into the directory #pod specified by the destination. #pod #pod If possible, move() will simply rename the file. Otherwise, it #pod copies the file to the new location and deletes the original. If an #pod error occurs during this copy-and-delete process, you may be left #pod with a (possibly partial) copy of the file under the destination #pod name. #pod #pod Current API available since 0.124. Prior versions used Perl's #pod -built-in (and less robust) L function #pod and did not return an object. #pod #pod =cut sub move { my ( $self, $dest ) = @_; require File::Copy; File::Copy::move( $self->[PATH], $dest ) or $self->_throw( 'move', $self->[PATH] . "' -> '$dest" ); return -d $dest ? _path( $dest, $self->basename ) : _path($dest); } #pod =method openr, openw, openrw, opena #pod #pod $fh = path("foo.txt")->openr($binmode); # read #pod $fh = path("foo.txt")->openr_raw; #pod $fh = path("foo.txt")->openr_utf8; #pod #pod $fh = path("foo.txt")->openw($binmode); # write #pod $fh = path("foo.txt")->openw_raw; #pod $fh = path("foo.txt")->openw_utf8; #pod #pod $fh = path("foo.txt")->opena($binmode); # append #pod $fh = path("foo.txt")->opena_raw; #pod $fh = path("foo.txt")->opena_utf8; #pod #pod $fh = path("foo.txt")->openrw($binmode); # read/write #pod $fh = path("foo.txt")->openrw_raw; #pod $fh = path("foo.txt")->openrw_utf8; #pod #pod Returns a file handle opened in the specified mode. The C style methods #pod take a single C argument. All of the C methods have #pod C and C equivalents that use buffered I/O layers C<:raw> #pod and C<:raw:encoding(UTF-8)> (or C<:raw:utf8_strict> with #pod L). #pod #pod An optional hash reference may be used to pass options. The only option is #pod C. If true, handles opened for writing, appending or read-write are #pod locked with C; otherwise, they are locked for C. #pod #pod $fh = path("foo.txt")->openrw_utf8( { locked => 1 } ); #pod #pod See L for more on locking. #pod #pod Current API available since 0.011. #pod #pod =cut # map method names to corresponding open mode my %opens = ( opena => ">>", openr => "<", openw => ">", openrw => "+<" ); while ( my ( $k, $v ) = each %opens ) { no strict 'refs'; # must check for lexical IO mode hint *{$k} = sub { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked/ ); my ($binmode) = @args; $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $v, -1, 1 ) } unless defined $binmode; $self->filehandle( $args, $v, $binmode ); }; *{ $k . "_raw" } = sub { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked/ ); $self->filehandle( $args, $v, ":raw" ); }; *{ $k . "_utf8" } = sub { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked/ ); my $layer; if ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { $layer = ":raw:utf8_strict"; } else { $layer = ":raw:encoding(UTF-8)"; } $self->filehandle( $args, $v, $layer ); }; } #pod =method parent #pod #pod $parent = path("foo/bar/baz")->parent; # foo/bar #pod $parent = path("foo/wibble.txt")->parent; # foo #pod #pod $parent = path("foo/bar/baz")->parent(2); # foo #pod #pod Returns a C object corresponding to the parent directory of the #pod original directory or file. An optional positive integer argument is the number #pod of parent directories upwards to return. C by itself is equivalent to #pod C. #pod #pod Current API available since 0.014. #pod #pod =cut # XXX this is ugly and coverage is incomplete. I think it's there for windows # so need to check coverage there and compare sub parent { my ( $self, $level ) = @_; $level = 1 unless defined $level && $level > 0; $self->_splitpath unless defined $self->[FILE]; my $parent; if ( length $self->[FILE] ) { if ( $self->[FILE] eq '.' || $self->[FILE] eq ".." ) { $parent = _path( $self->[PATH] . "/.." ); } else { $parent = _path( _non_empty( $self->[VOL] . $self->[DIR] ) ); } } elsif ( length $self->[DIR] ) { # because of symlinks, any internal updir requires us to # just add more updirs at the end if ( $self->[DIR] =~ m{(?:^\.\./|/\.\./|/\.\.\z)} ) { $parent = _path( $self->[VOL] . $self->[DIR] . "/.." ); } else { ( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/}; $parent = _path( $self->[VOL] . $dir ); } } else { $parent = _path( _non_empty( $self->[VOL] ) ); } return $level == 1 ? $parent : $parent->parent( $level - 1 ); } sub _non_empty { my ($string) = shift; return ( ( defined($string) && length($string) ) ? $string : "." ); } #pod =method realpath #pod #pod $real = path("/baz/foo/../bar")->realpath; #pod $real = path("foo/../bar")->realpath; #pod #pod Returns a new C object with all symbolic links and upward directory #pod parts resolved using L's C. Compared to C, this is #pod more expensive as it must actually consult the filesystem. #pod #pod If the parent path can't be resolved (e.g. if it includes directories that #pod don't exist), an exception will be thrown: #pod #pod $real = path("doesnt_exist/foo")->realpath; # dies #pod #pod However, if the parent path exists and only the last component (e.g. filename) #pod doesn't exist, the realpath will be the realpath of the parent plus the #pod non-existent last component: #pod #pod $real = path("./aasdlfasdlf")->realpath; # works #pod #pod The underlying L module usually worked this way on Unix, but died on #pod Windows (and some Unixes) if the full path didn't exist. As of version 0.064, #pod it's safe to use anywhere. #pod #pod Current API available since 0.001. #pod #pod =cut # Win32 and some Unixes need parent path resolved separately so realpath # doesn't throw an error resolving non-existent basename sub realpath { my $self = shift; $self = $self->_resolve_symlinks; require Cwd; $self->_splitpath if !defined $self->[FILE]; my $check_parent = length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..'; my $realpath = eval { # pure-perl Cwd can carp local $SIG{__WARN__} = sub { }; Cwd::realpath( $check_parent ? $self->parent->[PATH] : $self->[PATH] ); }; # parent realpath must exist; not all Cwd::realpath will error if it doesn't $self->_throw("resolving realpath") unless defined $realpath && length $realpath && -e $realpath; return ( $check_parent ? _path( $realpath, $self->[FILE] ) : _path($realpath) ); } #pod =method relative #pod #pod $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar #pod #pod Returns a C object with a path relative to a new base path #pod given as an argument. If no argument is given, the current directory will #pod be used as the new base path. #pod #pod If either path is already relative, it will be made absolute based on the #pod current directly before determining the new relative path. #pod #pod The algorithm is roughly as follows: #pod #pod =for :list #pod * If the original and new base path are on different volumes, an exception #pod will be thrown. #pod * If the original and new base are identical, the relative path is C<".">. #pod * If the new base subsumes the original, the relative path is the original #pod path with the new base chopped off the front #pod * If the new base does not subsume the original, a common prefix path is #pod determined (possibly the root directory) and the relative path will #pod consist of updirs (C<"..">) to reach the common prefix, followed by the #pod original path less the common prefix. #pod #pod Unlike C, in the last case above, the calculation based #pod on a common prefix takes into account symlinks that could affect the updir #pod process. Given an original path "/A/B" and a new base "/A/C", #pod (where "A", "B" and "C" could each have multiple path components): #pod #pod =for :list #pod * Symlinks in "A" don't change the result unless the last component of A is #pod a symlink and the first component of "C" is an updir. #pod * Symlinks in "B" don't change the result and will exist in the result as #pod given. #pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into #pod account the possibility that not all path components might exist on the #pod filesystem. #pod #pod Current API available since 0.001. New algorithm (that accounts for #pod symlinks) available since 0.079. #pod #pod =cut sub relative { my ( $self, $base ) = @_; $base = _path( defined $base && length $base ? $base : '.' ); # relative paths must be converted to absolute first $self = $self->absolute if $self->is_relative; $base = $base->absolute if $base->is_relative; # normalize volumes if they exist $self = $self->absolute if !length $self->volume && length $base->volume; $base = $base->absolute if length $self->volume && !length $base->volume; # can't make paths relative across volumes if ( !_same( $self->volume, $base->volume ) ) { Carp::croak("relative() can't cross volumes: '$self' vs '$base'"); } # if same absolute path, relative is current directory return _path(".") if _same( $self->[PATH], $base->[PATH] ); # if base is a prefix of self, chop prefix off self if ( $base->subsumes($self) ) { $base = "" if $base->is_rootdir; my $relative = "$self"; $relative =~ s{\A\Q$base/}{}; return _path(".", $relative); } # base is not a prefix, so must find a common prefix (even if root) my ( @common, @self_parts, @base_parts ); @base_parts = split /\//, $base->_just_filepath; # if self is rootdir, then common directory is root (shown as empty # string for later joins); otherwise, must be computed from path parts. if ( $self->is_rootdir ) { @common = (""); shift @base_parts; } else { @self_parts = split /\//, $self->_just_filepath; while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) { push @common, shift @base_parts; shift @self_parts; } } # if there are any symlinks from common to base, we have a problem, as # you can't guarantee that updir from base reaches the common prefix; # we must resolve symlinks and try again; likewise, any updirs are # a problem as it throws off calculation of updirs needed to get from # self's path to the common prefix. if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) { return $self->relative($new_base); } # otherwise, symlinks in common or from common to A don't matter as # those don't involve updirs my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts ); return _path(@new_path); } sub _just_filepath { my $self = shift; my $self_vol = $self->volume; return "$self" if !length $self_vol; ( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{}; return $self_path; } sub _resolve_between { my ( $self, $common, $base ) = @_; my $path = $self->volume . join( "/", @$common ); my $changed = 0; for my $p (@$base) { $path .= "/$p"; if ( $p eq '..' ) { $changed = 1; if ( -e $path ) { $path = _path($path)->realpath->[PATH]; } else { $path =~ s{/[^/]+/..\z}{/}; } } if ( -l $path ) { $changed = 1; $path = _path($path)->realpath->[PATH]; } } return $changed ? _path($path) : undef; } #pod =method remove #pod #pod path("foo.txt")->remove; #pod #pod This is just like C, except for its error handling: if the path does #pod not exist, it returns false; if deleting the file fails, it throws an #pod exception. #pod #pod Current API available since 0.012. #pod #pod =cut sub remove { my $self = shift; return 0 if !-e $self->[PATH] && !-l $self->[PATH]; return unlink( $self->[PATH] ) || $self->_throw('unlink'); } #pod =method remove_tree #pod #pod # directory #pod path("foo/bar/baz")->remove_tree; #pod path("foo/bar/baz")->remove_tree( \%options ); #pod path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove #pod #pod Like calling C from L, but defaults to C mode. #pod An optional hash reference is passed through to C. Errors will be #pod trapped and an exception thrown. Returns the number of directories deleted, #pod just like C. #pod #pod If you want to remove a directory only if it is empty, use the built-in #pod C function instead. #pod #pod rmdir path("foo/bar/baz/"); #pod #pod Current API available since 0.013. #pod #pod =cut sub remove_tree { my ( $self, $args ) = @_; return 0 if !-e $self->[PATH] && !-l $self->[PATH]; $args = {} unless ref $args eq 'HASH'; my $err; $args->{error} = \$err unless defined $args->{error}; $args->{safe} = 1 unless defined $args->{safe}; require File::Path; my $count = File::Path::remove_tree( $self->[PATH], $args ); if ( $err && @$err ) { my ( $file, $message ) = %{ $err->[0] }; Carp::croak("remove_tree failed for $file: $message"); } return $count; } #pod =method sibling #pod #pod $foo = path("/tmp/foo.txt"); #pod $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt #pod $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt #pod #pod Returns a new C object relative to the parent of the original. #pod This is slightly more efficient than C<< $path->parent->child(...) >>. #pod #pod Current API available since 0.058. #pod #pod =cut sub sibling { my $self = shift; return _path( $self->parent->[PATH], @_ ); } #pod =method size, size_human #pod #pod my $p = path("foo"); # with size 1025 bytes #pod #pod $p->size; # "1025" #pod $p->size_human; # "1.1 K" #pod $p->size_human( {format => "iec"} ); # "1.1 KiB" #pod #pod Returns the size of a file. The C method is just a wrapper around C<-s>. #pod #pod The C method provides a human-readable string similar to #pod C. Like C, it rounds upwards and provides one decimal place for #pod single-digit sizes and no decimal places for larger sizes. The only available #pod option is C, which has three valid values: #pod #pod =for :list #pod * 'ls' (the default): base-2 sizes, with C style single-letter suffixes (K, M, etc.) #pod * 'iec': base-2 sizes, with IEC binary suffixes (KiB, MiB, etc.) #pod * 'si': base-10 sizes, with SI decimal suffixes (kB, MB, etc.) #pod #pod If C<-s> would return C, C returns the empty string. #pod #pod Current API available since 0.122. #pod #pod =cut sub size { -s $_[0]->[PATH] } my %formats = ( 'ls' => [ 1024, log(1024), [ "", map { " $_" } qw/K M G T/ ] ], 'iec' => [ 1024, log(1024), [ "", map { " $_" } qw/KiB MiB GiB TiB/ ] ], 'si' => [ 1000, log(1000), [ "", map { " $_" } qw/kB MB GB TB/ ] ], ); sub _formats { return $formats{$_[0]} } sub size_human { my $self = shift; my $args = _get_args( shift, qw/format/ ); my $format = defined $args->{format} ? $args->{format} : "ls"; my $fmt_opts = $formats{$format} or Carp::croak("Invalid format '$format' for size_human()"); my $size = -s $self->[PATH]; return defined $size ? _human_size( $size, @$fmt_opts ) : ""; } sub _ceil { return $_[0] == int($_[0]) ? $_[0] : int($_[0]+1); } sub _human_size { my ( $size, $base, $log_base, $suffixes ) = @_; return "0" if $size == 0; my $mag = int( log($size) / $log_base ); $size /= $base**$mag; $size = $mag == 0 ? $size : length( int($size) ) == 1 ? _ceil( $size * 10 ) / 10 : _ceil($size); if ( $size >= $base ) { $size /= $base; $mag++; } my $fmt = ( $mag == 0 || length( int($size) ) > 1 ) ? "%.0f%s" : "%.1f%s"; return sprintf( $fmt, $size, $suffixes->[$mag] ); } #pod =method slurp, slurp_raw, slurp_utf8 #pod #pod $data = path("foo.txt")->slurp; #pod $data = path("foo.txt")->slurp( {binmode => ":raw"} ); #pod $data = path("foo.txt")->slurp_raw; #pod $data = path("foo.txt")->slurp_utf8; #pod #pod Reads file contents into a scalar. Takes an optional hash reference which may #pod be used to pass options. The only available option is C, which is #pod passed to C on the handle used for reading. #pod #pod C is like C with a C of C<:unix> for #pod a fast, unbuffered, raw read. #pod #pod C is like C with a C of #pod C<:unix:encoding(UTF-8)> (or C<:unix:utf8_strict> with #pod L). If L 0.58+ is installed, a #pod unbuffered, raw slurp will be done instead and the result decoded with #pod C. This is just as strict and is roughly an order of #pod magnitude faster than using C<:encoding(UTF-8)>. #pod #pod B: C and friends lock the filehandle before slurping. If #pod you plan to slurp from a file created with L, be sure to #pod close other handles or open without locking to avoid a deadlock: #pod #pod my $tempfile = File::Temp->new(EXLOCK => 0); #pod my $guts = path($tempfile)->slurp; #pod #pod Current API available since 0.004. #pod #pod =cut sub slurp { my $self = shift; my $args = _get_args( shift, qw/binmode/ ); my $binmode = $args->{binmode}; $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode; my $fh = $self->filehandle( { locked => 1 }, "<", $binmode ); if ( ( defined($binmode) ? $binmode : "" ) eq ":unix" and my $size = -s $fh ) { my $buf; my $rc = read $fh, $buf, $size; # File::Slurp in a nutshell $self->_throw('read') unless defined $rc; return $buf; } else { local $/; my $buf = scalar <$fh>; $self->_throw('read') unless defined $buf; return $buf; } } sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp } sub slurp_utf8 { if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) { return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) ); } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { $_[1] = { binmode => ":unix:utf8_strict" }; goto &slurp; } else { $_[1] = { binmode => ":unix:encoding(UTF-8)" }; goto &slurp; } } #pod =method spew, spew_raw, spew_utf8 #pod #pod path("foo.txt")->spew(@data); #pod path("foo.txt")->spew(\@data); #pod path("foo.txt")->spew({binmode => ":raw"}, @data); #pod path("foo.txt")->spew_raw(@data); #pod path("foo.txt")->spew_utf8(@data); #pod #pod Writes data to a file atomically. The file is written to a temporary file in #pod the same directory, then renamed over the original. An optional hash reference #pod may be used to pass options. The only option is C, which is passed to #pod C on the handle used for writing. #pod #pod C is like C with a C of C<:unix> for a fast, #pod unbuffered, raw write. #pod #pod C is like C with a C of C<:unix:encoding(UTF-8)> #pod (or C<:unix:utf8_strict> with L). If L #pod 0.58+ is installed, a raw, unbuffered spew will be done instead on the data #pod encoded with C. #pod #pod B: because the file is written to a temporary file and then renamed, the #pod new file will wind up with permissions based on your current umask. This is a #pod feature to protect you from a race condition that would otherwise give #pod different permissions than you might expect. If you really want to keep the #pod original mode flags, use L with the C option. #pod #pod Current API available since 0.011. #pod #pod =cut sub spew { my ( $self, @data ) = @_; my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {}; $args = _get_args( $args, qw/binmode/ ); my $binmode = $args->{binmode}; # get default binmode from caller's lexical scope (see "perldoc open") $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode; # writing needs to follow the link and create the tempfile in the same # dir for later atomic rename my $resolved_path = $self->_resolve_symlinks; my $temp = $resolved_path->_replacment_path; my $fh; my $ok = eval { $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode ); 1 }; if (!$ok) { my $msg = ref($@) eq 'Path::Tiny::Error' ? "error opening temp file '$@->{file}' for atomic write: $@->{err}" : "error opening temp file for atomic write: $@"; $self->_throw('spew', $self->[PATH], $msg); } print( {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data) or self->_throw('print', $temp->[PATH]); close $fh or $self->_throw( 'close', $temp->[PATH] ); return $temp->move($resolved_path); } sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew } sub spew_utf8 { if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) { my $self = shift; spew( $self, { binmode => ":unix" }, map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_ ); } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { splice @_, 1, 0, { binmode => ":unix:utf8_strict" }; goto &spew; } else { splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" }; goto &spew; } } #pod =method stat, lstat #pod #pod $stat = path("foo.txt")->stat; #pod $stat = path("/some/symlink")->lstat; #pod #pod Like calling C or C from L. #pod #pod Current API available since 0.001. #pod #pod =cut # XXX break out individual stat() components as subs? sub stat { my $self = shift; require File::stat; return File::stat::stat( $self->[PATH] ) || $self->_throw('stat'); } sub lstat { my $self = shift; require File::stat; return File::stat::lstat( $self->[PATH] ) || $self->_throw('lstat'); } #pod =method stringify #pod #pod $path = path("foo.txt"); #pod say $path->stringify; # same as "$path" #pod #pod Returns a string representation of the path. Unlike C, this method #pod returns the path standardized with Unix-style C> directory separators. #pod #pod Current API available since 0.001. #pod #pod =cut sub stringify { $_[0]->[PATH] =~ /^~/ ? './' . $_[0]->[PATH] : $_[0]->[PATH] } #pod =method subsumes #pod #pod path("foo/bar")->subsumes("foo/bar/baz"); # true #pod path("/foo/bar")->subsumes("/foo/baz"); # false #pod #pod Returns true if the first path is a prefix of the second path at a directory #pod boundary. #pod #pod This B resolve parent directory entries (C<..>) or symlinks: #pod #pod path("foo/bar")->subsumes("foo/bar/../baz"); # true #pod #pod If such things are important to you, ensure that both paths are resolved to #pod the filesystem with C: #pod #pod my $p1 = path("foo/bar")->realpath; #pod my $p2 = path("foo/bar/../baz")->realpath; #pod if ( $p1->subsumes($p2) ) { ... } #pod #pod Current API available since 0.048. #pod #pod =cut sub subsumes { my $self = shift; Carp::croak("subsumes() requires a defined, positive-length argument") unless defined $_[0]; my $other = _path(shift); # normalize absolute vs relative if ( $self->is_absolute && !$other->is_absolute ) { $other = $other->absolute; } elsif ( $other->is_absolute && !$self->is_absolute ) { $self = $self->absolute; } # normalize volume vs non-volume; do this after absolute path # adjustments above since that might add volumes already if ( length $self->volume && !length $other->volume ) { $other = $other->absolute; } elsif ( length $other->volume && !length $self->volume ) { $self = $self->absolute; } if ( $self->[PATH] eq '.' ) { return !!1; # cwd subsumes everything relative } elsif ( $self->is_rootdir ) { # a root directory ("/", "c:/") already ends with a separator return $other->[PATH] =~ m{^\Q$self->[PATH]\E}; } else { # exact match or prefix breaking at a separator return $other->[PATH] =~ m{^\Q$self->[PATH]\E(?:/|\z)}; } } #pod =method touch #pod #pod path("foo.txt")->touch; #pod path("foo.txt")->touch($epoch_secs); #pod #pod Like the Unix C utility. Creates the file if it doesn't exist, or else #pod changes the modification and access times to the current time. If the first #pod argument is the epoch seconds then it will be used. #pod #pod Returns the path object so it can be easily chained with other methods: #pod #pod # won't die if foo.txt doesn't exist #pod $content = path("foo.txt")->touch->slurp; #pod #pod Current API available since 0.015. #pod #pod =cut sub touch { my ( $self, $epoch ) = @_; if ( !-e $self->[PATH] ) { my $fh = $self->openw; close $fh or $self->_throw('close'); } if ( defined $epoch ) { utime $epoch, $epoch, $self->[PATH] or $self->_throw("utime ($epoch)"); } else { # literal undef prevents warnings :-( utime undef, undef, $self->[PATH] or $self->_throw("utime ()"); } return $self; } #pod =method touchpath #pod #pod path("bar/baz/foo.txt")->touchpath; #pod #pod Combines C and C. Creates the parent directory if it doesn't exist, #pod before touching the file. Returns the path object like C does. #pod #pod If you need to pass options, use C and C separately: #pod #pod path("bar/baz")->mkdir( \%options )->child("foo.txt")->touch($epoch_secs); #pod #pod Current API available since 0.022. #pod #pod =cut sub touchpath { my ($self) = @_; my $parent = $self->parent; $parent->mkdir unless $parent->exists; $self->touch; } #pod =method visit #pod #pod path("/tmp")->visit( \&callback, \%options ); #pod #pod Executes a callback for each child of a directory. It returns a hash #pod reference with any state accumulated during iteration. #pod #pod The options are the same as for L (which it uses internally): #pod C and C. Both default to false. #pod #pod The callback function will receive a C object as the first argument #pod and a hash reference to accumulate state as the second argument. For example: #pod #pod # collect files sizes #pod my $sizes = path("/tmp")->visit( #pod sub { #pod my ($path, $state) = @_; #pod return if $path->is_dir; #pod $state->{$path} = -s $path; #pod }, #pod { recurse => 1 } #pod ); #pod #pod For convenience, the C object will also be locally aliased as the #pod C<$_> global variable: #pod #pod # print paths matching /foo/ #pod path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} ); #pod #pod If the callback returns a B to a false scalar value, iteration will #pod terminate. This is not the same as "pruning" a directory search; this just #pod stops all iteration and returns the state hash reference. #pod #pod # find up to 10 files larger than 100K #pod my $files = path("/tmp")->visit( #pod sub { #pod my ($path, $state) = @_; #pod $state->{$path}++ if -s $path > 102400 #pod return \0 if keys %$state == 10; #pod }, #pod { recurse => 1 } #pod ); #pod #pod If you want more flexible iteration, use a module like L. #pod #pod Current API available since 0.062. #pod #pod =cut sub visit { my $self = shift; my $cb = shift; my $args = _get_args( shift, qw/recurse follow_symlinks/ ); Carp::croak("Callback for visit() must be a code reference") unless defined($cb) && ref($cb) eq 'CODE'; my $next = $self->iterator($args); my $state = {}; while ( my $file = $next->() ) { local $_ = $file; my $r = $cb->( $file, $state ); last if ref($r) eq 'SCALAR' && !$$r; } return $state; } #pod =method volume #pod #pod $vol = path("/tmp/foo.txt")->volume; # "" #pod $vol = path("C:/tmp/foo.txt")->volume; # "C:" #pod #pod Returns the volume portion of the path. This is equivalent #pod to what L would give from C and thus #pod usually is the empty string on Unix-like operating systems or the #pod drive letter for an absolute path on C. #pod #pod Current API available since 0.001. #pod #pod =cut sub volume { my ($self) = @_; $self->_splitpath unless defined $self->[VOL]; return $self->[VOL]; } package Path::Tiny::Error; our @CARP_NOT = qw/Path::Tiny/; use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 ); sub throw { my ( $class, $op, $file, $err ) = @_; chomp( my $trace = Carp::shortmess ); my $msg = "Error $op on '$file': $err$trace\n"; die bless { op => $op, file => $file, err => $err, msg => $msg }, $class; } 1; # vim: ts=4 sts=4 sw=4 et: __END__ =pod =encoding UTF-8 =head1 NAME Path::Tiny - File path utility =head1 VERSION version 0.146 =head1 SYNOPSIS use Path::Tiny; # Creating Path::Tiny objects my $dir = path("/tmp"); my $foo = path("foo.txt"); my $subdir = $dir->child("foo"); my $bar = $subdir->child("bar.txt"); # Stringifies as cleaned up path my $file = path("./foo.txt"); print $file; # "foo.txt" # Reading files my $guts = $file->slurp; $guts = $file->slurp_utf8; my @lines = $file->lines; @lines = $file->lines_utf8; my ($head) = $file->lines( {count => 1} ); my ($tail) = $file->lines( {count => -1} ); # Writing files $bar->spew( @data ); $bar->spew_utf8( @data ); # Reading directories for ( $dir->children ) { ... } my $iter = $dir->iterator; while ( my $next = $iter->() ) { ... } =head1 DESCRIPTION This module provides a small, fast utility for working with file paths. It is friendlier to use than L and provides easy access to functions from several other core file handling modules. It aims to be smaller and faster than many alternatives on CPAN, while helping people do many common things in consistent and less error-prone ways. Path::Tiny does not try to work for anything except Unix-like and Win32 platforms. Even then, it might break if you try something particularly obscure or tortuous. (Quick! What does this mean: C<< ///../../..//./././a//b/.././c/././ >>? And how does it differ on Win32?) All paths are forced to have Unix-style forward slashes. Stringifying the object gives you back the path (after some clean up). File input/output methods C handles before reading or writing, as appropriate (if supported by the platform and/or filesystem). The C<*_utf8> methods (C, C, etc.) operate in raw mode. On Windows, that means they will not have CRLF translation from the C<:crlf> IO layer. Installing L 0.58 or later will speed up C<*_utf8> situations in many cases and is highly recommended. Alternatively, installing L 0.003 or later will be used in place of the default C<:encoding(UTF-8)>. This module depends heavily on PerlIO layers for correct operation and thus requires Perl 5.008001 or later. =head1 CONSTRUCTORS =head2 path $path = path("foo/bar"); $path = path("/tmp", "file.txt"); # list $path = path("."); # cwd Constructs a C object. It doesn't matter if you give a file or directory path. It's still up to you to call directory-like methods only on directories and file-like methods only on files. This function is exported automatically by default. The first argument must be defined and have non-zero length or an exception will be thrown. This prevents subtle, dangerous errors with code like C<< path( maybe_undef() )->remove_tree >>. B: If and only if the B character of the B argument to C is a tilde ('~'), then tilde replacement will be applied to the first path segment. A single tilde will be replaced with C and a tilde followed by a username will be replaced with output of C. B. See L for more. On Windows, if the path consists of a drive identifier without a path component (C or C), it will be expanded to the absolute path of the current directory on that volume using C. If called with a single C argument, the original is returned unless the original is holding a temporary file or directory reference in which case a stringified copy is made. $path = path("foo/bar"); $temp = Path::Tiny->tempfile; $p2 = path($path); # like $p2 = $path $t2 = path($temp); # like $t2 = path( "$temp" ) This optimizes copies without proliferating references unexpectedly if a copy is made by code outside your control. Current API available since 0.017. =head2 new $path = Path::Tiny->new("foo/bar"); This is just like C, but with method call overhead. (Why would you do that?) Current API available since 0.001. =head2 cwd $path = Path::Tiny->cwd; # path( Cwd::getcwd ) $path = cwd; # optional export Gives you the absolute path to the current directory as a C object. This is slightly faster than C<< path(".")->absolute >>. C may be exported on request and used as a function instead of as a method. Current API available since 0.018. =head2 rootdir $path = Path::Tiny->rootdir; # / $path = rootdir; # optional export Gives you C<< File::Spec->rootdir >> as a C object if you're too picky for C. C may be exported on request and used as a function instead of as a method. Current API available since 0.018. =head2 tempfile, tempdir $temp = Path::Tiny->tempfile( @options ); $temp = Path::Tiny->tempdir( @options ); $temp = $dirpath->tempfile( @options ); $temp = $dirpath->tempdir( @options ); $temp = tempfile( @options ); # optional export $temp = tempdir( @options ); # optional export C passes the options to C<< File::Temp->new >> and returns a C object with the file name. The C option will be enabled by default, but you can override that by passing C<< TMPDIR => 0 >> along with the options. (If you use an absolute C option, you will want to disable C.) The resulting C object is cached. When the C object is destroyed, the C object will be as well. C annoyingly requires you to specify a custom template in slightly different ways depending on which function or method you call, but C lets you ignore that and can take either a leading template or a C option and does the right thing. $temp = Path::Tiny->tempfile( "customXXXXXXXX" ); # ok $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok The tempfile path object will be normalized to have an absolute path, even if created in a relative directory using C. If you want it to have the C instead, pass a leading options hash like this: $real_temp = tempfile({realpath => 1}, @options); C is just like C, except it calls C<< File::Temp->newdir >> instead. Both C and C may be exported on request and used as functions instead of as methods. The methods can be called on an instances representing a directory. In this case, the directory is used as the base to create the temporary file/directory, setting the C option in File::Temp. my $target_dir = path('/to/destination'); my $tempfile = $target_dir->tempfile('foobarXXXXXX'); $tempfile->spew('A lot of data...'); # not atomic $tempfile->move($target_dir->child('foobar')); # hopefully atomic In this case, any value set for option C is ignored. B: for tempfiles, the filehandles from File::Temp are closed and not reused. This is not as secure as using File::Temp handles directly, but is less prone to deadlocks or access problems on some platforms. Think of what C gives you to be just a temporary file B that gets cleaned up. B: if you don't want these cleaned up automatically when the object is destroyed, File::Temp requires different options for directories and files. Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for files. B: Don't lose the temporary object by chaining a method call instead of storing it: my $lost = tempdir()->child("foo"); # tempdir cleaned up right away B: The cached object may be accessed with the L method. Keeping a reference to, or modifying the cached object may break the behavior documented above and is not supported. Use at your own risk. Current API available since 0.119. =head1 METHODS =head2 absolute $abs = path("foo/bar")->absolute; $abs = path("foo/bar")->absolute("/tmp"); Returns a new C object with an absolute path (or itself if already absolute). If no argument is given, the current directory is used as the absolute base path. If an argument is given, it will be converted to an absolute path (if it is not already) and used as the absolute base path. This will not resolve upward directories ("foo/../bar") unless C in L would normally do so on your platform. If you need them resolved, you must call the more expensive C method instead. On Windows, an absolute path without a volume component will have it added based on the current drive. Current API available since 0.101. =head2 append, append_raw, append_utf8 path("foo.txt")->append(@data); path("foo.txt")->append(\@data); path("foo.txt")->append({binmode => ":raw"}, @data); path("foo.txt")->append_raw(@data); path("foo.txt")->append_utf8(@data); Appends data to a file. The file is locked with C