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