The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package AnnoCPAN::Update;

$VERSION = '0.22';

use strict;
use warnings;

=head1 NAME

AnnoCPAN::Update - Update AnnoCPAN database from local CPAN mirror

=head1 SYNOPSYS

    use AnnoCPAN::Config 'config.pl';
    use AnnoCPAN::Update;
    AnnoCPAN::Update->run(verbose => 1);

=head1 DESCRIPTION

This module is used for updating an annocpan database from a local CPAN
mirror.

=head1 METHODS

=over

=cut

use File::Find qw(find);
use AnnoCPAN::Config;
use AnnoCPAN::Dist qw(:all);

=item new

Construct an AnnoCPAN::Update object. Options

=over 

=item cpan_root

The directory containing the local CPAN mirror.

=item dist_class

The name of the class used to construct CPAN distribution objects. Defaults to
L<AnnoCPAN::Dist>.

=back

=cut

sub new {
    my ($class, %opts) = @_;
    bless \%opts, $class;
    $opts{cpan_root} ||= AnnoCPAN::Config->option('cpan_root');
    $opts{path} = $opts{cpan_root};
    $opts{path} .= '/authors/id' unless $opts{path} =~ m|/authors/id|;
    $opts{cpan_root} =~ s|/authors/id.*||;
    $opts{dist_class} = $opts{dist_class}
        || AnnoCPAN::Config->option('dist_class')
        || 'AnnoCPAN::Dist';
    \%opts;
}

=item run

Does everything: loads the new modules, deletes the modules that no longer
exist, and collects the garbage.

If called as a class method, it calls the constructor automatically.

=cut

sub run {
    my $self = shift;
    return $self->new(@_)->run unless ref $self;
    $self->log('Beginning update');
    $self->load_db;
    $self->log('Deleting missing distvers');
    $self->delete_missing;
    $self->log('Collecting garbage');
    $self->garbage_collect;
    $self->log('Done');
}


=item load_db

Load the new modules into the database. Modules that are already loaded are not
affected.

=cut

sub load_db {
    my ($self) = @_;

    my $it = AnnoCPAN::DBI::DistVer->retrieve_all;
    my %seen;
    while (my $dv = $it->next) {
        $seen{$dv->path}++;
    }
    $self->{seen} = \%seen;

    find(
        {wanted => sub { $self->load_dist($_) }, no_chdir => 1 }, 
        $self->{path},
    );
}

=item load_dist($fname)

Load a specific distribution. If it is already in the database, does nothing.

=cut

sub load_dist {
    my ($self, $fname) = @_;

    return unless $fname =~ m{(authors/id/.*(\.tar\.gz|\.tgz|\.zip))$};
    return if $self->{seen}{$1};

    $self->log($fname);
    if (my $dist = $self->{dist_class}->new(
        $fname, verbose => $self->verbose)) 
    {
        my ($distver, $status) = $dist->extract;
        if ($distver and $status == DIST_ADDED and not $self->{new}) {
            # this is a new dist; check if notes have to be propagated
            $distver->translate_notes;
        }
    }
}

=item delete_missing

Delete from the database all the distributions that no longer exist in the
CPAN mirror.

=cut

sub delete_missing {
    my ($self) = @_;
    my $it = AnnoCPAN::DBI::DistVer->retrieve_all;
    my $cpan = $self->{cpan_root};
    while (my $distver = $it->next) {
        my $path = $distver->path;
        #print "checking $path\n";
        unless (-e "$cpan/$path") {
            $self->log("deleting entry for $path from database");
            $distver->delete;
        }
    }
}

=item garbage_collect

Delete from the database the Pods and Dists that no longer exist in any
version.

=cut

sub garbage_collect {
    my ($self) = @_;
    AnnoCPAN::DBI::Pod->garbage_collect;
    AnnoCPAN::DBI::Dist->garbage_collect;
}

sub verbose     { shift->{verbose} }

sub log {
    my ($self, $message) = @_;
    printf "%s\t%s\n", scalar localtime, $message if $self->verbose;
}

=back

=head1 SEE ALSO

L<AnnoCPAN::DBI>, L<AnnoCPAN::Config>, L<AnnoCPAN::Dist>

=head1 AUTHOR

Ivan Tubert-Brohman E<lt>itub@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (c) 2005 Ivan Tubert-Brohman. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same terms as
Perl itself.

=cut

1;