POE: Perl Object Environment

Update of /cvsroot/poe/poe/lib
In directory usw-pr-cvs1:/tmp/cvs-serv11977

Added Files:
	cpan-test.perl 
Log Message:
This little ditty runs all the /^POE::/ modules on the CPAN against
the local CVS version of POE.  Useful for regression testing and
uncovering problems in components.


--- NEW FILE: cpan-test.perl ---
#!/usr/bin/perl
# $Id: cpan-test.perl,v 1.1 2002/10/14 23:04:45 rcaputo Exp $

# Fetch and test all the /^POE::/ distributions on CPAN.

use warnings;
use strict;

use CPANPLUS::Configure;
use CPANPLUS::Backend;
use Cwd;
use Digest::MD5;

my $cwd = cwd;
sub DIR_MAIN     () { $cwd . "/comptest" }
sub DIR_CPANPLUS () { DIR_MAIN . "/cpanplus" }
sub DIR_TARBALLS () { DIR_MAIN . "/tarballs" }
sub DIR_TESTING  () { DIR_CPANPLUS . "/build" }

### Set up the directories.

unless (-e DIR_MAIN) {
  mkdir DIR_MAIN, 0777 or die $!;
}

unless (-e DIR_CPANPLUS) {
  mkdir DIR_CPANPLUS, 0777 or die $!;
}

unless (-e DIR_TARBALLS) {
  mkdir DIR_TARBALLS, 0777 or die $!;
}

### Redirect CPANPLUS configuration into our private cache.

my $cc = CPANPLUS::Configure->new();
$cc->_set_build( base => DIR_CPANPLUS );

### Gather a list of POE components that aren't part of POE.

print "Searching CPAN for POE modules...\n";

my $cp = CPANPLUS::Backend->new($cc);
my $search = $cp->search( type => "module",
                          list => [ "^POE::" ],
                        );

my %package;
foreach my $mod (sort keys %$search) {
  my $obj = $search->{$mod};
  my $package = $obj->package();

  my ($pkg, $ver) = ($package =~ /^(.*?)-([0-9\.\_]+)\.tar\.gz$/);

  # Skip things indigenous to POE.
  next if $pkg eq "POE";

  $package{$package} = $obj;
}

### Fetch distributions.

print "Fetching distributions...\n";

foreach my $package (sort keys %package) {
  my $existing_file = DIR_TARBALLS . "/$package";
  print "Got ", $package{$package}->fetch( fetchdir => DIR_TARBALLS ), "\n";
}

### Remove unsuccessful downloads.  Also remove older versions of
### updated distributions.

my %ver;
opendir(TB, DIR_TARBALLS) or die $!;
foreach (readdir(TB)) {
  my $full_path = DIR_TARBALLS . "/$_";

  next unless -f $full_path;

  if (/-\d+$/) {
    print "Unlinked stale temporary $full_path\n";
    unlink $full_path;
    next;
  }

  my ($mod, $ver) = (/^(.*?)-([0-9\.\_]+)\.tar\.gz$/);
  die "Can't parse $_ into dist/version" unless defined $mod and defined $ver;
  if (exists $ver{$mod}) {
    push @{$ver{$mod}}, $full_path;
  }
  else {
    $ver{$mod} = [$full_path];
  }
}
closedir TB;

foreach my $mod (sort keys %ver) {
  next unless @{$ver{$mod}} > 1;
  my @files = sort { -M } @{$ver{$mod}};
  while (@files > 1) {
    my $dead = shift @files;
    print "Unlinking older $dead...\n";
    unlink $dead;
  }


}

### Test them!

# Trap SIGINT and exit gracefully, so the END block below gets a
# chance to run.
$SIG{INT} = sub { exit };

# Add my cvspoe directory to the include path.
if (exists $ENV{PERL5LIB}) {
  $ENV{PERL5LIB} .= ":/home/troc/perl/poe";
}
else {
  $ENV{PERL5LIB} = "/home/troc/perl/poe";
}

opendir(TB, DIR_TARBALLS) or die $!;
my @tarballs = grep { -f } map { DIR_TARBALLS . "/$_" } readdir TB;
close TB;

my %results;

foreach my $tarball (@tarballs) {

  # Temporarily skip some modules that hang during testing.
  if ($tarball =~ /(rrdtool|onjoin|player-mpg123)/i) {
    warn "Skipping $tarball...\n";
    next;
  }

  warn "Testing $tarball...\n";

  system("/bin/rm -rf " . DIR_TESTING);
  mkdir DIR_TESTING, 0777 or die $!;

  $cp->extract(files => [ $tarball ]);

  my $mod = $tarball;
  $mod =~ s/^.*\///;
  $mod =~ s/\.tar.gz$//;

  my $full_dir = DIR_TESTING . "/$mod";
  warn $full_dir;

  my $local_results = $cp->make( target => "test",
                                 dirs   => [ $full_dir ],
                               );

  while (my ($dir, $stat) = each %$local_results) {
    $results{$dir} = $stat;
  }
}

### Print summary of results.

END{
  foreach my $dir (sort keys %results) {
    my $mod = $dir;
    $mod =~ s/^.*\///;

    print( $results{$dir}, " = ", ($results{$dir}) ? "   " : "NOT" );
    print " OK $mod\n";
  }
}