view release on metacpan or  search on metacpan

lib/CPAN/Testers/Data/Uploads.pm  view on Meta::CPAN

    # handle the CSV exception
    if($backups{CSV}) {
        $self->_log("Backup to CSV file");
        $backups{CSV}{db} = undef;  # close db handle
        my $fh1 = IO::File->new('uploads','r') or die "Cannot read temporary database file 'uploads'\n";
        my $fh2 = IO::File->new($backups{CSV}{dbfile},'w+') or die "Cannot write to CSV database file $backups{CSV}{dbfile}\n";
        while(<$fh1>) { print $fh2 $_ }
        $fh1->close;
        $fh2->close;
        unlink('uploads');
    }
}

sub help {
    my ($self,$full,$mess) = @_;

    print "\n$mess\n\n" if($mess);

    if($full) {
        print <<HERE;

Usage: $0 --config=<file> [-g] [-r] [-u] [-b] [-h] [-v]
        [--logfile=<file>] [--logclean] 
        [--lastmail=<file>] [--journal=<file>]

  --config=<file>   database configuration file
  -g                generate new database
  -r                reindex database (*)
  -u                update existing database
  -b                backup database to portable files
  -h                this help screen
  -v                program version
  --logfile=<file>  trace log file
  --logclean        overwrite exisiting log file
  --lastmail=<file> last id file
  --journal=<file>  SQL journal file path

Notes:
  * A generate request automatically includes a reindex.

HERE

    }

    print "$0 v$VERSION\n\n";
    exit(0);
}

#----------------------------------------------------------------------------
# Private Methods

sub _parse_archive {
    my ($self,$type,$file,$update) = @_;
    my $db = $self->uploads;
    my $dist = CPAN::DistnameInfo->new($file);

    my $name      = $dist->dist;      # "CPAN-DistnameInfo"
    my $version   = $dist->version;   # "0.02"
    my $cpanid    = $dist->cpanid;    # "GBARR"
    my $filename  = $dist->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
    my $date      = (stat($file))[9];

    unless($name && defined $version && $cpanid && $date) {
    	#$self->_log("PARSE: FAIL file=$file, $type => $name => $version => $cpanid => $date => $filename");
        $file =~ s!/opt/projects/CPAN/!!;
        $db->do_query($phrasebook{'ParseFailed'},$file,$type,$name,$version,$filename,$cpanid,$date);
    	return;
    }
    #$self->_log("$type => $name => $version => $cpanid => $date");

    my @rows = $db->get_query('array',$phrasebook{'FindDistVersion'},$cpanid,$name,$version);
    if(@rows) {
        if($type ne $rows[0]->[0]) {
            $db->do_query($phrasebook{'UpdateDistVersion'},$type,$cpanid,$name,$version);
            $self->_update_index($cpanid,$version,$date,$name,$oncpan{$type})
                if($update && $type ne 'backpan');
        }
    } else {
        $db->do_query($phrasebook{'InsertDistVersion'},$type,$cpanid,$name,$version,$filename,$date);
        $self->_update_index($cpanid,$version,$date,$name,$oncpan{$type})   if($update);
    }

    return $filename;
}

sub _update_index {
    my ($self,$author,$version,$date,$name,$oncpan) = @_;
    my $db = $self->uploads;

    my @index = $db->get_query('hash',$phrasebook{'FindIndex'},$name,$author);
    if(@index) {
        if($date > $index[0]->{released}) {
            $db->do_query($phrasebook{'UpdateIndex'},$oncpan,$version,$date,$name,$author);
            $self->_log("... index update [$author,$version,$date,$name,$oncpan]");
        }
    } else {
        $db->do_query($phrasebook{'InsertIndex'},$oncpan,$author,$version,$date,$name);
        $self->_log("... index insert [$author,$version,$date,$name,$oncpan]");
    }

    # add to page_requests table to update letter index pages and individual pages
    $db->do_query($phrasebook{'InsertRequest'},'ixauth',substr($author,0,1));
    $db->do_query($phrasebook{'InsertRequest'},'ixdist',substr($name,0,1));
    $db->do_query($phrasebook{'InsertRequest'},'author',$author);
    $db->do_query($phrasebook{'InsertRequest'},'distro',$name);
}

sub _nntp_connect {
    # connect to NNTP server
    my $nntp = Net::NNTP->new("nntp.perl.org") or die "Cannot connect to nntp.perl.org";
    my ($num,$first,$last) = $nntp->group("perl.cpan.uploads");

    return ($nntp,$num,$first,$last);
}

sub _lastid {
    my ($self,$id) = @_;
    my $f = $self->lastfile;

    unless( -f $f) {
        mkpath(dirname($f));