WL4189 Add Handles.pm and use it from My::File::Path to show open handles....

use base "Exporter";

our @EXPORT= qw / rmtree mkpath copytree /;

use File::Find;

use File::Path;

use File::Copy;

use Carp;

no warnings 'redefine';

use My::Handles;

sub rmtree {

  my ($dir)= @_;

  #

  # chmod all files to 0777 before calling rmtree

  #

  find( {

	 bydepth 		=> 1,

	 no_chdir 		=> 1,

	 wanted => sub {

	   chmod(0777, $_)

	     or warn("couldn't chmod(0777, $_): $!");

	 }

	},

	$dir

      );

	   my $name= $_;

	   if (!-l $name && -d _){

	     return if (rmdir($name) == 1);

	     chmod(0777, $name) or carp("couldn't chmod(0777, $name): $!");

  # Call rmtree from File::Path

  goto &File::Path::rmtree;

	     return if (rmdir($name) == 1);

	     # Failed to remove the directory, analyze

	     carp("Couldn't remove directory '$name': $!");

	     My::Handles::show_handles($name);

	   } else {

	     return if (unlink($name) == 1);

	     chmod(0777, $name) or carp("couldn't chmod(0777, $name): $!");

	     return if (unlink($name) == 1);

	     carp("Couldn't delete file '$name': $!");

	     My::Handles::show_handles($name);

	   }

	 }

	}, $dir );

};

# -*- cperl -*-

# Copyright (C) 2008 MySQL AB

#

# This program is free software; you can redistribute it and/or modify

# it under the terms of the GNU General Public License as published by

# the Free Software Foundation; version 2 of the License.

#

# This program is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

# You should have received a copy of the GNU General Public License

# along with this program; if not, write to the Free Software

# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

package My::Handles;

use strict;

use Carp;

use My::Platform;

my $handle_exe;

if (IS_WINDOWS){

  # Check if handle.exe is available

  # Pass switch to accept the EULA to avoid hanging

  # if the program hasn't been run before.

  my $list= `handle.exe -? -accepteula 2>&1`;

  foreach my $line (split('\n', $list))

  {

    $handle_exe= "$1.$2"

      if ($line =~ /Handle v([0-9]*)\.([0-9]*)/);

  }

  if ($handle_exe){

    print "Found handle.exe version $handle_exe\n";

  }

}

sub show_handles

{

  my ($dir)= @_;

  return unless $handle_exe;

  return unless $dir;

  $dir= native_path($dir);

  # Get a list of open handles in a particular directory

  my $list= `handle.exe "$dir" 2>&1` or return;

  foreach my $line (split('\n', $list))

  {

    return if ($line =~ /No matching handles found/);

  }

  print "\n";

  print "=" x 50, "\n";

  print "Open handles in '$dir':\n";

  print "$list\n";

  print "=" x 50, "\n\n";

  return;

}

1;