File Coverage

blib/lib/POE/Component/CPANIDX.pm

Criterion	Covered	Total	%
statement	100	109	91.7
branch	15	28	53.5
condition	3	9	33.3
subroutine	19	20	95.0
pod	4	4	100.0
total	141	170	82.9

package POE::Component::CPANIDX;

use strict;
use warnings;
use Carp;
use POE qw(Component::Client::HTTP);
use YAML::Tiny;
use HTTP::Request::Common;
use File::Spec::Unix;
use vars qw($VERSION);

$VERSION = '0.10';

my $cmds = {
  mod       => 1,
  dist      => 1,
  auth      => 1,
  corelist  => 1,
  dists     => 1,
  timestamp => 0,
  topten    => 0,
  mirrors   => 0,
};

# Stolen from POE::Wheel. This is static data, shared by all
my $current_id = 0;
my %active_identifiers;

sub _allocate_identifier {
  while (1) {
    last unless exists $active_identifiers{ ++$current_id };
  }
  return $active_identifiers{$current_id} = $current_id;
}

sub _free_identifier {
  my $id = shift;
  delete $active_identifiers{$id};
}


sub spawn {
  my $package = shift;
  my %opts = @_;
  $opts{lc $_} = delete $opts{$_} for keys %opts;
  my $options = delete $opts{options};
  my $self = bless \%opts, $package;
  $self->{session_id} = POE::Session->create(
  object_states => [
     $self => { shutdown     => '_shutdown',
                query_idx    => '_query_idx',
     },
     $self => [ qw(_start _query_idx _dispatch _http_request _http_response) ],
  ],
  heap => $self,
  ( ref($options) eq 'HASH' ? ( options => $options ) : () ),
  )->ID();
  return $self;
}

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

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

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->{_httpc} = 'httpc-' . $self->{session_id};
  POE::Component::Client::HTTP->spawn(
     Alias           => $self->{_httpc},
     FollowRedirects => 2,
  );
  return;
}

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

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

sub _query_idx {
  my ($kernel,$self,$state) = @_[KERNEL,OBJECT,STATE];
  my $sender = $_[SENDER]->ID();
  return if $self->{_shutdown};
  my $args;
  if ( ref( $_[ARG0] ) eq 'HASH' ) {
  $args = { %{ $_[ARG0] } };
  } else {
  $args = { @_[ARG0..$#_] };
  }

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

  unless ( $args->{event} ) {
    warn "No 'event' specified for $state";
    return;
  }

  croak
  "You must provide a valid 'url' of a CPANIDX site"
     unless $args->{url} and URI->new($args->{url}) and URI->new($args->{url})->scheme eq 'http';

  $args->{cmd} = 'timestamp' unless $args->{cmd};
  $args->{cmd} = lc $args->{cmd};

  my $arg = $cmds->{ $args->{cmd} };

  croak
  "'cmd' that was specified is unknown"
    unless defined $arg;

  croak
  "'cmd' requires that you specify a 'search' term"
    if $arg and !$args->{search};

  $args->{sender} = $sender;
  $kernel->refcount_increment( $sender => __PACKAGE__ );
  $kernel->yield( '_http_request', $args );

  return;
}

sub _http_request {
  my ($kernel,$self,$req) = @_[KERNEL,OBJECT,ARG0];
  my $url = URI->new( $req->{url} );

  $url->path( File::Spec::Unix->catfile( $url->path, 'yaml', $req->{cmd}, ( $req->{search} ? $req->{search} : () ) ) );

  my $id = _allocate_identifier();

  $kernel->post(
    $self->{_httpc},
    'request',
    '_http_response',
    GET( $url->as_string ),
    "$id",
  );

  $self->{_requests}->{ $id } = $req;
  return;
}

sub _http_response {
  my ($kernel,$self,$request_packet,$response_packet) = @_[KERNEL,OBJECT,ARG0,ARG1];
  my $id = $request_packet->[1];
  my $req = delete $self->{_requests}->{ $id };
  _free_identifier( $id );
  my $resp = $response_packet->[0];
  if ( $resp->is_success ) {
        my $data;
        eval { $data = YAML::Tiny::Load( $resp->content ); };
        unless ( $data ) {
          $req->{error} = 'No valid YAML data was found';
          $kernel->yield( '_dispatch', $req );
          return;
        }
        $req->{data} = $data;
  }
  else {
        $req->{error} = $resp->as_string;
  }

  $kernel->yield( '_dispatch', $req );
  return;
}

sub _dispatch {
  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__ );
  return;
}

qq[CAPTCH!];

__END__