use 5.008001; use strict; use warnings; package Path::Tiny; # ABSTRACT: File path utility our $VERSION = '0.144'; # Dependencies use Config; use Exporter 5.57 (qw/import/); use File::Spec 0.86 (); # shipped with 5.8.1 use Carp (); our @EXPORT = qw/path/; our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/; use constant { PATH => 0, CANON => 1, VOL => 2, DIR => 3, FILE => 4, TEMP => 5, IS_WIN32 => ( $^O eq 'MSWin32' ), }; use overload ( q{""} => 'stringify', bool => sub () { 1 }, fallback => 1, ); # FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol sub THAW { return path( $_[2] ) } { no warnings 'once'; *TO_JSON = *FREEZE = \&stringify }; my $HAS_UU; # has Unicode::UTF8; lazily populated sub _check_UU { local $SIG{__DIE__}; # prevent outer handler from being called !!eval { require Unicode::UTF8; Unicode::UTF8->VERSION(0.58); 1; }; } my $HAS_PU; # has PerlIO::utf8_strict; lazily populated sub _check_PU { local $SIG{__DIE__}; # prevent outer handler from being called !!eval { # MUST preload Encode or $SIG{__DIE__} localization fails # on some Perl 5.8.8 (maybe other 5.8.*) compiled with -O2. require Encode; require PerlIO::utf8_strict; PerlIO::utf8_strict->VERSION(0.003); 1; }; } my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf}; # notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \ my $SLASH = qr{[\\/]}; my $NOTSLASH = qr{[^\\/]}; my $DRV_VOL = qr{[a-z]:}i; my $UNC_VOL = qr{$SLASH $SLASH $NOTSLASH+ $SLASH $NOTSLASH+}x; my $WIN32_ROOT = qr{(?: $UNC_VOL $SLASH | $DRV_VOL $SLASH | $SLASH )}x; sub _win32_vol { my ( $path, $drv ) = @_; require Cwd; my $dcwd = eval { Cwd::getdcwd($drv) }; # C: -> C:\some\cwd # getdcwd on non-existent drive returns empty string # so just use the original drive Z: -> Z: $dcwd = "$drv" unless defined $dcwd && length $dcwd; # normalize dwcd to end with a slash: might be C:\some\cwd or D:\ or Z: $dcwd =~ s{$SLASH?\z}{/}; # make the path absolute with dcwd $path =~ s{^$DRV_VOL}{$dcwd}; return $path; } # This is a string test for before we have the object; see is_rootdir for well-formed # object test sub _is_root { return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' ); } BEGIN { *_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] }; } # mode bits encoded for chmod in symbolic mode my %MODEBITS = ( om => 0007, gm => 0070, um => 0700 ); ## no critic { my $m = 0; $MODEBITS{$_} = ( 1 << $m++ ) for qw/ox ow or gx gw gr ux uw ur/ }; sub _symbolic_chmod { my ( $mode, $symbolic ) = @_; for my $clause ( split /,\s*/, $symbolic ) { if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) { my ( $who, $action, $perms ) = ( $1, $2, $3 ); $who =~ s/a/ugo/g; for my $w ( split //, $who ) { my $p = 0; $p |= $MODEBITS{"$w$_"} for split //, $perms; if ( $action eq '=' ) { $mode = ( $mode & ~$MODEBITS{"${w}m"} ) | $p; } else { $mode = $action eq "+" ? ( $mode | $p ) : ( $mode & ~$p ); } } } else { Carp::croak("Invalid mode clause '$clause' for chmod()"); } } return $mode; } # flock doesn't work on NFS on BSD or on some filesystems like lustre. # Since program authors often can't control or detect that, we warn once # instead of being fatal if we can detect it and people who need it strict # can fatalize the 'flock' category #<<< No perltidy { package flock; use warnings::register } #>>> my $WARNED_NO_FLOCK = 0; sub _throw { my ( $self, $function, $file, $msg ) = @_; if ( $function =~ /^flock/ && $! =~ /operation not supported|function not implemented/i && !warnings::fatal_enabled('flock') ) { if ( !$WARNED_NO_FLOCK ) { warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" ); $WARNED_NO_FLOCK++; } } else { $msg = $! unless defined $msg; Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ), $msg ); } return; } # cheapo option validation sub _get_args { my ( $raw, @valid ) = @_; if ( defined($raw) && ref($raw) ne 'HASH' ) { my ( undef, undef, undef, $called_as ) = caller(1); $called_as =~ s{^.*::}{}; Carp::croak("Options for $called_as must be a hash reference"); } my $cooked = {}; for my $k (@valid) { $cooked->{$k} = delete $raw->{$k} if exists $raw->{$k}; } if ( keys %$raw ) { my ( undef, undef, undef, $called_as ) = caller(1); $called_as =~ s{^.*::}{}; Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) ); } return $cooked; } #--------------------------------------------------------------------------# # Constructors #--------------------------------------------------------------------------# #pod =construct path #pod #pod $path = path("foo/bar"); #pod $path = path("/tmp", "file.txt"); # list #pod $path = path("."); # cwd #pod #pod Constructs a C object. It doesn't matter if you give a file or #pod directory path. It's still up to you to call directory-like methods only on #pod directories and file-like methods only on files. This function is exported #pod automatically by default. #pod #pod The first argument must be defined and have non-zero length or an exception #pod will be thrown. This prevents subtle, dangerous errors with code like #pod C<< path( maybe_undef() )->remove_tree >>. #pod #pod B: If and only if the B character of the B argument #pod to C is a tilde ('~'), then tilde replacement will be applied to the #pod first path segment. A single tilde will be replaced with C and a #pod tilde followed by a username will be replaced with output of #pod C. B. #pod See L for more. #pod #pod On Windows, if the path consists of a drive identifier without a path component #pod (C or C), it will be expanded to the absolute path of the current #pod directory on that volume using C. #pod #pod If called with a single C argument, the original is returned unless #pod the original is holding a temporary file or directory reference in which case a #pod stringified copy is made. #pod #pod $path = path("foo/bar"); #pod $temp = Path::Tiny->tempfile; #pod #pod $p2 = path($path); # like $p2 = $path #pod $t2 = path($temp); # like $t2 = path( "$temp" ) #pod #pod This optimizes copies without proliferating references unexpectedly if a copy is #pod made by code outside your control. #pod #pod Current API available since 0.017. #pod #pod =cut sub path { my $path = shift; Carp::croak("Path::Tiny paths require defined, positive-length parts") unless 1 + @_ == grep { defined && length } $path, @_; # non-temp Path::Tiny objects are effectively immutable and can be reused if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) { return $path; } # stringify objects $path = "$path"; # do any tilde expansions my ($tilde) = $path =~ m{^(~[^/]*)}; if ( defined $tilde ) { # Escape File::Glob metacharacters (my $escaped = $tilde) =~ s/([\[\{\*\?\\])/\\$1/g; require File::Glob; my ($homedir) = File::Glob::bsd_glob($escaped); if (defined $homedir && ! $File::Glob::ERROR) { $homedir =~ tr[\\][/] if IS_WIN32(); $path =~ s{^\Q$tilde\E}{$homedir}; } } unshift @_, $path; goto &_pathify; } # _path is like path but without tilde expansion sub _path { my $path = shift; Carp::croak("Path::Tiny paths require defined, positive-length parts") unless 1 + @_ == grep { defined && length } $path, @_; # non-temp Path::Tiny objects are effectively immutable and can be reused if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) { return $path; } # stringify objects $path = "$path"; unshift @_, $path; goto &_pathify; } # _pathify expects one or more string arguments, then joins and canonicalizes # them into an object. sub _pathify { my $path = shift; # expand relative volume paths on windows; put trailing slash on UNC root if ( IS_WIN32() ) { $path = _win32_vol( $path, $1 ) if $path =~ m{^($DRV_VOL)(?:$NOTSLASH|\z)}; $path .= "/" if $path =~ m{^$UNC_VOL\z}; } # concatenations stringifies objects, too if (@_) { $path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ ); } # canonicalize, but with unix slashes and put back trailing volume slash my $cpath = $path = File::Spec->canonpath($path); $path =~ tr[\\][/] if IS_WIN32(); $path = "/" if $path eq '/..'; # for old File::Spec $path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL\z}; # root paths must always have a trailing slash, but other paths must not if ( _is_root($path) ) { $path =~ s{/?\z}{/}; } else { $path =~ s{/\z}{}; } bless [ $path, $cpath ], __PACKAGE__; } #pod =construct new #pod #pod $path = Path::Tiny->new("foo/bar"); #pod #pod This is just like C, but with method call overhead. (Why would you #pod do that?) #pod #pod Current API available since 0.001. #pod #pod =cut sub new { shift; path(@_) } #pod =construct cwd #pod #pod $path = Path::Tiny->cwd; # path( Cwd::getcwd ) #pod $path = cwd; # optional export #pod #pod Gives you the absolute path to the current directory as a C object. #pod This is slightly faster than C<< path(".")->absolute >>. #pod #pod C may be exported on request and used as a function instead of as a #pod method. #pod #pod Current API available since 0.018. #pod #pod =cut sub cwd { require Cwd; return _path( Cwd::getcwd() ); } #pod =construct rootdir #pod #pod $path = Path::Tiny->rootdir; # / #pod $path = rootdir; # optional export #pod #pod Gives you C<< File::Spec->rootdir >> as a C object if you're too #pod picky for C. #pod #pod C may be exported on request and used as a function instead of as a #pod method. #pod #pod Current API available since 0.018. #pod #pod =cut sub rootdir { _path( File::Spec->rootdir ) } #pod =construct tempfile, tempdir #pod #pod $temp = Path::Tiny->tempfile( @options ); #pod $temp = Path::Tiny->tempdir( @options ); #pod $temp = $dirpath->tempfile( @options ); #pod $temp = $dirpath->tempdir( @options ); #pod $temp = tempfile( @options ); # optional export #pod $temp = tempdir( @options ); # optional export #pod #pod C passes the options to C<< File::Temp->new >> and returns a #pod C object with the file name. The C option will be enabled #pod by default, but you can override that by passing C<< TMPDIR => 0 >> along with #pod the options. (If you use an absolute C