#!/usr/bin/perl
#
# written by Dominix <dominix@despammed.com>;
# under GPL;
# this script is supposed to take place in 
# 	$CPAN::Config->{"cpan_home"} . "/sources"
# ie: 
# perl -MCPAN::Config -l012e 'print $CPAN::Config->{"cpan_home"}."/sources"'
# so it become directly usable by cpan utility.
# well,  this is not mandatory but I recommend setting 
# $CPAN::Config->{"scan_cache} to "never" 
# or $CPAN::Config->{'index_expire'} to '999'
# as long as you intend to manage manualy your .cpan cache
use strict;
use warnings;
use LWP::Simple;
use Compress::Zlib;
use File::Basename;
use File::Path;
use File::Find ();
use vars qw/*name *dir *prune/;
use CPAN::Config;

my $basearg = scalar($#ARGV) == -1 ? ${$CPAN::Config->{urllist}}[0] : $ARGV[0];

die "usage $0 URL(that indicate a CPAN root miror)" if $basearg eq "";

my ($proto,$filler,$host,$relative)=split("/",$basearg,4);
die "bad URL: @ARGV" if ( $filler ne "" || $host eq "");

my @list;
#my @toremove;
my $realf;
my ($Fld1,$Fld2,$Fld3) ;
my %seen ;
my @realfiles;
my $base;

*name   = *File::Find::name;
*dir    = *File::Find::dir;
*prune  = *File::Find::prune;

my $file='modules/02packages.details.txt.gz';
$relative = "" if not defined $relative ;
$relative = $relative eq "" ? "" : $relative . "/";
my $url = $proto . "//" . $host . "/" . $relative ;

print "fetching from $url\n" . $file;

$|=1;
my $httpresponse = mirror($url . $file ,$file);
die "Couldn't get it! $httpresponse" unless defined $httpresponse;
print " HTTP response: $httpresponse\n";

my $gz = gzopen($file, "rb")
                    or die "ARRG Cannot open $file: $gzerrno\n" ;
while ($gz->gzreadline($_) > 0) {
	#awk
	($Fld1,$Fld2,$Fld3) = split(' ', $_, 9999);
	if (/[gz|zip]$/) {
	   #uniq
	   push(@list, 'authors/id/' . $Fld3) unless $seen{$Fld3}++;
	}
}
die "Error reading from $file: $gzerrno" . ($gzerrno+0) . "\n"
                   if $gzerrno != Z_STREAM_END ;
#$gz->gzclose() or die "what happen with that gzclose ? $! ";
$gz->gzclose();
$file="modules/03modlist.data.gz";
print $file," HTTP response:";
$httpresponse = mirror($url . $file ,$file);
print $httpresponse . "\n";
$file="authors/01mailrc.txt.gz";
print $file," HTTP response:";
$httpresponse = mirror($url . $file ,$file);
print $httpresponse . "\n";

foreach (@list) { 
	if (! -e $_) {
		$base = dirname($_);
		if (! -d $base) { mkpath $base };	
		print $_," HTTP response:";
		$httpresponse = mirror($url . $_ ,$_);
		print $httpresponse;
		$httpresponse = mirror($url . $base . "/CHECKSUMS" ,$base . "/CHECKSUMS" );
		print " CHECKSUMS $httpresponse\n";
	}
} 


# now , cleanup the old version, if exists ...

sub wanted {
	my ($dev,$ino,$mode,$nlink,$uid,$gid);

	(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
	-f _ &&
	push @realfiles,$name if $name=~ /(gz|zip)$/;
}
# Traverse desired filesystems
File::Find::find({wanted => \&wanted}, 'authors/id');

#%seen = ();
@seen{@list} = ();

foreach $realf (@realfiles) {
#       push(@toremove, $realf) unless exists $seen{$realf};
	print "cleanup of " . $realf . "\n" unless exists $seen{$realf};
	unlink $realf unless exists $seen{$realf};
}