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


line stmt bran cond sub pod time code
1             package POE::Component::CPANIDX;
2              
3 3     3   580628 use strict;
  3         6  
  3         114  
4 3     3   18 use warnings;
  3         7  
  3         97  
5 3     3   16 use Carp;
  3         13  
  3         259  
6 3     3   2326 use POE qw(Component::Client::HTTP);
  3         116918  
  3         31  
7 3     3   884215 use YAML::Tiny;
  3         24131  
  3         214  
8 3     3   7037 use HTTP::Request::Common;
  3         17142  
  3         310  
9 3     3   29 use File::Spec::Unix;
  3         7  
  3         118  
10 3     3   16 use vars qw($VERSION);
  3         6  
  3         4137  
11              
12             $VERSION = '0.10';
13              
14             my $cmds = {
15             mod => 1,
16             dist => 1,
17             auth => 1,
18             corelist => 1,
19             dists => 1,
20             timestamp => 0,
21             topten => 0,
22             mirrors => 0,
23             };
24              
25             # Stolen from POE::Wheel. This is static data, shared by all
26             my $current_id = 0;
27             my %active_identifiers;
28              
29             sub _allocate_identifier {
30 2     2   5 while (1) {
31 2 50       11 last unless exists $active_identifiers{ ++$current_id };
32             }
33 2         8 return $active_identifiers{$current_id} = $current_id;
34             }
35              
36             sub _free_identifier {
37 2     2   8 my $id = shift;
38 2         12 delete $active_identifiers{$id};
39             }
40              
41              
42             sub spawn {
43 2     2 1 28 my $package = shift;
44 2         5 my %opts = @_;
45 2         10 $opts{lc $_} = delete $opts{$_} for keys %opts;
46 2         5 my $options = delete $opts{options};
47 2         8 my $self = bless \%opts, $package;
48 2 50       38 $self->{session_id} = POE::Session->create(
49             object_states => [
50             $self => { shutdown => '_shutdown',
51             query_idx => '_query_idx',
52             },
53             $self => [ qw(_start _query_idx _dispatch _http_request _http_response) ],
54             ],
55             heap => $self,
56             ( ref($options) eq 'HASH' ? ( options => $options ) : () ),
57             )->ID();
58 2         218 return $self;
59             }
60              
61             sub session_id {
62 0     0 1 0 return $_[0]->{session_id};
63             }
64              
65             sub shutdown {
66 2     2 1 3803 my $self = shift;
67 2         13 $poe_kernel->call( $self->{session_id}, 'shutdown' );
68             }
69              
70             sub _start {
71 2     2   578 my ($kernel,$self) = @_[KERNEL,OBJECT];
72 2         10 $self->{session_id} = $_[SESSION]->ID();
73 2 50       13 if ( $self->{alias} ) {
74 0         0 $kernel->alias_set( $self->{alias} );
75             }
76             else {
77 2         12 $kernel->refcount_increment( $self->{session_id} => __PACKAGE__ );
78             }
79 2         64 $self->{_httpc} = 'httpc-' . $self->{session_id};
80 2         21 POE::Component::Client::HTTP->spawn(
81             Alias => $self->{_httpc},
82             FollowRedirects => 2,
83             );
84 2         3095 return;
85             }
86              
87             sub _shutdown {
88 2     2   101 my ($kernel,$self) = @_[KERNEL,OBJECT];
89 2         9 $kernel->alias_remove( $_ ) for $kernel->alias_list();
90 2 50       204 $kernel->refcount_decrement( $self->{session_id} => __PACKAGE__ ) unless $self->{alias};
91 2         61 $self->{_shutdown} = 1;
92 2         8 $kernel->post( $self->{_httpc}, 'shutdown' );
93 2         467 undef;
94             }
95              
96             sub query_idx {
97 2     2 1 2377 my $self = shift;
98 2         12 $poe_kernel->post( $self->{session_id}, '_query_idx', @_ );
99             }
100              
101             sub _query_idx {
102 2     2   803 my ($kernel,$self,$state) = @_[KERNEL,OBJECT,STATE];
103 2         9 my $sender = $_[SENDER]->ID();
104 2 50       17 return if $self->{_shutdown};
105 2         3 my $args;
106 2 50       9 if ( ref( $_[ARG0] ) eq 'HASH' ) {
107 0         0 $args = { %{ $_[ARG0] } };
  0         0  
108             } else {
109 2         16 $args = { @_[ARG0..$#_] };
110             }
111              
112 2         5 $args->{lc $_} = delete $args->{$_} for grep { $_ !~ /^_/ } keys %{ $args };
  8         36  
  2         8  
113              
114 2 50       12 unless ( $args->{event} ) {
115 0         0 warn "No 'event' specified for $state";
116 0         0 return;
117             }
118              
119             croak
120 2 50 33     34 "You must provide a valid 'url' of a CPANIDX site"
      33        
121             unless $args->{url} and URI->new($args->{url}) and URI->new($args->{url})->scheme eq 'http';
122              
123 2 50       29296 $args->{cmd} = 'timestamp' unless $args->{cmd};
124 2         7 $args->{cmd} = lc $args->{cmd};
125              
126 2         9 my $arg = $cmds->{ $args->{cmd} };
127              
128 2 50       55 croak
129             "'cmd' that was specified is unknown"
130             unless defined $arg;
131              
132 2 50 33     18 croak
133             "'cmd' requires that you specify a 'search' term"
134             if $arg and !$args->{search};
135              
136 2         6 $args->{sender} = $sender;
137 2         18 $kernel->refcount_increment( $sender => __PACKAGE__ );
138 2         90 $kernel->yield( '_http_request', $args );
139              
140 2         179 return;
141             }
142              
143             sub _http_request {
144 2     2   369 my ($kernel,$self,$req) = @_[KERNEL,OBJECT,ARG0];
145 2         10 my $url = URI->new( $req->{url} );
146              
147 2 50       119 $url->path( File::Spec::Unix->catfile( $url->path, 'yaml', $req->{cmd}, ( $req->{search} ? $req->{search} : () ) ) );
148              
149 2         156 my $id = _allocate_identifier();
150              
151 2         22 $kernel->post(
152             $self->{_httpc},
153             'request',
154             '_http_response',
155             GET( $url->as_string ),
156             "$id",
157             );
158              
159 2         514 $self->{_requests}->{ $id } = $req;
160 2         7 return;
161             }
162              
163             sub _http_response {
164 2     2   229034 my ($kernel,$self,$request_packet,$response_packet) = @_[KERNEL,OBJECT,ARG0,ARG1];
165 2         9 my $id = $request_packet->[1];
166 2         8 my $req = delete $self->{_requests}->{ $id };
167 2         19 _free_identifier( $id );
168 2         7 my $resp = $response_packet->[0];
169 2 100       15 if ( $resp->is_success ) {
170 1         10 my $data;
171 1         3 eval { $data = YAML::Tiny::Load( $resp->content ); };
  1         7  
172 1 50       623 unless ( $data ) {
173 0         0 $req->{error} = 'No valid YAML data was found';
174 0         0 $kernel->yield( '_dispatch', $req );
175 0         0 return;
176             }
177 1         3 $req->{data} = $data;
178             }
179             else {
180 1         23 $req->{error} = $resp->as_string;
181             }
182              
183 2         277 $kernel->yield( '_dispatch', $req );
184 2         132 return;
185             }
186              
187             sub _dispatch {
188 2     2   783 my ($kernel,$self,$input) = @_[KERNEL,OBJECT,ARG0];
189 2         13 my $session = delete $input->{sender};
190 2         10 my $event = delete $input->{event};
191 2         8 $kernel->post( $session, $event, $input );
192 2         161 $kernel->refcount_decrement( $session => __PACKAGE__ );
193 2         64 return;
194             }
195              
196             qq[CAPTCH!];
197              
198             __END__