diff options
Diffstat (limited to 'linux-x86/lib/perl-base/File/Path.pm')
-rw-r--r-- | linux-x86/lib/perl-base/File/Path.pm | 583 |
1 files changed, 0 insertions, 583 deletions
diff --git a/linux-x86/lib/perl-base/File/Path.pm b/linux-x86/lib/perl-base/File/Path.pm deleted file mode 100644 index b9a4fb3..0000000 --- a/linux-x86/lib/perl-base/File/Path.pm +++ /dev/null @@ -1,583 +0,0 @@ -package File::Path; - -use 5.005_04; -use strict; - -use Cwd 'getcwd'; -use File::Basename (); -use File::Spec (); - -BEGIN { - if ( $] < 5.006 ) { - - # can't say 'opendir my $dh, $dirname' - # need to initialise $dh - eval 'use Symbol'; - } -} - -use Exporter (); -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = '2.12_01'; -$VERSION = eval $VERSION; -@ISA = qw(Exporter); -@EXPORT = qw(mkpath rmtree); -@EXPORT_OK = qw(make_path remove_tree); - -BEGIN { - for (qw(VMS MacOS MSWin32 os2)) { - no strict 'refs'; - *{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 }; - } - - # These OSes complain if you want to remove a file that you have no - # write permission to: - *_FORCE_WRITABLE = ( - grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2) - ) ? sub () { 1 } : sub () { 0 }; - - # Unix-like systems need to stat each directory in order to detect - # race condition. MS-Windows is immune to this particular attack. - *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 }; -} - -sub _carp { - require Carp; - goto &Carp::carp; -} - -sub _croak { - require Carp; - goto &Carp::croak; -} - -sub _error { - my $arg = shift; - my $message = shift; - my $object = shift; - - if ( $arg->{error} ) { - $object = '' unless defined $object; - $message .= ": $!" if $!; - push @{ ${ $arg->{error} } }, { $object => $message }; - } - else { - _carp( defined($object) ? "$message for $object: $!" : "$message: $!" ); - } -} - -sub __is_arg { - my ($arg) = @_; - - # If client code blessed an array ref to HASH, this will not work - # properly. We could have done $arg->isa() wrapped in eval, but - # that would be expensive. This implementation should suffice. - # We could have also used Scalar::Util:blessed, but we choose not - # to add this dependency - return ( ref $arg eq 'HASH' ); -} - -sub make_path { - push @_, {} unless @_ and __is_arg( $_[-1] ); - goto &mkpath; -} - -sub mkpath { - my $old_style = !( @_ and __is_arg( $_[-1] ) ); - - my $arg; - my $paths; - - if ($old_style) { - my ( $verbose, $mode ); - ( $paths, $verbose, $mode ) = @_; - $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' ); - $arg->{verbose} = $verbose; - $arg->{mode} = defined $mode ? $mode : oct '777'; - } - else { - my %args_permitted = map { $_ => 1 } ( qw| - chmod - error - group - mask - mode - owner - uid - user - verbose - | ); - my @bad_args = (); - $arg = pop @_; - for my $k (sort keys %{$arg}) { - push @bad_args, $k unless $args_permitted{$k}; - } - _carp("Unrecognized option(s) passed to make_path(): @bad_args") - if @bad_args; - $arg->{mode} = delete $arg->{mask} if exists $arg->{mask}; - $arg->{mode} = oct '777' unless exists $arg->{mode}; - ${ $arg->{error} } = [] if exists $arg->{error}; - $arg->{owner} = delete $arg->{user} if exists $arg->{user}; - $arg->{owner} = delete $arg->{uid} if exists $arg->{uid}; - if ( exists $arg->{owner} and $arg->{owner} =~ /\D/ ) { - my $uid = ( getpwnam $arg->{owner} )[2]; - if ( defined $uid ) { - $arg->{owner} = $uid; - } - else { - _error( $arg, -"unable to map $arg->{owner} to a uid, ownership not changed" - ); - delete $arg->{owner}; - } - } - if ( exists $arg->{group} and $arg->{group} =~ /\D/ ) { - my $gid = ( getgrnam $arg->{group} )[2]; - if ( defined $gid ) { - $arg->{group} = $gid; - } - else { - _error( $arg, -"unable to map $arg->{group} to a gid, group ownership not changed" - ); - delete $arg->{group}; - } - } - if ( exists $arg->{owner} and not exists $arg->{group} ) { - $arg->{group} = -1; # chown will leave group unchanged - } - if ( exists $arg->{group} and not exists $arg->{owner} ) { - $arg->{owner} = -1; # chown will leave owner unchanged - } - $paths = [@_]; - } - return _mkpath( $arg, $paths ); -} - -sub _mkpath { - my $arg = shift; - my $paths = shift; - - my ( @created ); - foreach my $path ( @{$paths} ) { - next unless defined($path) and length($path); - $path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT - - # Logic wants Unix paths, so go with the flow. - if (_IS_VMS) { - next if $path eq '/'; - $path = VMS::Filespec::unixify($path); - } - next if -d $path; - my $parent = File::Basename::dirname($path); - unless ( -d $parent or $path eq $parent ) { - push( @created, _mkpath( $arg, [$parent] ) ); - } - print "mkdir $path\n" if $arg->{verbose}; - if ( mkdir( $path, $arg->{mode} ) ) { - push( @created, $path ); - if ( exists $arg->{owner} ) { - - # NB: $arg->{group} guaranteed to be set during initialisation - if ( !chown $arg->{owner}, $arg->{group}, $path ) { - _error( $arg, -"Cannot change ownership of $path to $arg->{owner}:$arg->{group}" - ); - } - } - if ( exists $arg->{chmod} ) { - if ( !chmod $arg->{chmod}, $path ) { - _error( $arg, - "Cannot change permissions of $path to $arg->{chmod}" ); - } - } - } - else { - my $save_bang = $!; - my ( $e, $e1 ) = ( $save_bang, $^E ); - $e .= "; $e1" if $e ne $e1; - - # allow for another process to have created it meanwhile - if ( ! -d $path ) { - $! = $save_bang; - if ( $arg->{error} ) { - push @{ ${ $arg->{error} } }, { $path => $e }; - } - else { - _croak("mkdir $path: $e"); - } - } - } - } - return @created; -} - -sub remove_tree { - push @_, {} unless @_ and __is_arg( $_[-1] ); - goto &rmtree; -} - -sub _is_subdir { - my ( $dir, $test ) = @_; - - my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 ); - my ( $tv, $td ) = File::Spec->splitpath( $test, 1 ); - - # not on same volume - return 0 if $dv ne $tv; - - my @d = File::Spec->splitdir($dd); - my @t = File::Spec->splitdir($td); - - # @t can't be a subdir if it's shorter than @d - return 0 if @t < @d; - - return join( '/', @d ) eq join( '/', splice @t, 0, +@d ); -} - -sub rmtree { - my $old_style = !( @_ and __is_arg( $_[-1] ) ); - - my $arg; - my $paths; - - if ($old_style) { - my ( $verbose, $safe ); - ( $paths, $verbose, $safe ) = @_; - $arg->{verbose} = $verbose; - $arg->{safe} = defined $safe ? $safe : 0; - - if ( defined($paths) and length($paths) ) { - $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' ); - } - else { - _carp("No root path(s) specified\n"); - return 0; - } - } - else { - my %args_permitted = map { $_ => 1 } ( qw| - error - keep_root - result - safe - verbose - | ); - my @bad_args = (); - $arg = pop @_; - for my $k (sort keys %{$arg}) { - push @bad_args, $k unless $args_permitted{$k}; - } - _carp("Unrecognized option(s) passed to remove_tree(): @bad_args") - if @bad_args; - ${ $arg->{error} } = [] if exists $arg->{error}; - ${ $arg->{result} } = [] if exists $arg->{result}; - $paths = [@_]; - } - - $arg->{prefix} = ''; - $arg->{depth} = 0; - - my @clean_path; - $arg->{cwd} = getcwd() or do { - _error( $arg, "cannot fetch initial working directory" ); - return 0; - }; - for ( $arg->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint - - for my $p (@$paths) { - - # need to fixup case and map \ to / on Windows - my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p; - my $ortho_cwd = - _IS_MSWIN32 ? _slash_lc( $arg->{cwd} ) : $arg->{cwd}; - my $ortho_root_length = length($ortho_root); - $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']' - if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) { - local $! = 0; - _error( $arg, "cannot remove path when cwd is $arg->{cwd}", $p ); - next; - } - - if (_IS_MACOS) { - $p = ":$p" unless $p =~ /:/; - $p .= ":" unless $p =~ /:\z/; - } - elsif ( _IS_MSWIN32 ) { - $p =~ s{[/\\]\z}{}; - } - else { - $p =~ s{/\z}{}; - } - push @clean_path, $p; - } - - @{$arg}{qw(device inode perm)} = ( lstat $arg->{cwd} )[ 0, 1 ] or do { - _error( $arg, "cannot stat initial working directory", $arg->{cwd} ); - return 0; - }; - - return _rmtree( $arg, \@clean_path ); -} - -sub _rmtree { - my $arg = shift; - my $paths = shift; - - my $count = 0; - my $curdir = File::Spec->curdir(); - my $updir = File::Spec->updir(); - - my ( @files, $root ); - ROOT_DIR: - foreach my $root (@$paths) { - - # since we chdir into each directory, it may not be obvious - # to figure out where we are if we generate a message about - # a file name. We therefore construct a semi-canonical - # filename, anchored from the directory being unlinked (as - # opposed to being truly canonical, anchored from the root (/). - - my $canon = - $arg->{prefix} - ? File::Spec->catfile( $arg->{prefix}, $root ) - : $root; - - my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ] - or next ROOT_DIR; - - if ( -d _ ) { - $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) ) - if _IS_VMS; - - if ( !chdir($root) ) { - - # see if we can escalate privileges to get in - # (e.g. funny protection mask such as -w- instead of rwx) - # This uses fchmod to avoid traversing outside of the proper - # location (CVE-2017-6512) - my $root_fh; - if (open($root_fh, '<', $root)) { - my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1]; - $perm &= oct '7777'; - my $nperm = $perm | oct '700'; - local $@; - if ( - !( - $arg->{safe} - or $nperm == $perm - or !-d _ - or $fh_dev ne $ldev - or $fh_inode ne $lino - or eval { chmod( $nperm, $root_fh ) } - ) - ) - { - _error( $arg, - "cannot make child directory read-write-exec", $canon ); - next ROOT_DIR; - } - close $root_fh; - } - if ( !chdir($root) ) { - _error( $arg, "cannot chdir to child", $canon ); - next ROOT_DIR; - } - } - - my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ] - or do { - _error( $arg, "cannot stat current working directory", $canon ); - next ROOT_DIR; - }; - - if (_NEED_STAT_CHECK) { - ( $ldev eq $cur_dev and $lino eq $cur_inode ) - or _croak( -"directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting." - ); - } - - $perm &= oct '7777'; # don't forget setuid, setgid, sticky bits - my $nperm = $perm | oct '700'; - - # notabene: 0700 is for making readable in the first place, - # it's also intended to change it to writable in case we have - # to recurse in which case we are better than rm -rf for - # subtrees with strange permissions - - if ( - !( - $arg->{safe} - or $nperm == $perm - or chmod( $nperm, $curdir ) - ) - ) - { - _error( $arg, "cannot make directory read+writeable", $canon ); - $nperm = $perm; - } - - my $d; - $d = gensym() if $] < 5.006; - if ( !opendir $d, $curdir ) { - _error( $arg, "cannot opendir", $canon ); - @files = (); - } - else { - if ( !defined ${^TAINT} or ${^TAINT} ) { - # Blindly untaint dir names if taint mode is active - @files = map { /\A(.*)\z/s; $1 } readdir $d; - } - else { - @files = readdir $d; - } - closedir $d; - } - - if (_IS_VMS) { - - # Deleting large numbers of files from VMS Files-11 - # filesystems is faster if done in reverse ASCIIbetical order. - # include '.' to '.;' from blead patch #31775 - @files = map { $_ eq '.' ? '.;' : $_ } reverse @files; - } - - @files = grep { $_ ne $updir and $_ ne $curdir } @files; - - if (@files) { - - # remove the contained files before the directory itself - my $narg = {%$arg}; - @{$narg}{qw(device inode cwd prefix depth)} = - ( $cur_dev, $cur_inode, $updir, $canon, $arg->{depth} + 1 ); - $count += _rmtree( $narg, \@files ); - } - - # restore directory permissions of required now (in case the rmdir - # below fails), while we are still in the directory and may do so - # without a race via '.' - if ( $nperm != $perm and not chmod( $perm, $curdir ) ) { - _error( $arg, "cannot reset chmod", $canon ); - } - - # don't leave the client code in an unexpected directory - chdir( $arg->{cwd} ) - or - _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting."); - - # ensure that a chdir upwards didn't take us somewhere other - # than we expected (see CVE-2002-0435) - ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ] - or _croak( - "cannot stat prior working directory $arg->{cwd}: $!, aborting." - ); - - if (_NEED_STAT_CHECK) { - ( $arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode ) - or _croak( "previous directory $arg->{cwd} " - . "changed before entering $canon, " - . "expected dev=$ldev ino=$lino, " - . "actual dev=$cur_dev ino=$cur_inode, aborting." - ); - } - - if ( $arg->{depth} or !$arg->{keep_root} ) { - if ( $arg->{safe} - && ( _IS_VMS - ? !&VMS::Filespec::candelete($root) - : !-w $root ) ) - { - print "skipped $root\n" if $arg->{verbose}; - next ROOT_DIR; - } - if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) { - _error( $arg, "cannot make directory writeable", $canon ); - } - print "rmdir $root\n" if $arg->{verbose}; - if ( rmdir $root ) { - push @{ ${ $arg->{result} } }, $root if $arg->{result}; - ++$count; - } - else { - _error( $arg, "cannot remove directory", $canon ); - if ( - _FORCE_WRITABLE - && !chmod( $perm, - ( _IS_VMS ? VMS::Filespec::fileify($root) : $root ) - ) - ) - { - _error( - $arg, - sprintf( "cannot restore permissions to 0%o", - $perm ), - $canon - ); - } - } - } - } - else { - # not a directory - $root = VMS::Filespec::vmsify("./$root") - if _IS_VMS - && !File::Spec->file_name_is_absolute($root) - && ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax - - if ( - $arg->{safe} - && ( - _IS_VMS - ? !&VMS::Filespec::candelete($root) - : !( -l $root || -w $root ) - ) - ) - { - print "skipped $root\n" if $arg->{verbose}; - next ROOT_DIR; - } - - my $nperm = $perm & oct '7777' | oct '600'; - if ( _FORCE_WRITABLE - and $nperm != $perm - and not chmod $nperm, $root ) - { - _error( $arg, "cannot make file writeable", $canon ); - } - print "unlink $canon\n" if $arg->{verbose}; - - # delete all versions under VMS - for ( ; ; ) { - if ( unlink $root ) { - push @{ ${ $arg->{result} } }, $root if $arg->{result}; - } - else { - _error( $arg, "cannot unlink file", $canon ); - _FORCE_WRITABLE and chmod( $perm, $root ) - or _error( $arg, - sprintf( "cannot restore permissions to 0%o", $perm ), - $canon ); - last; - } - ++$count; - last unless _IS_VMS && lstat $root; - } - } - } - return $count; -} - -sub _slash_lc { - - # fix up slashes and case on MSWin32 so that we can determine that - # c:\path\to\dir is underneath C:/Path/To - my $path = shift; - $path =~ tr{\\}{/}; - return lc($path); -} - -1; - -__END__ - |