1# -*- cperl -*- 2# Copyright (c) 2007, 2021, Oracle and/or its affiliates. 3# Use is subject to license terms. 4# 5# This program is free software; you can redistribute it and/or modify 6# it under the terms of the GNU General Public License, version 2.0, 7# as published by the Free Software Foundation. 8# 9# This program is also distributed with certain software (including 10# but not limited to OpenSSL) that is licensed under separate terms, 11# as designated in a particular file or component or in included license 12# documentation. The authors of MySQL hereby grant you an additional 13# permission to link the program and your derivative works with the 14# separately licensed software that they have included with MySQL. 15# 16# This program is distributed in the hope that it will be useful, 17# but WITHOUT ANY WARRANTY; without even the implied warranty of 18# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19# GNU General Public License, version 2.0, for more details. 20# 21# You should have received a copy of the GNU General Public License 22# along with this program; if not, write to the Free Software 23# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 24 25package My::File::Path; 26use strict; 27 28 29# 30# File::Path::rmtree has a problem with deleting files 31# and directories where it hasn't got read permission 32# 33# Patch this by installing a 'rmtree' function in local 34# scope that first chmod all files to 0777 before calling 35# the original rmtree function. 36# 37# This is almost gone in version 1.08 of File::Path - 38# but unfortunately some hosts still suffers 39# from this also in 1.08 40# 41 42use Exporter; 43use base "Exporter"; 44our @EXPORT= qw / rmtree mkpath copytree /; 45 46use File::Find; 47use File::Copy; 48use File::Spec; 49use Carp; 50use My::Handles; 51use My::Platform; 52 53sub rmtree { 54 my ($dir)= @_; 55 find( { 56 bydepth => 1, 57 no_chdir => 1, 58 wanted => sub { 59 my $name= $_; 60 if (!-l $name && -d _){ 61 return if (rmdir($name) == 1); 62 63 chmod(0777, $name) or carp("couldn't chmod(0777, $name): $!"); 64 65 return if (rmdir($name) == 1); 66 67 # Failed to remove the directory, analyze 68 carp("Couldn't remove directory '$name': $!"); 69 My::Handles::show_handles($name); 70 } else { 71 return if (unlink($name) == 1); 72 73 chmod(0777, $name) or carp("couldn't chmod(0777, $name): $!"); 74 75 return if (unlink($name) == 1); 76 77 carp("Couldn't delete file '$name': $!"); 78 My::Handles::show_handles($name); 79 } 80 } 81 }, $dir ); 82}; 83 84 85use File::Basename; 86sub _mkpath_debug { 87 my ($message, $path, $dir, $err)= @_; 88 89 print "=" x 40, "\n"; 90 print $message, "\n"; 91 print "err: '$err'\n"; 92 print "path: '$path'\n"; 93 print "dir: '$dir'\n"; 94 95 print "-" x 40, "\n"; 96 my $dirname= dirname($path); 97 print "ls -l $dirname\n"; 98 print `ls -l $dirname`, "\n"; 99 print "-" x 40, "\n"; 100 print "dir $dirname\n"; 101 print `dir $dirname`, "\n"; 102 print "-" x 40, "\n"; 103 my $dirname2= dirname($dirname); 104 print "ls -l $dirname2\n"; 105 print `ls -l $dirname2`, "\n"; 106 print "-" x 40, "\n"; 107 print "dir $dirname2\n"; 108 print `dir $dirname2`, "\n"; 109 print "-" x 40, "\n"; 110 print "file exists\n" if (-e $path); 111 print "file is a plain file\n" if (-f $path); 112 print "file is a directory\n" if (-d $path); 113 print "-" x 40, "\n"; 114 print "showing handles for $path\n"; 115 My::Handles::show_handles($path); 116 117 print "=" x 40, "\n"; 118 119} 120 121 122sub mkpath { 123 my $path; 124 125 die "Usage: mkpath(<path>)" unless @_ == 1; 126 127 foreach my $dir ( File::Spec->splitdir( @_ ) ) { 128 #print "dir: $dir\n"; 129 if ($dir =~ /^[a-z]:/i){ 130 # Found volume ie. C: 131 $path= $dir; 132 next; 133 } 134 135 $path= File::Spec->catdir($path, $dir); 136 #print "path: $path\n"; 137 138 next if -d $path; # Path already exists and is a directory 139 croak("File already exists but is not a directory: '$path'") if -e $path; 140 next if mkdir($path); 141 _mkpath_debug("mkdir failed", $path, $dir, $!); 142 143 # mkdir failed, try one more time 144 next if mkdir($path); 145 _mkpath_debug("mkdir failed, second time", $path, $dir, $!); 146 147 # mkdir failed again, try two more time after sleep(s) 148 sleep(1); 149 next if mkdir($path); 150 _mkpath_debug("mkdir failed, third time", $path, $dir, $!); 151 152 sleep(1); 153 next if mkdir($path); 154 _mkpath_debug("mkdir failed, fourth time", $path, $dir, $!); 155 156 # Report failure and die 157 croak("Couldn't create directory '$path' ", 158 " after 4 attempts and 2 sleep(1): $!"); 159 } 160}; 161 162 163sub copytree { 164 my ($from_dir, $to_dir, $use_umask) = @_; 165 166 die "Usage: copytree(<fromdir>, <todir>, [<umask>])" 167 unless @_ == 2 or @_ == 3; 168 169 my $orig_umask; 170 if ($use_umask){ 171 # Set new umask and remember the original 172 $orig_umask= umask(oct($use_umask)); 173 } 174 175 mkpath("$to_dir"); 176 opendir(DIR, "$from_dir") 177 or croak("Can't find $from_dir$!"); 178 for(readdir(DIR)) { 179 180 next if "$_" eq "." or "$_" eq ".."; 181 182 # Skip SCCS/ directories 183 next if "$_" eq "SCCS"; 184 185 if ( -d "$from_dir/$_" ) 186 { 187 copytree("$from_dir/$_", "$to_dir/$_"); 188 next; 189 } 190 191 # Only copy plain files 192 next unless -f "$from_dir/$_"; 193 copy("$from_dir/$_", "$to_dir/$_"); 194 } 195 closedir(DIR); 196 197 if ($orig_umask){ 198 # Set the original umask 199 umask($orig_umask); 200 } 201} 202 2031; 204