use 5.008001; use strict; use warnings; package Path::Tiny; # ABSTRACT: File path utility our $VERSION = '0.104'; # 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_BSD => ( scalar $^O =~ /bsd$/ ), IS_WIN32 => ( $^O eq 'MSWin32' ), }; use overload ( q{""} => sub { $_[0]->[PATH] }, bool => sub () { 1 }, fallback => 1, ); # FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol sub FREEZE { return $_[0]->[PATH] } sub THAW { return path( $_[2] ) } { no warnings 'once'; *TO_JSON = *FREEZE }; my $HAS_UU; # has Unicode::UTF8; lazily populated sub _check_UU { !!eval { require Unicode::UTF8; Unicode::UTF8->VERSION(0.58); 1 }; } my $HAS_PU; # has PerlIO::utf8_strict; lazily populated sub _check_PU { !!eval { 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?$}{/}; # 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$/ ) : ( $_[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. 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 if Path::Tiny::IS_BSD(), 'warnings::register' } #>>> my $WARNED_BSD_NFS = 0; sub _throw { my ( $self, $function, $file, $msg ) = @_; if ( IS_BSD() && $function =~ /^flock/ && $! =~ /operation not supported/i && !warnings::fatal_enabled('flock') ) { if ( !$WARNED_BSD_NFS ) { warnings::warn( flock => "No flock for NFS on BSD: continuing in unsafe mode" ); $WARNED_BSD_NFS++; } } 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 $path = path("~user/file.txt"); # tilde processing #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 If the first component of the path is a tilde ('~') then the component will be #pod replaced with the output of C. If the first component of the path #pod is a tilde followed by a user name then the component will be replaced with #pod output of C. Behaviour for non-existent users depends on #pod the output of C on the system. #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"; # 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|$)}; $path .= "/" if $path =~ m{^$UNC_VOL$}; } # 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$}; # root paths must always have a trailing slash, but other paths must not if ( _is_root($path) ) { $path =~ s{/?$}{/}; } else { $path =~ s{/$}{}; } # do any tilde expansions if ( $path =~ m{^(~[^/]*).*} ) { require File::Glob; my ($homedir) = File::Glob::bsd_glob($1); $homedir =~ tr[\\][/] if IS_WIN32(); $path =~ s{^(~[^/]*)}{$homedir}; } 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 = tempfile( @options ); # optional export #pod $temp = tempdir( @options ); # optional export #pod #pod C passes the options to C<< File::Temp->new >> and returns a C #pod object with the file name. The C option is enabled by default. #pod #pod The resulting C object is cached. When the C object is #pod destroyed, the C object will be as well. #pod #pod C annoyingly requires you to specify a custom template in slightly #pod different ways depending on which function or method you call, but #pod C lets you ignore that and can take either a leading template or a #pod C