File Coverage

blib/lib/POE/Component/CPAN/SQLite/Info.pm

Criterion	Covered	Total	%
statement	21	168	12.5
branch	0	66	0.0
condition	0	3	0.0
subroutine	7	24	29.1
pod	4	5	80.0
total	32	266	12.0

package POE::Component::CPAN::SQLite::Info;

use strict;
use warnings;

our $VERSION = '0.11';

use LWP::UserAgent;
use File::Spec;
use CPAN::SQLite::Info;
use POE (qw( Wheel::Run  Filter::Reference  Filter::Line));
use Carp;

sub spawn {
    my $package = shift;

    croak "Even number of arguments must be passed to $package"
        if @_ & 1;

    my %params = @_;

    $params{ lc $_ } = delete $params{ $_ } for keys %params;

    delete $params{options}
        unless ref $params{options} eq 'HASH';

    unless ( exists $params{path} ) {
        $params{path} = 'cpan_sqlite_info/';
        warn "Warning: No `path` parameter was specified\n"
            if $params{debug};
    }

    unless ( exists $params{mirror} ) {
        $params{mirror} = 'http://cpan.perl.org';
    }

    my $self = bless \%params, $package;

    $self->{session_id} = POE::Session->create(
        object_states => [
            $self => {
                freshen    => '_freshen',
                fetch_info => '_fetch_info',
                shutdown   => '_shutdown',
            },
            $self => [
                qw(
                    _child_error
                    _child_close
                    _child_stderr
                    _child_stdout
                    _sig_chld
                    _start
                )
            ],
        ],
        ( exists $params{options} ? ( options => $params{options} ) : () ),
    )->ID;

    return $self;
}

sub _start {
    my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
    $self->{session_id} = $_[SESSION]->ID();

    if  ( $self->{alias} ) {
        $kernel->alias_set( $self->{alias} );
    }
    else {
        $kernel->refcount_increment( $self->{session_id} => __PACKAGE__ );
    }

    $self->{wheel} = POE::Wheel::Run->new(
        Program => \&_wheel,
        ErrorEvent => '_child_error',
        CloseEvent => '_child_close',
        StderrEvent => '_child_stderr',
        StdoutEvent => '_child_stdout',
        StdioFilter => POE::Filter::Reference->new,
        StderrFilter => POE::Filter::Line->new,
        ( $^O eq 'MSWin32' ? ( CloseOnCall => 0 ) : ( CloseOnCall => 1 ) ),
    );

    $kernel->call('shutdown')
        unless $self->{wheel};

    $kernel->sig_child( $self->{wheel}->PID, '_sig_chld' );
}

sub _sig_chld {
    $poe_kernel->sig_handled;
}

sub _child_close {
    my ( $kernel, $self, $wheel_id ) = @_[ KERNEL, OBJECT, ARG0 ];

    warn "_child_close called (@_[ARG0..$#_])\n"
        if $self->{debug};

    delete $self->{wheel};
    $kernel->yield('shutdown')
        unless $self->{shutdown};

    undef;
}

sub _child_error {
    my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
    warn "_child_error called (@_[ARG0..$#_])\n"
        if $self->{debug};

    delete $self->{wheel};
    $kernel->yield('shutdown')
        unless $self->{shutdown};

    undef;
}

sub _child_stderr {
    my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
    warn "_child_stderr: $_[ARG0]\n"
        if $self->{debug};

    undef;
}

sub _child_stdout {
    my ( $kernel, $self, $input ) = @_[ KERNEL, OBJECT, ARG0 ];

    my $session = delete $input->{sender};
    my $event   = delete $input->{event};

    $kernel->post( $session, $event, $input );
    $kernel->refcount_decrement( $session => __PACKAGE__ );

    undef;
}

sub shutdown {
    my $self = shift;
    $poe_kernel->post( $self->{session_id} => 'shutdown' );
}

sub _shutdown {
    my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
    $kernel->alarm_remove_all;
    $kernel->alias_remove( $_ ) for $kernel->alias_list;
    $kernel->refcount_decrement( $self->{session_id} => __PACKAGE__ )
        unless $self->{alias};

    $self->{shutdown} = 1;
    $self->{wheel}->shutdown_stdin
        if $self->{wheel};
}

sub session_id {
    return $_[0]->{session_id};
}

sub freshen {
    my $self = shift;
    $poe_kernel->post( $self->{session_id} => 'freshen' => @_ );
}

sub fetch_info {
    my $self = shift;
    $poe_kernel->post( $self->{session_id} => 'fetch_info' => @_ );
}

sub _fetch_info {
    my ( $kernel, $self, $args )= @_[ KERNEL, OBJECT, ARG0 ];

    my $sender = $_[SENDER]->ID;

    return
        if $self->{shutdown};

    $args->{ lc $_ } = delete $args->{ $_ }
        for grep { !/^_/ } keys %{ $args };


    if ( $args->{session} ) {
        if ( my $ref = $kernel->alias_resolve( $args->{session} ) ) {
            $args->{sender} = $ref->ID;
        }
        else {
            warn "Could not resolve `session` parameter to a "
                    . "valid POE session. Aborting...";
            return;
        }
    }
    else {
        $args->{sender} = $sender;
    }

    unless ( exists $args->{path} ) {
        $args->{path} = $self->{path};
    }

    delete $args->{freshen}; # to make sure wheel doesn't freshen by mistake
    $kernel->refcount_increment( $args->{sender} => __PACKAGE__ );
    $self->{wheel}->put( $args );

    undef;
}


# yes, yes, the almost identical sub{} to the above one....
# fighting POE's "magik" in here is beyond me...
# .. note to self: figure out wtf is going on.

sub _freshen {
    my ( $kernel, $self, $args )= @_[ KERNEL, OBJECT, ARG0 ];

    my $sender = $_[SENDER]->ID;

    return
        if $self->{shutdown};

    $args->{ lc $_ } = delete $args->{ $_ }
        for grep { !/^_/ } keys %{ $args };


    if ( $args->{session} ) {
        if ( my $ref = $kernel->alias_resolve( $args->{session} ) ) {
            $args->{sender} = $ref->ID;
        }
        else {
            warn "Could not resolve `session` parameter to a "
                    . "valid POE session. Aborting...";
            return;
        }
    }
    else {
        $args->{sender} = $sender;
    }

    unless ( exists $args->{path} ) {
        $args->{path} = $self->{path};
    }

    unless ( exists $args->{mirror} ) {
        $args->{mirror} = $self->{mirror};
    }

    unless ( exists $args->{ua_args}{timeout} ) {
        $args->{ua_args}{timeout} = 30;
    }

    $args->{freshen} = 1; # for the wheel to know what to do.
    $kernel->refcount_increment( $args->{sender} => __PACKAGE__ );
    $self->{wheel}->put( $args );

    undef;
}

sub _wheel {
    if ( $^O eq 'MSWin32' ) {
        binmode STDIN;
        binmode STDOUT;
    }

    my $raw;
    my $size = 4096;
    my $filter = POE::Filter::Reference->new;

    while ( sysread STDIN, $raw, $size ) {
        my $requests = $filter->get( [ $raw ] );
        foreach my $req_ref ( @$requests ) {

            if ( exists $req_ref->{freshen} ) {
                eval { _fetch_data_files( $req_ref ); };
                $req_ref->{freshen_error} = $@
                    if $@;
            }
            else {
                _populate_info( $req_ref );
            }

            my $response = $filter->put( [ $req_ref ] );
            print STDOUT @$response;
        }
    }
}

sub _populate_info {
    my $req_ref = shift;

    my $info = CPAN::SQLite::Info->new( CPAN => $req_ref->{path} );

    # stupid ->fetch_info prints crap to STDOUT effectively
    # breaking Wheel ~_~
    {
        local *STDOUT;
        open STDOUT, '>', File::Spec->devnull;
        $info->fetch_info;
    }

    @$req_ref{ qw( dists mods auths ) }
    =  @$info{ qw( dists mods auths ) };

    undef;
}

sub _fetch_data_files {
    my $req_ref = shift;

    my $path     = $req_ref->{path};
    my $mod_dir  = File::Spec->catdir( $path, 'modules/' );
    my $auth_dir = File::Spec->catdir( $path, 'authors/' );

    foreach my $dir ( $path, $mod_dir, $auth_dir ) {
        unless ( -e $dir ) {
            mkdir $dir
                or die "Failed to create directory `$dir` ($!)\n";
        }
    }

    my $ua = LWP::UserAgent->new( %{ $req_ref->{ua_args} || {} } );

    my $mirror = $req_ref->{mirror};

    @{ $req_ref->{uris} }{ qw(modlist packages authors) } = (
        URI->new( $mirror ),
        URI->new( $mirror ),
        URI->new( $mirror ),
    );

    my $uris_ref = $req_ref->{uris};
    $uris_ref->{modlist }->path('/modules/03modlist.data.gz');
    $uris_ref->{packages}->path('/modules/02packages.details.txt.gz');
    $uris_ref->{authors }->path('/authors/01mailrc.txt.gz');

    $req_ref->{files}{ modlist  } = File::Spec->catfile(
        $mod_dir,
        '03modlist.data.gz',
    );
    $req_ref->{files}{ packages } = File::Spec->catfile(
        $mod_dir,
        '02packages.details.txt.gz',
    );
    $req_ref->{files}{ authors  } = File::Spec->catfile(
        $auth_dir,
        '01mailrc.txt.gz',
    );

    keys %{ $req_ref->{uris} };
    while ( my ( $name, $uri ) = each %{ $req_ref->{uris} } ) {

        $req_ref->{requests}{ $name } = $ua->mirror(
            $uri,
            $req_ref->{files}{ $name },
        );

        my $requests_ref = $req_ref->{requests};
        # check for fetch errors, but do not consider 304 an error,
        # we are fine with that since it indicates that file is good
        # enough for that we need it.
        if (
                !$requests_ref->{ $name }->is_success
            and $requests_ref->{ $name }->status_line ne '304 Not Modified'
        ) {
            $req_ref->{freshen_errors}{ $name }
            = $req_ref->{requests}{ $name }->status_line;

            $req_ref->{freshen_error} = 'fetch';
        }
    }

    undef;
}

1;

__END__