1# -*- cperl -*- 2# Copyright (c) 2004, 2010, Oracle and/or its affiliates. All rights reserved. 3# 4# This program is free software; you can redistribute it and/or modify 5# it under the terms of the GNU General Public License, version 2.0, 6# as published by the Free Software Foundation. 7# 8# This program is also distributed with certain software (including 9# but not limited to OpenSSL) that is licensed under separate terms, 10# as designated in a particular file or component or in included license 11# documentation. The authors of MySQL hereby grant you an additional 12# permission to link the program and your derivative works with the 13# separately licensed software that they have included with MySQL. 14# 15# This program is distributed in the hope that it will be useful, 16# but WITHOUT ANY WARRANTY; without even the implied warranty of 17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18# GNU General Public License, version 2.0, for more details. 19# 20# You should have received a copy of the GNU General Public License 21# along with this program; if not, write to the Free Software 22# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 23 24# This is a library file used by the Perl version of mysql-test-run, 25# and is part of the translation of the Bourne shell script with the 26# same name. 27 28use strict; 29use File::Find; 30 31sub mtr_native_path($); 32sub mtr_init_args ($); 33sub mtr_add_arg ($$@); 34sub mtr_path_exists(@); 35sub mtr_script_exists(@); 36sub mtr_file_exists(@); 37sub mtr_exe_exists(@); 38sub mtr_exe_maybe_exists(@); 39sub mtr_copy_dir($$); 40sub mtr_rmtree($); 41sub mtr_same_opts($$); 42sub mtr_cmp_opts($$); 43 44############################################################################## 45# 46# Misc 47# 48############################################################################## 49 50# Convert path to OS native format 51sub mtr_native_path($) 52{ 53 my $path= shift; 54 55 # MySQL version before 5.0 still use cygwin, no need 56 # to convert path 57 return $path 58 if ($::mysql_version_id < 50000); 59 60 $path=~ s/\//\\/g 61 if ($::glob_win32); 62 return $path; 63} 64 65 66# FIXME move to own lib 67 68sub mtr_init_args ($) { 69 my $args = shift; 70 $$args = []; # Empty list 71} 72 73sub mtr_add_arg ($$@) { 74 my $args= shift; 75 my $format= shift; 76 my @fargs = @_; 77 78 push(@$args, sprintf($format, @fargs)); 79} 80 81############################################################################## 82 83# 84# NOTE! More specific paths should be given before less specific. 85# For example /client/debug should be listed before /client 86# 87sub mtr_path_exists (@) { 88 foreach my $path ( @_ ) 89 { 90 return $path if -e $path; 91 } 92 if ( @_ == 1 ) 93 { 94 mtr_error("Could not find $_[0]"); 95 } 96 else 97 { 98 mtr_error("Could not find any of " . join(" ", @_)); 99 } 100} 101 102 103# 104# NOTE! More specific paths should be given before less specific. 105# For example /client/debug should be listed before /client 106# 107sub mtr_script_exists (@) { 108 foreach my $path ( @_ ) 109 { 110 if($::glob_win32) 111 { 112 return $path if -f $path; 113 } 114 else 115 { 116 return $path if -x $path; 117 } 118 } 119 if ( @_ == 1 ) 120 { 121 mtr_error("Could not find $_[0]"); 122 } 123 else 124 { 125 mtr_error("Could not find any of " . join(" ", @_)); 126 } 127} 128 129 130# 131# NOTE! More specific paths should be given before less specific. 132# For example /client/debug should be listed before /client 133# 134sub mtr_file_exists (@) { 135 foreach my $path ( @_ ) 136 { 137 return $path if -e $path; 138 } 139 return ""; 140} 141 142 143# 144# NOTE! More specific paths should be given before less specific. 145# For example /client/debug should be listed before /client 146# 147sub mtr_exe_maybe_exists (@) { 148 my @path= @_; 149 150 map {$_.= ".exe"} @path if $::glob_win32; 151 foreach my $path ( @path ) 152 { 153 if($::glob_win32) 154 { 155 return $path if -f $path; 156 } 157 else 158 { 159 return $path if -x $path; 160 } 161 } 162 return ""; 163} 164 165 166# 167# NOTE! More specific paths should be given before less specific. 168# For example /client/debug should be listed before /client 169# 170sub mtr_exe_exists (@) { 171 my @path= @_; 172 if (my $path= mtr_exe_maybe_exists(@path)) 173 { 174 return $path; 175 } 176 # Could not find exe, show error 177 if ( @path == 1 ) 178 { 179 mtr_error("Could not find $path[0]"); 180 } 181 else 182 { 183 mtr_error("Could not find any of " . join(" ", @path)); 184 } 185} 186 187 188sub mtr_copy_dir($$) { 189 my $from_dir= shift; 190 my $to_dir= shift; 191 192 # mtr_verbose("Copying from $from_dir to $to_dir"); 193 194 mkpath("$to_dir"); 195 opendir(DIR, "$from_dir") 196 or mtr_error("Can't find $from_dir$!"); 197 for(readdir(DIR)) { 198 next if "$_" eq "." or "$_" eq ".."; 199 if ( -d "$from_dir/$_" ) 200 { 201 mtr_copy_dir("$from_dir/$_", "$to_dir/$_"); 202 next; 203 } 204 copy("$from_dir/$_", "$to_dir/$_"); 205 } 206 closedir(DIR); 207 208} 209 210 211sub mtr_rmtree($) { 212 my ($dir)= @_; 213 mtr_verbose("mtr_rmtree: $dir"); 214 215 # Try to use File::Path::rmtree. Recent versions 216 # handles removal of directories and files that don't 217 # have full permissions, while older versions 218 # may have a problem with that and we use our own version 219 220 eval { rmtree($dir); }; 221 if ( $@ ) { 222 mtr_warning("rmtree($dir) failed, trying with File::Find..."); 223 224 my $errors= 0; 225 226 # chmod 227 find( { 228 no_chdir => 1, 229 wanted => sub { 230 chmod(0777, $_) 231 or mtr_warning("couldn't chmod(0777, $_): $!") and $errors++; 232 } 233 }, 234 $dir 235 ); 236 237 # rm 238 finddepth( { 239 no_chdir => 1, 240 wanted => sub { 241 my $file= $_; 242 # Use special underscore (_) filehandle, caches stat info 243 if (!-l $file and -d _ ) { 244 rmdir($file) or 245 mtr_warning("couldn't rmdir($file): $!") and $errors++; 246 } else { 247 unlink($file) 248 or mtr_warning("couldn't unlink($file): $!") and $errors++; 249 } 250 } 251 }, 252 $dir 253 ); 254 255 mtr_error("Failed to remove '$dir'") if $errors; 256 257 mtr_report("OK, that worked!"); 258 } 259} 260 261 262sub mtr_same_opts ($$) { 263 my $l1= shift; 264 my $l2= shift; 265 return mtr_cmp_opts($l1,$l2) == 0; 266} 267 268sub mtr_cmp_opts ($$) { 269 my $l1= shift; 270 my $l2= shift; 271 272 my @l1= @$l1; 273 my @l2= @$l2; 274 275 return -1 if @l1 < @l2; 276 return 1 if @l1 > @l2; 277 278 while ( @l1 ) # Same length 279 { 280 my $e1= shift @l1; 281 my $e2= shift @l2; 282 my $cmp= ($e1 cmp $e2); 283 return $cmp if $cmp != 0; 284 } 285 286 return 0; # They are the same 287} 288 289# 290# Compare two arrays and put all unequal elements into a new one 291# 292sub mtr_diff_opts ($$) { 293 my $l1= shift; 294 my $l2= shift; 295 my $f; 296 my $l= []; 297 foreach my $e1 (@$l1) 298 { 299 $f= undef; 300 foreach my $e2 (@$l2) 301 { 302 $f= 1 unless ($e1 ne $e2); 303 } 304 push(@$l, $e1) unless (defined $f); 305 } 306 foreach my $e2 (@$l2) 307 { 308 $f= undef; 309 foreach my $e1 (@$l1) 310 { 311 $f= 1 unless ($e1 ne $e2); 312 } 313 push(@$l, $e2) unless (defined $f); 314 } 315 return $l; 316} 317 3181; 319