File Coverage

blib/lib/CPAN/Testers/WWW/Statistics/Graphs.pm
Criterion Covered Total %
statement 58 174 33.3
branch 20 62 32.2
condition 0 14 0.0
subroutine 12 17 70.5
pod 2 2 100.0
total 92 269 34.2


line stmt bran cond sub pod time code
1             package CPAN::Testers::WWW::Statistics::Graphs;
2              
3 16     16   53907 use warnings;
  16         39  
  16         594  
4 16     16   84 use strict;
  16         36  
  16         352  
5 16     16   82 use vars qw($VERSION);
  16         33  
  16         881  
6              
7             $VERSION = '1.23';
8              
9             #----------------------------------------------------------------------------
10              
11             =head1 NAME
12              
13             CPAN::Testers::WWW::Statistics::Graphs - CPAN Testers Statistics graphs.
14              
15             =head1 SYNOPSIS
16              
17             my %hash = { config => 'options' };
18             my $obj = CPAN::Testers::WWW::Statistics->new(%hash);
19             my $ct = CPAN::Testers::WWW::Statistics::Graphs->new(parent => $obj);
20             $ct->create();
21              
22             =head1 DESCRIPTION
23              
24             Using previously formatted data, generate graphs using the Google Chart API.
25              
26             Note that this package should not be called directly, but via its parent as:
27              
28             my %hash = { config => 'options' };
29             my $obj = CPAN::Testers::WWW::Statistics->new(%hash);
30             $obj->make_graphs();
31              
32             =cut
33              
34             # -------------------------------------
35             # Library Modules
36              
37 16     16   100 use File::Basename;
  16         39  
  16         1210  
38 16     16   110 use File::Path;
  16         47  
  16         856  
39 16     16   520 use HTML::Entities;
  16         4749  
  16         817  
40 16     16   520 use IO::File;
  16         6896  
  16         2009  
41 16     16   9503 use LWP::UserAgent;
  16         463116  
  16         580  
42 16     16   171 use HTTP::Request;
  16         39  
  16         26744  
43              
44             # -------------------------------------
45             # Variables
46              
47             my %month = (
48             0 => 'January', 1 => 'February', 2 => 'March', 3 => 'April',
49             4 => 'May', 5 => 'June', 6 => 'July', 7 => 'August',
50             8 => 'September', 9 => 'October', 10 => 'November', 11 => 'December'
51             );
52              
53             my ($backg,$foreg) = ('black','white');
54              
55             my @graphs = (
56             ['stats/stats1' ,'CPAN Testers Statistics - Reports' ,[qw(UPLOADS REPORTS PASS FAIL)],'TEST_RANGES' ,'month'],
57             ['stats/stats2' ,'CPAN Testers Statistics - Attributes' ,[qw(TESTERS PLATFORMS PERLS)] ,'TEST_RANGES' ,'month'],
58             ['stats/stats3' ,'CPAN Testers Statistics - Non-Passes' ,[qw(FAIL NA UNKNOWN)] ,'TEST_RANGES' ,'month'],
59             ['stats/stats4' ,'CPAN Testers Statistics - Testers' ,[qw(ALL FIRST LAST)] ,'TEST_RANGES' ,'month'],
60             ['stats/stats6' ,'CPAN Statistics - Uploads' ,[qw(AUTHORS DISTROS)] ,'CPAN_RANGES' ,'month'],
61             ['stats/stats12' ,'CPAN Statistics - New Uploads' ,[qw(AUTHORS DISTROS)] ,'CPAN_RANGES' ,'month'],
62             ['stats/build1' ,'CPAN Testers Performance Graph' ,[qw(REQUESTS PAGES REPORTS)] ,'NONE' ,'daily'],
63             ['stats/pcent1' ,'CPAN Testers Statistics - Percentages' ,[qw(FAIL OTHER PASS)] ,'TEST_RANGES' ,'month'],
64             ['rates/submit1' ,'CPAN Submissions - By Month' ,[qw(EXCLUSIVE INCLUSIVE)] ,'NONE' ,'index'],
65             ['rates/submit2' ,'CPAN Submissions - By Day of the Week' ,[qw(EXCLUSIVE INCLUSIVE)] ,'NONE' ,'index'],
66             ['rates/submit3' ,'CPAN Submissions - By Day of the Month' ,[qw(EXCLUSIVE INCLUSIVE)] ,'NONE' ,'index'],
67             ['rates/submit4' ,'CPAN Submissions - By Hour' ,[qw(EXCLUSIVE INCLUSIVE)] ,'NONE' ,'index'],
68             );
69              
70             my $lwp = LWP::UserAgent->new();
71             $lwp->agent( 'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.4) Gecko/20030624' );
72              
73             my $chart_api = 'http://chart.apis.google.com/chart?chs=640x300&cht=lc';
74             my $chart_titles = 'chtt=%s&chdl=%s';
75             my $chart_labels = 'chxt=x,x,y,r&chxl=0:|%s|1:|%s|2:|%s|3:|%s';
76             my $chart_data = 'chd=t:%s';
77             my $chart_colour = 'chco=%s';
78             my $chart_filler = 'chf=bg,s,dddddd';
79              
80             my %COLOURS = (
81             white => [255,255,255],
82             black => [0,0,0],
83             red => [255,0,0],
84             blue => [0,0,255],
85             purple => [230,0,230],
86             green => [0,255,0],
87             grey => [128,128,128],
88             light_grey => [170,170,170],
89             dark_grey => [75,75,75],
90             cream => [200,200,240],
91             yellow => [255,255,0],
92             orange => [255,128,0],
93             );
94              
95             my @COLOURS = map {sprintf "%s%s%s", _dec2hex($COLOURS{$_}->[0]),_dec2hex($COLOURS{$_}->[1]),_dec2hex($COLOURS{$_}->[2])} qw(red blue green orange purple grey);
96             my @MONTH = qw( - JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER );
97             my @MONTHS = map {my @x = split(//); my $x = join(' ',@x); [split(//,$x)]} @MONTH;
98              
99             # -------------------------------------
100             # Subroutines
101              
102             =head1 INTERFACE
103              
104             =head2 The Constructor
105              
106             =over 4
107              
108             =item * new
109              
110             Graph creation object. Checks to see whether the data files exist, and allows
111             the user to turn or off the progress tracking.
112              
113             new() takes an option hash as an argument, which may contain 'progress => 1'
114             to turn on the progress tracker and/or 'directory => $dir' to indicate the path
115             to the data files. If no directory is supplied the current directory is
116             assumed.
117              
118             =back
119              
120             =cut
121              
122             sub new {
123 0     0 1 0 my $class = shift;
124 0         0 my %hash = @_;
125              
126 0 0       0 die "Must specify the parent statistics object\n" unless(defined $hash{parent});
127              
128 0         0 my $self = {parent => $hash{parent}};
129 0         0 bless $self, $class;
130              
131 0         0 $self->{parent}->_log("GRAPHS: new");
132              
133 0         0 return $self;
134             }
135              
136             =head2 Methods
137              
138             =over 4
139              
140             =item * create
141              
142             Method to facilitate the creation of graphs.
143              
144             =back
145              
146             =cut
147              
148             sub create {
149 0     0 1 0 my $self = shift;
150 0         0 my $status = 0; # assume success
151              
152 0         0 my $directory = $self->{parent}->directory;
153              
154 0         0 $self->{parent}->_log("create start");
155              
156 0         0 for my $g (@graphs) {
157 0         0 my $results = "$directory/$g->[0]";
158 0         0 my ($path,$file) = (dirname($results),basename($results));
159 0         0 mkpath($path);
160 0         0 $g->[0] = $file;
161 0         0 $g->[5] = $path;
162              
163 0         0 my $ranges = $self->{parent}->ranges($g->[3]);
164 0         0 $self->{parent}->_log("writing graph - got range [$g->[3]] = " . (scalar(@$ranges)) . ", latest=$ranges->[-1]");
165              
166 0         0 my $latest = $ranges->[-1];
167              
168 0         0 for my $r (@$ranges) {
169 0         0 $self->{parent}->_log("writing graph - $g->[0]-$r");
170              
171 0         0 my $url = $self->_make_graph($r,@$g);
172 0 0       0 next unless($url);
173              
174 0         0 $self->{parent}->_log("url - [".(length $url)."] $url");
175             # print "$url\n";
176              
177 0         0 my $res;
178 0         0 eval {
179 0         0 my $req = HTTP::Request->new(GET => $url);
180 0         0 $res = $lwp->request($req);
181             };
182              
183 0 0 0     0 if($@ || !$res->is_success()) {
    0          
184 0         0 $file = "$results-$r.html";
185 0         0 $self->{parent}->_log("FAIL: $0 - Cannot access page - see '$file' [$url] [" . length($url) . "] [$@]\n");
186 0         0 _save_content($res,$file);
187 0         0 $status = 1;
188             } elsif($res->header('Content-Type') =~ /html/) {
189 0         0 $file = "$results-$r.html";
190 0         0 $self->{parent}->_log("FAIL: $0 - request failed - see '$file'\n");
191 0         0 _save_content($res,$file);
192 0         0 $status = 1;
193             } else {
194 0         0 $file = "$results-$r.png";
195 0         0 _save_content($res,$file);
196              
197 0 0       0 if($r eq $latest) {
198 0         0 $file = "$results.png";
199 0         0 _save_content($res,$file);
200             }
201             }
202             }
203             }
204              
205 0         0 $self->{parent}->_log("finish = $status");
206 0         0 return $status;
207             }
208              
209             sub _save_content {
210 0     0   0 my ($res,$file) = @_;
211 0 0       0 my $fh = IO::File->new(">$file") or die "$0 - Cannot write file [$file]: $!\n";
212 0 0       0 binmode($fh) if($file =~ /\.png$/);
213 0         0 print $fh $res->content;
214 0         0 $fh->close;
215             }
216              
217             #=item _make_graph
218             #
219             #Creates and writes out a single graph.
220             #
221             #=cut
222              
223             sub _make_graph {
224 0     0   0 my ($self,$r,$file,$title,$legend,$rcode,$type,$path) = @_;
225 0         0 my (@dates1,@dates2);
226 0         0 my $yr = 0;
227              
228 0         0 my @data = $self->_get_data("$path/$file.txt",$r);
229             #use Data::Dumper;
230             #print STDERR "#type=$type, file=$file.txt, data=".Dumper(\@data);
231              
232 0         0 $self->{parent}->_log("checkpoint 1");
233 0 0       0 return unless(@data);
234 0         0 $self->{parent}->_log("checkpoint 2");
235              
236 0         0 for my $date (@{$data[0]}) {
  0         0  
237 0 0       0 if($type eq 'index') {
    0          
238 0         0 push @dates1, "'";
239 0         0 push @dates2, $date;
240             } elsif($type eq 'month') {
241 0         0 my $year = substr($date,0,4);
242 0         0 my $month = substr($date,4,2);
243 0 0       0 push @dates1, ($month % 2 == 1 ? $MONTHS[$month][0] : '');
244 0 0       0 push @dates2, ($year != $yr ? $year : '');
245 0         0 $yr = $year;
246             } else {
247 0         0 my $year = substr($date,0,4);
248 0         0 my $month = substr($date,4,2);
249 0         0 my $day = substr($date,6,2);
250 0 0 0     0 push @dates1, ($day == 1 || $day % 7 == 0 ? sprintf "%d", $day : "'");
251 0   0     0 push @dates2, ($MONTHS[$month][$day-1] || '');
252             }
253             }
254              
255 0         0 my $max = 0;
256 0         0 for my $inx (1 .. $#data) {
257 0         0 for my $data (@{$data[$inx]}) {
  0         0  
258 0 0       0 $max = $data if($max < $data);
259             }
260             }
261              
262 0         0 $max = _set_max($max);
263 0         0 my $range = _set_range(0,$max);
264              
265 0         0 my (@d,@c);
266 0         0 my @colours = @COLOURS;
267 0         0 for my $inx (1 .. $#data) {
268 0         0 push @c, shift @colours;
269             # data needs to be expressed as a percentage of the max
270 0         0 for(@{$data[$inx]}) {
  0         0  
271             #print "pcent = $_ / $max * 100 = ";
272 0         0 $_ = $_ / $max * 100;
273             #print "$_ = ";
274 0         0 $_ = int($_ * 1) / 1;
275             #print "$_\n";
276             }
277              
278 0         0 push @d, join(',',@{$data[$inx]});
  0         0  
279             }
280 0         0 my $d = join('|',@d);
281 0         0 my $data = sprintf $chart_data, $d;
282              
283 0         0 my $dates1 = join('|', @dates1);
284 0         0 my $dates2 = join('|', @dates2);
285              
286 0         0 my $colour = sprintf $chart_colour, join(',',@c);
287 0         0 my $titles = sprintf $chart_titles, $title, join('|',@$legend);
288 0         0 my $labels = sprintf $chart_labels, $dates1, $dates2, $range, $range;
289 0         0 $titles =~ s/ /+/g;
290 0         0 $labels =~ s/ /+/g;
291 0         0 my @api = ($chart_api, $titles, $labels, $colour, $chart_filler, $data) ;
292              
293 0         0 my $url = join('&',@api);
294 0         0 $self->{parent}->_log("checkpoint 3 - $url");
295 0         0 return $url;
296             }
297              
298             #=item _get_data
299             #
300             #Reads and returns the contents of the graph data file.
301             #
302             #=cut
303              
304             sub _get_data {
305 0     0   0 my ($self,$file,$range) = @_;
306 0         0 my ($fdate,$tdate) = split('-',$range);
307              
308 0         0 $self->{parent}->_log("get data - range=$range, fdate=$fdate, tdate=$tdate, file=$file");
309              
310 0         0 my @data;
311 0 0       0 my $fh = IO::File->new($file)
312             or return ();
313             #or die "Cannot open data file [$file]: $!\n";
314 0         0 while(<$fh>) {
315 0         0 s/\s*$//;
316 0 0       0 next unless($_);
317 0 0 0     0 next if(/^#/ || /^$/);
318 0         0 my @values = split(",",$_);
319 0 0 0     0 next if($values[0] < $fdate || $values[0] > $tdate);
320 0         0 push @{$data[$_]}, $values[$_] for(0..$#values);
  0         0  
321             }
322 0         0 return @data;
323             }
324              
325             sub _dec2hex {
326 288     288   615 my $hexnum = sprintf("%x", $_[0]);
327 288 50       639 return '00' if(length($hexnum) < 1);
328 288 100       825 return '0'.$hexnum if(length($hexnum) < 2);
329 160         424 return $hexnum;
330             }
331              
332             sub _set_max {
333 8     8   4328 my $max = shift;
334 8         18 my $lmt = 10;
335              
336 8 100       29 return $lmt if($max <= $lmt);
337              
338 7         17 my $len = length("$max") - 1;
339 7         17 my $num = substr("$max",0,1);
340              
341 7 100       20 if($max < 100_000) {
342 5         16 my $lmt1 = (10**$len) * $num;
343 5         11 my $lmt2 = ((10**$len) * $num) + ((1**($len-1)) * 5);
344 5         10 my $lmt3 = (10**$len) * ($num + 1);
345              
346 5 100       25 return $lmt1 if($max <= $lmt1);
347 1 50       4 return $lmt2 if($max <= $lmt2);
348 1 50       7 return $lmt3 if($max <= $lmt3);
349             }
350              
351 2 50       10 $num += ($num % 2) ? 1 : 2;
352              
353 2         14 return (10**$len) * $num;
354             }
355              
356             sub _set_range {
357 8     8   18 my ($min,$max) = @_;
358              
359 8         18 my $len = length("$max") - 2;
360 8         19 my $pc0 = $max / 10;
361              
362 8         19 my $x1 = 10**$len * 1;
363 8         22 my $x2 = 10**$len * 2;
364 8         15 my $x5 = 10**$len * 5;
365 8         17 my $x0 = 10**$len * 10;
366              
367 8 100       31 my $step = $pc0 <= $x1 ? $x1 : $pc0 <= $x2 ? $x2 : $pc0 <= $x5 ? $x5 : $x0;
    50          
    50          
368              
369 8         12 my @r;
370 8         25 for(my $r = $min; $r < ($max+$step); $r += $step) {
371 41 100       110 my $x = $r < 1000 ? $r : $r < 1000000 ? ($r/1000) . 'k' : ($r/1000000) . 'm';
    100          
372 41         103 push @r, $x;
373             };
374              
375 8         48 return join('|',@r);
376             }
377              
378             q('Will code for a nice Balti Lamb Tikka Bhuna');
379              
380             __END__
381              
382             =head1 CPAN TESTERS FUND
383              
384             CPAN Testers wouldn't exist without the help and support of the Perl
385             community. However, since 2008 CPAN Testers has grown far beyond the
386             expectations of it's original creators. As a consequence it now requires
387             considerable funding to help support the infrastructure.
388              
389             In early 2012 the Enlightened Perl Organisation very kindly set-up a
390             CPAN Testers Fund within their donatation structure, to help the project
391             cover the costs of servers and services.
392              
393             If you would like to donate to the CPAN Testers Fund, please follow the link
394             below to the Enlightened Perl Organisation's donation site.
395              
396             F<https://members.enlightenedperl.org/drupal/donate-cpan-testers>
397              
398             If your company would like to support us, you can donate financially via the
399             fund link above, or if you have servers or services that we might use, please
400             send an email to admin@cpantesters.org with details.
401              
402             Our full list of current sponsors can be found at our I <3 CPAN Testers site.
403              
404             F<http://iheart.cpantesters.org>
405              
406             =head1 BUGS, PATCHES & FIXES
407              
408             There are no known bugs at the time of this release. However, if you spot a
409             bug or are experiencing difficulties, that is not explained within the POD
410             documentation, please send bug reports and patches to the RT Queue (see below).
411              
412             Fixes are dependent upon their severity and my availability. Should a fix not
413             be forthcoming, please feel free to (politely) remind me.
414              
415             RT Queue -
416             http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Testers-WWW-Statistics
417              
418             =head1 SEE ALSO
419              
420             L<CPAN::Testers::Data::Generator>,
421             L<CPAN::Testers::WWW::Reports>
422              
423             F<http://www.cpantesters.org/>,
424             F<http://stats.cpantesters.org/>,
425             F<http://wiki.cpantesters.org/>
426              
427             =head1 AUTHOR
428              
429             Barbie, <barbie@cpan.org>
430             for Miss Barbell Productions <http://www.missbarbell.co.uk>.
431              
432             =head1 COPYRIGHT AND LICENSE
433              
434             Copyright (C) 2005-2017 Barbie for Miss Barbell Productions.
435              
436             This distribution is free software; you can redistribute it and/or
437             modify it under the Artistic Licence v2.
438              
439             =cut