File Coverage

blib/lib/WWW/ActiveState/PPM.pm
Criterion Covered Total %
statement 32 59 54.2
branch 3 18 16.6
condition 1 2 50.0
subroutine 10 10 100.0
pod 4 4 100.0
total 50 93 53.7


line stmt bran cond sub pod time code
1             package WWW::ActiveState::PPM;
2              
3             =pod
4              
5             =head1 NAME
6              
7             WWW::ActiveState::PPM - Scrape build status from the ActiveState build farm
8              
9             =head1 DESCRIPTION
10              
11             B
12              
13             B
14              
15             B
16              
17             This module is used to extract the build state of all the modules from the
18             ActiveState PPM website, located at L.
19              
20             =head1 METHODS
21              
22             =cut
23              
24 2     2   1110823 use 5.006;
  2         8  
  2         101  
25 2     2   15 use strict;
  2         4  
  2         88  
26 2     2   874 use LWP::Simple ();
  2         185133  
  2         63  
27              
28 2     2   18 use vars qw{$VERSION};
  2         5  
  2         134  
29             BEGIN {
30 2     2   1948 $VERSION = '0.01';
31             }
32              
33             my $BASEURI = "http://ppm.activestate.com/BuildStatus/";
34              
35              
36              
37              
38              
39             #####################################################################
40             # Constructor
41              
42             =pod
43              
44             =head2 new
45              
46             my $scraper = WWW::ActiveState::PPM->new(
47             trace => 0,
48             version => '5.10',
49             );
50              
51             The C constructor creates a new website scraping object.
52              
53             The optional boolean C param (off by default) is
54             supplied to make the scraping object print status to STDOUT
55             as it runs.
56              
57             The optional C param (5.10 by default) is used to
58             set the version of Perl that the scraper should target.
59             Legal values are '5.6', '5.8' and '5.10'.
60              
61             Returns a new B object, or throws an
62             exception on error.
63              
64             =cut
65              
66             sub new {
67 1     1 1 17 my $class = shift;
68 1         4 my $self = bless { @_ }, $class;
69 1   50     16 $self->{version} ||= '5.10';
70 1         3 $self->{trace} = !! $self->{trace};
71 1         3 $self->{dists} = {};
72 1         3 return $self;
73             }
74              
75             =pod
76              
77             =head2 trace
78              
79             The C accessor is used to discover if tracing is enabled
80             for the object.
81              
82             =cut
83              
84             sub trace {
85 2     2 1 837 $_[0]->{trace};
86             }
87              
88             =pod
89              
90             =head2 version
91              
92             The C accessor returns the version of Perl that the scraper
93             is targetting.
94              
95             =cut
96              
97             sub version {
98 1     1 1 5 $_[0]->{version};
99             }
100              
101             =pod
102              
103             =head2 run
104              
105             The C method is used to kick off the parsing process.
106              
107             Returns true when all packages have been checked, or throws an
108             exception if an error occurs.
109              
110             =cut
111              
112             sub run {
113 1     1 1 3 my $self = shift;
114 1         4 foreach my $letter ( 'A' .. 'Z' ) {
115 1         4 my $uri = "$BASEURI$self->{version}-$letter.html";
116 1 50       4 print "Processing letter $letter...\n" if $self->trace;
117 1         6 $self->_scrape( $uri );
118             }
119 0         0 return 1;
120             }
121              
122             sub _scrape {
123 1     1   3 my $self = shift;
124 1         3 my $uri = shift;
125 1         8 my $content = LWP::Simple::get($uri);
126 1 50       14405202 unless ( defined $content ) {
127 0         0 die "Failed to fetch $uri";
128             }
129              
130             # Get the table
131 1 50       21 unless ( $content =~ m/\(.+?)\<\/table\>/s ) {
132 1         287 die "Failed to find packages table";
133             }
134 0           my $table = $1;
135              
136             # Separate out the rows
137 0           my @rows = $table =~ m/\]*\>(.+?)\<\/tr\>/sg;
138 0 0         unless ( @rows ) {
139 0           die "Failed to find rows";
140             }
141              
142             # Get the platforms
143 0           my $headers = $rows[0];
144 0           my @platforms = $headers =~ m/\(\w+)\<\/th\>/sg;
145 0 0         unless ( @platforms ) {
146 0           die "Failed to find platforms";
147             }
148              
149             # Process the rows
150 0           foreach my $rownum ( 0 .. $#rows ) {
151 0           my $row = $rows[$rownum];
152 0           my $record = {};
153              
154             # Skip headers
155 0 0         next if $row =~ /\
156              
157             # Parse the row
158 0 0         unless ( $row =~ m/\(.+?)\<\/td\>/s ) {
159 0           die "Failed to find package on row $rownum";
160             }
161 0           my $pkg = $record->{package} = $1;
162 0 0         unless ( $row =~ m/\(.+?)\<\/td\>/s ) {
163 0           die "Failed to find version on row $rownum";
164             }
165 0           $record->{version} = $1;
166 0           my @results = $row =~ m/\.+?\<\/td\>/sg;
167 0 0         unless ( @results = @platforms ) {
168 0           die "Failed to find expected results on row $rownum";
169             }
170 0           foreach ( 0 .. $#platforms ) {
171 0           $record->{$platforms[$_]} = $results[$_];
172             }
173              
174             # Add to the collection
175 0           $self->{dists}->{$pkg} = $record;
176             }
177              
178 0           return 1;
179             }
180              
181             1;
182              
183             =pod
184              
185             =head1 SUPPORT
186              
187             Bugs should be reported via the CPAN bug tracker
188              
189             L
190              
191             For other issues, contact the author.
192              
193             =head1 AUTHOR
194              
195             Adam Kennedy Eadamk@cpan.orgE
196              
197             =head1 SEE ALSO
198              
199             L
200              
201             =head1 COPYRIGHT
202              
203             Copyright 2008 Adam Kennedy.
204              
205             This program is free software; you can redistribute
206             it and/or modify it under the same terms as Perl itself.
207              
208             The full text of the license can be found in the
209             LICENSE file included with this module.
210              
211             =cut