File Coverage

blib/lib/CPAN/Testers/WWW/Statistics/Pages.pm
Criterion Covered Total %
statement 48 1308 3.6
branch 0 368 0.0
condition 0 170 0.0
subroutine 16 55 29.0
pod 14 14 100.0
total 78 1915 4.0


line stmt bran cond sub pod time code
1             package CPAN::Testers::WWW::Statistics::Pages;
2              
3 15     15   60738 use warnings;
  15         38  
  15         513  
4 15     15   88 use strict;
  15         34  
  15         338  
5 15     15   76 use vars qw($VERSION);
  15         34  
  15         839  
6              
7             $VERSION = '1.22';
8              
9             #----------------------------------------------------------------------------
10              
11             =head1 NAME
12              
13             CPAN::Testers::WWW::Statistics::Pages - CPAN Testers Statistics pages.
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::Pages->new(parent => $obj);
20              
21             $ct->update_full(); # updates statistics data and web pages
22              
23             # alternatively called individual processes
24              
25             $ct->update_data(); # updates statistics data
26             $ct->build_basics(); # updates basic web pages
27             $ct->build_matrices(); # updates matrix style web pages
28             $ct->build_stats(); # updates stats style web pages
29              
30             =head1 DESCRIPTION
31              
32             Using the cpanstats database, this module extracts all the data and generates
33             all the HTML pages needed for the CPAN Testers Statistics website. In addition,
34             also generates the data files in order generate the graphs that appear on the
35             site.
36              
37             Note that this package should not be called directly, but via its parent as:
38              
39             my %hash = { config => 'options' };
40             my $obj = CPAN::Testers::WWW::Statistics->new(%hash);
41              
42             $obj->make_pages(); # updates statistics data and web pages
43              
44             # alternatively called individual processes
45              
46             $obj->update(); # updates statistics data
47             $obj->make_basics(); # updates basic web pages
48             $obj->make_matrix(); # updates matrix style web pages
49             $obj->make_stats(); # updates stats style web pages
50              
51             =cut
52              
53             # -------------------------------------
54             # Library Modules
55              
56 15     15   8036 use Data::Dumper;
  15         106656  
  15         1003  
57 15     15   11223 use DateTime;
  15         6831422  
  15         717  
58 15     15   155 use File::Basename;
  15         47  
  15         1234  
59 15     15   8725 use File::Copy;
  15         25707  
  15         853  
60 15     15   106 use File::Path;
  15         43  
  15         664  
61 15     15   6018 use File::Slurp;
  15         44710  
  15         1204  
62 15     15   591 use HTML::Entities;
  15         4791  
  15         756  
63 15     15   508 use IO::File;
  15         6476  
  15         1770  
64 15     15   8384 use JSON;
  15         119865  
  15         95  
65 15     15   7919 use Sort::Versions;
  15         7243  
  15         1518  
66 15     15   6051 use Template;
  15         235668  
  15         477  
67             #use Time::HiRes qw ( time );
68 15     15   7332 use Time::Piece;
  15         103609  
  15         81  
69 15     15   1206 use Try::Tiny;
  15         32  
  15         180004  
70              
71             # -------------------------------------
72             # Variables
73              
74             my %month = (
75             0 => 'January', 1 => 'February', 2 => 'March', 3 => 'April',
76             4 => 'May', 5 => 'June', 6 => 'July', 7 => 'August',
77             8 => 'September', 9 => 'October', 10 => 'November', 11 => 'December'
78             );
79              
80             my @months = map { $month{$_} } keys %month;
81             my @days = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
82              
83             my $ADAY = 86400;
84              
85             my %matrix_limits = (
86             all => [ 1000, 5000 ],
87             month => [ 100, 500 ]
88             );
89              
90             # -------------------------------------
91             # Subroutines
92              
93             =head1 INTERFACE
94              
95             =head2 The Constructor
96              
97             =over 4
98              
99             =item * new
100              
101             Page creation object. Allows the user to turn or off the progress tracking.
102              
103             new() takes an option hash as an argument, which may contain 'progress => 1'
104             to turn on the progress tracker.
105              
106             =back
107              
108             =cut
109              
110             sub new {
111 0     0 1   my $class = shift;
112 0           my %hash = @_;
113              
114 0 0         die "Must specify the parent statistics object\n" unless(defined $hash{parent});
115              
116 0           my $self = {parent => $hash{parent}};
117 0           bless $self, $class;
118              
119 0           $self->setdates();
120 0           return $self;
121             }
122              
123             =head2 Public Methods
124              
125             =over 4
126              
127             =item * setdates
128              
129             Prime all key date variable.
130              
131             =item * update_full
132              
133             Full update of data and pages.
134              
135             =item * update_data
136              
137             Update data and store in JSON format.
138              
139             =item * build_basics
140              
141             Create the basic set of pages,those require no statistical calculation.
142              
143             =item * build_matrices
144              
145             Create the matrices pages and distribution list pages.
146              
147             =item * build_stats
148              
149             Create all other statistical pages; monthly tables, interesting stats, etc.
150              
151             =item * build_leaders
152              
153             Create all OS Leaderboards.
154              
155             =item * build_cpan
156              
157             Create/update the CPAN specific statistics data files and pages.
158              
159             =item * build_performance
160              
161             Create/update the builder performance data file.
162              
163             =item * build_noreports
164              
165             Create all OS no report pages.
166              
167             =back
168              
169             =cut
170              
171             sub setdates {
172 0     0 1   my $self = shift;
173 0   0       my $time = shift || time;
174              
175 0           $self->{parent}->_log("init");
176              
177 0           Time::Piece::day_list(@days);
178 0           Time::Piece::mon_list(@months);
179              
180             # timestamp for now
181 0           my $t = localtime($time);
182 0           $self->{dates}{RUNTIME} = $t->strftime("%a, %e %b %Y %T %Z");
183              
184             # todays date
185 0           my @datetime = localtime($time);
186 0           my $THISYEAR = ($datetime[5] + 1900);
187 0           my $THISMONTH = ($datetime[4]);
188 0           $self->{dates}{RUNDATE} = sprintf "%d%s %s %d", $datetime[3], _ext($datetime[3]), $month{$THISMONTH}, $THISYEAR;
189              
190             # THISMONTH is the last date for all data
191 0           $self->{dates}{THISMONTH} = ($THISYEAR) * 100 + $THISMONTH + 1;
192 0           $self->{dates}{THISDATE} = sprintf "%s %d", $month{int($THISMONTH)}, $THISYEAR;
193              
194 0           my $THATMONTH = $THISMONTH - 1;
195 0           my $THATYEAR = $THISYEAR;
196 0 0         if($THATMONTH < 0) {
197 0           $THATMONTH = 11;
198 0           $THATYEAR--;
199             }
200              
201             # LASTMONTH is the Month/Year stats are run for
202 0           $self->{dates}{LASTMONTH} = sprintf "%04d%02d", $THATYEAR, int($THATMONTH+1);
203 0           $self->{dates}{LASTDATE} = sprintf "%s %d", $month{int($THATMONTH)}, $THATYEAR;
204 0           $self->{dates}{PREVMONTH} = sprintf "%02d/%02d", int($THATMONTH+1), $THATYEAR - 2000;
205              
206 0           $THATMONTH--;
207 0 0         if($THATMONTH < 0) {
208 0           $THATMONTH = 11;
209 0           $THATYEAR--;
210             }
211              
212             # THATMONTH is the previous Month/Year for a full matrix
213 0           $self->{dates}{THATMONTH} = sprintf "%04d%02d", $THATYEAR, int($THATMONTH+1);
214            
215 0           $self->{parent}->_log( "THISYEAR=[$THISYEAR]" );
216 0           $self->{parent}->_log( "THATYEAR=[$THATYEAR]" );
217 0           $self->{parent}->_log( "DATES=" . Dumper( $self->{dates} ) );
218              
219             # calculate database metrics
220 0           my @rows = $self->{parent}->{CPANSTATS}->get_query('array',"SELECT fulldate FROM cpanstats ORDER BY id DESC LIMIT 1");
221 0           my @time = $rows[0]->[0] =~ /(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/;
222 0           $self->{dates}{RUNDATE2} = sprintf "%d%s %s %d", $time[2],_ext($time[2]),$month{$time[1]-1},$time[0];
223 0           $self->{dates}{RUNDATE3} = sprintf "%d%s %s %d, %02d:%02d", $time[2],_ext($time[2]),$month{$time[1]-1},$time[0],$time[3],$time[4];
224             }
225              
226             sub update_full {
227 0     0 1   my $self = shift;
228              
229 0           $self->{parent}->_log("start update_full");
230 0           $self->build_basics();
231 0           $self->build_data();
232 0           $self->build_matrices();
233 0           $self->build_stats();
234 0           $self->build_leaders();
235 0           $self->{parent}->_log("finish update_full");
236             }
237              
238             sub update_data {
239 0     0 1   my $self = shift;
240              
241 0           $self->{parent}->_log("start update_data");
242 0           $self->build_data();
243 0           $self->{parent}->_log("finish update_data");
244             }
245              
246             sub build_basics {
247 0     0 1   my $self = shift;
248              
249 0           $self->{parent}->_log("start build_basics");
250              
251             ## BUILD INFREQUENT PAGES
252 0           $self->_write_basics();
253 0           $self->_missing_in_action();
254              
255 0           $self->{parent}->_log("finish build_basics");
256             }
257              
258             sub build_matrices {
259 0     0 1   my $self = shift;
260              
261 0           $self->{parent}->_log("start build_matrices");
262 0           $self->storage_read();
263 0 0         if($self->{perls}) {
264 0           $self->{parent}->_log("building dist hash from storage");
265              
266 0           my @versions = sort {versioncmp($b,$a)} keys %{$self->{perls}};
  0            
  0            
267 0           $self->{versions} = \@versions;
268              
269 0           $self->_build_osname_matrix();
270 0           $self->_build_platform_matrix();
271             }
272 0           $self->{parent}->_log("finish build_matrices");
273             }
274              
275             sub build_stats {
276 0     0 1   my $self = shift;
277              
278 0           $self->{parent}->_log("stats start");
279              
280 0           $self->{parent}->_log("building dist hash from storage");
281 0           $self->storage_read();
282 0           my $testers = $self->storage_read('testers');
283 0           $self->{parent}->_log("dist hash from storage built");
284              
285 0 0         if($testers) {
286 0           for my $tester (keys %$testers) {
287 0           $self->{counts}{$testers->{$tester}{first}}{first}++;
288 0           $self->{counts}{$testers->{$tester}{last}}{last}++;
289             }
290              
291 0           $testers = {}; # save memory
292 0           $self->{parent}->_log("tester counts built");
293              
294 0           my @versions = sort {versioncmp($b,$a)} keys %{$self->{perls}};
  0            
  0            
295 0           $self->{versions} = \@versions;
296              
297             ## BUILD INDEPENDENT STATS
298 0           $self->_build_sizes();
299 0           $self->_report_cpan();
300              
301             ## BUILD MONTHLY STATS
302 0           $self->_build_monthly_stats();
303              
304             ## BUILD STATS PAGES
305 0           $self->_report_interesting();
306 0           $self->_build_monthly_stats_files();
307 0           $self->_build_failure_rates();
308 0           $self->_build_performance_stats();
309              
310             ## BUILD INDEX PAGE
311 0           $self->_write_index();
312             }
313              
314 0           $self->{parent}->_log("stats finish");
315             }
316              
317             sub build_cpan {
318 0     0 1   my $self = shift;
319              
320 0           $self->{parent}->_log("cpan stats start");
321              
322             ## BUILD INDEPENDENT STATS
323 0           $self->_build_sizes();
324 0           $self->_report_cpan();
325              
326 0           $self->{parent}->_log("cpan stats finish");
327             }
328              
329             sub build_performance {
330 0     0 1   my $self = shift;
331              
332 0           $self->{parent}->_log("performance start");
333 0           $self->{build} = $self->storage_read('build');
334              
335             ## BUILD PERFORMANCE FILES
336 0           $self->_build_performance_stats();
337              
338 0           $self->{parent}->_log("performance finish");
339             }
340              
341             sub build_leaders {
342 0     0 1   my $self = shift;
343              
344 0           $self->{parent}->_log("leaders start");
345              
346             ## BUILD OS LEADERBOARDS
347 0           $self->_build_osname_leaderboards();
348              
349 0           $self->{parent}->_log("leaders finish");
350             }
351              
352             sub build_noreports {
353 0     0 1   my $self = shift;
354              
355 0           $self->{parent}->_log("noreports start");
356              
357 0           $self->_update_noreports();
358 0           $self->_build_noreports();
359              
360 0           $self->{parent}->_log("noreports finish");
361             }
362              
363             =head2 Private Methods
364              
365             =head3 Data Methods
366              
367             =over 4
368              
369             =item * build_data
370              
371             =item * storage_read
372              
373             =item * storage_write
374              
375             =back
376              
377             =cut
378              
379             sub build_data {
380 0     0 1   my $self = shift;
381              
382 0           $self->{parent}->_log("building rate hash");
383              
384 0           my ($d1,$d2) = (time(), time() - $ADAY);
385 0           my @date = localtime($d2);
386 0           my $date = sprintf "%04d%02d%02d", $date[5]+1900, $date[4]+1, $date[3];
387 0           my @tday = localtime($d1);
388 0           my $tday = sprintf "%04d%02d%02d", $tday[5]+1900, $tday[4]+1, $tday[3];
389              
390 0   0       my $lastid = $self->storage_read('lastid') || 0;
391 0           my $testers = {};
392              
393 0 0         if($lastid) {
394 0           $self->{parent}->_log("building dist hash from storage");
395              
396 0           $self->storage_read();
397 0           $testers = $self->storage_read('testers');
398              
399             # only remember the latest release for 'dists' hash
400 0           my $iterator = $self->{parent}->{CPANSTATS}->iterator('hash',"SELECT dist,version FROM ixlatest");
401 0           while(my $row = $iterator->()) {
402 0 0 0       next if($self->{dists}{$row->{dist}} && $self->{dists}{$row->{dist}}->{VER} eq $row->{version});
403 0           $self->{dists}{$row->{dist}} = { ALL => 0, IXL => 0, VER => $row->{version}};
404             }
405              
406             } else {
407 0           $self->{parent}->_log("building dist hash from scratch");
408              
409 0           my $iterator = $self->{parent}->{CPANSTATS}->iterator('hash',"SELECT dist,version FROM ixlatest");
410 0           while(my $row = $iterator->()) {
411 0           $self->{dists}{$row->{dist}}->{ALL} = 0;
412 0           $self->{dists}{$row->{dist}}->{IXL} = 0;
413 0           $self->{dists}{$row->{dist}}->{VER} = $row->{version};
414             }
415              
416 0           $self->{parent}->_log("building stats hash");
417              
418 0   0       $self->{count}{$_} ||= 0 for(qw(posters entries reports distros));
419             $self->{xrefs} = { posters => {}, entries => {}, reports => {} },
420 0           $self->{xlast} = { posters => [], entries => [], reports => [] },
421             }
422              
423             # clear old month entries
424 0           for my $key (qw(platform osys osname)) {
425 0           for my $name (keys %{$self->{$key}}) {
  0            
426 0           for my $perl (keys %{$self->{$key}{$name}}) {
  0            
427 0           for my $month (keys %{$self->{$key}{$name}{$perl}{month}}) {
  0            
428 0 0 0       next if($month =~ /^\d+$/ && $month > $self->{dates}{THATMONTH});
429 0           delete $self->{$key}{$name}{$perl}{month}{$month};
430             }
431             }
432             }
433             }
434              
435             #$self->{parent}->_log("build:1.".Dumper($self->{build}));
436              
437             # reports builder performance stats
438 0           for my $d (keys %{$self->{build}}) {
  0            
439 0           $self->{build}{$d}->{old} = 0;
440             }
441 0           my $file = $self->{parent}->builder();
442 0 0 0       if($file && -f $file) {
443 0 0         if(my $fh = IO::File->new($file,'r')) {
444 0           while(<$fh>) {
445 0           my ($d,$r,$p) = /(\d+),(\d+),(\d+)/;
446 0 0         next unless($d);
447 0           $self->{build}{$d}->{webtotal} = $r;
448 0           $self->{build}{$d}->{webunique} = $p;
449 0           $self->{build}{$d}->{old} = 1;
450             }
451 0           $fh->close;
452             }
453             }
454 0           $self->{build}{$date}->{old} = 1; # keep the tally for yesterday
455 0           $self->{build}{$tday}->{old} = 2; # keep the tally for today, but don't use
456 0           for my $d (keys %{$self->{build}}) {
  0            
457 0 0         delete $self->{build}{$d} unless($self->{build}{$d}->{old});
458             }
459             #$self->{parent}->_log("build:2.".Dumper($self->{build}));
460              
461              
462             # load pass matrices, for all or just the last full month
463 0           $self->{parent}->_log("building pass reports matrices from database");
464 0           my $count = 0;
465 0           my $iterator = $self->{parent}->{CPANSTATS}->iterator('hash','SELECT * FROM passreports');
466 0           while(my $row = $iterator->()) {
467 0           $self->{pass}{$row->{platform}}{$row->{perl}}{all}{$row->{dist}} = 1;
468 0 0         next if($row->{postdate} <= $self->{dates}{THATMONTH});
469 0           $self->{pass}{$row->{platform}}{$row->{perl}}{month}{$row->{postdate}}{$row->{dist}} = 1;
470             }
471              
472              
473             # 0, 1, 2, 3, 4, 5 6, 7, 8, 9, 10 11 12
474             # id, guid, state, postdate, tester, dist, version, platform, perl, osname, osvers, fulldate, type
475              
476 0           $self->{parent}->_log("building dist hash from $lastid");
477 0           $iterator = $self->{parent}->{CPANSTATS}->iterator('hash',"SELECT * FROM cpanstats WHERE type = 2 AND id > $lastid ORDER BY id LIMIT 1000000");
478 0           while(my $row = $iterator->()) {
479 0           $row->{perl} =~ s/\s.*//; # only need to know the main release
480 0           $lastid = $row->{id};
481              
482             {
483 0           my $osname = $self->{parent}->osname($row->{osname});
  0            
484 0           my ($name) = $self->{parent}->tester($row->{tester});
485              
486 0           $self->{stats}{$row->{postdate}}{reports}++;
487 0           $self->{stats}{$row->{postdate}}{state }{$row->{state}}++;
488             #$self->{stats}{$row->{postdate}}{dist }{$row->{dist}}++;
489             #$self->{stats}{$row->{postdate}}{version }{$row->{version}}++;
490              
491             # check distribution tallies
492 0 0         if(defined $self->{dists}{$row->{dist}}) {
493 0           $self->{dists}{$row->{dist}}{ALL}++;
494              
495 0 0         if($self->{dists}{$row->{dist}}->{VER} eq $row->{version}) {
496 0           $self->{dists}{$row->{dist}}{IXL}++;
497              
498             # check failure rates
499 0 0         $self->{fails}{$row->{dist}}{$row->{version}}{fail}++ if($row->{state} eq 'fail');
500 0 0         $self->{fails}{$row->{dist}}{$row->{version}}{pass}++ if($row->{state} eq 'pass');
501 0           $self->{fails}{$row->{dist}}{$row->{version}}{total}++;
502             }
503             }
504              
505             # build matrix stats
506 0           my $perl = $row->{perl};
507 0           $perl =~ s/\s.*//; # only need to know the main release
508 0           $self->{perls}{$perl} = 1;
509              
510             # $self->{pass} {$row->{platform}}{$perl}{all}{$row->{dist}} = 1;
511 0           $self->{platform}{$row->{platform}}{$perl}{all}++;
512 0           $self->{osys} {$osname} {$perl}{all}{$row->{dist}} = 1;
513 0           $self->{osname} {$osname} {$perl}{all}++;
514              
515 0 0         if($row->{postdate} > $self->{dates}{THATMONTH}) {
516             # $self->{pass} {$row->{platform}}{$perl}{month}{$row->{postdate}}{$row->{dist}} = 1;
517 0           $self->{platform}{$row->{platform}}{$perl}{month}{$row->{postdate}}++;
518 0           $self->{osys} {$osname} {$perl}{month}{$row->{postdate}}{$row->{dist}} = 1;
519 0           $self->{osname} {$osname} {$perl}{month}{$row->{postdate}}++;
520             }
521              
522             # record tester activity
523 0   0       $testers->{$name}{first} ||= $row->{postdate};
524 0           $testers->{$name}{last} = $row->{postdate};
525 0           $self->{counts}{$row->{postdate}}{testers}{$name} = 1;
526              
527 0           my $day = substr($row->{fulldate},0,8);
528 0 0         $self->{build}{$day}{reports}++ if(defined $self->{build}{$day});
529             }
530              
531 0           my @row = (0, map {$row->{$_}} qw(id guid state postdate tester dist version platform perl osname osvers fulldate type));
  0            
532              
533 0           $self->{count}{posters} = $row[1];
534 0           $self->{count}{entries}++;
535 0           $self->{count}{reports}++;
536              
537 0           my $type = 'reports';
538 0 0         $self->{parent}->_log("checkpoint: count=$self->{count}{$type}, lastid=$lastid") if($self->{count}{$type} % 10000 == 0);
539              
540 0 0         if($self->{count}->{$type} % 100000 == 0) {
541             # due to the large data structures used, long runs (eg starting from
542             # scratch) should save the current state periodically.
543 0           $self->storage_write();
544 0           $self->storage_write('testers',$testers);
545 0           $self->storage_write('lastid',$lastid);
546             }
547              
548 0 0 0       if($self->{count}{$type} == 1 || ($self->{count}->{$type} % 500000) == 0) {
549 0           $self->{xrefs}{$type}->{$self->{count}->{$type}} = \@row;
550             } else {
551 0           $self->{xlast}{$type} = \@row;
552             }
553             }
554             #$self->{parent}->_log("build:3.".Dumper($self->{build}));
555             #$self->{parent}->_log("build:4.".Dumper($testers));
556              
557 0           $self->storage_write();
558 0           $self->storage_write('testers',$testers);
559 0           $self->storage_write('lastid',$lastid);
560              
561 0           for my $tester (keys %$testers) {
562 0           $self->{counts}{$testers->{$tester}{first}}{first}++;
563 0           $self->{counts}{$testers->{$tester}{last}}{last}++;
564             }
565             #$self->{parent}->_log("build:5.".Dumper($self->{counts}));
566              
567 0           my @versions = sort {versioncmp($b,$a)} keys %{$self->{perls}};
  0            
  0            
568 0           $self->{versions} = \@versions;
569              
570 0           $self->{parent}->_log("stats hash built");
571             }
572              
573             sub storage_read {
574 0     0 1   my ($self,$type) = @_;
575              
576 0 0         if($type) {
577 0           my $storage = sprintf $self->{parent}->mainstore(), $type;
578 0 0         return unless(-f $storage);
579 0           my $data = read_file($storage);
580 0           my $store = decode_json($data);
581 0           return $store->{$type};
582             }
583              
584             # for $type (qw(stats dists fails perls pass platform osys osname build counts count xrefs xlast)) {
585 0           for $type (qw(stats dists fails perls platform osys osname build counts count xrefs xlast)) {
586 0           $self->{parent}->_log("storage_read:1.type=$type");
587 0           my $storage = sprintf $self->{parent}->mainstore(), $type;
588 0 0         next unless(-f $storage);
589 0           $self->{parent}->_log("storage_read:2.storage=$storage");
590             try {
591 0     0     my $data = read_file($storage);
592 0           my $store = decode_json($data);
593 0           $self->{$type} = $store->{$type};
594             } catch {
595 0     0     $self->{parent}->_log("storage_read:3.failed to read data storage=$storage");
596 0           };
597             }
598             }
599              
600             sub storage_write {
601 0     0 1   my ($self,$type,$store) = @_;
602              
603 0 0         if($type) {
604 0 0         return unless($store);
605 0           my $data = encode_json({$type => $store});
606              
607 0           my $storage = sprintf $self->{parent}->mainstore(), $type;
608 0           my $dir = dirname($storage);
609 0 0 0       mkpath($dir) if($dir && !-e $dir);
610 0           overwrite_file($storage,$data);
611 0           return;
612             }
613              
614             # for $type (qw(stats dists fails perls pass platform osys osname build counts count xrefs xlast)) {
615 0           for $type (qw(stats dists fails perls platform osys osname build counts count xrefs xlast)) {
616 0 0         next unless($self->{$type});
617 0           my $data = encode_json({$type => $self->{$type}});
618              
619 0           my $storage = sprintf $self->{parent}->mainstore(), $type;
620 0           my $dir = dirname($storage);
621 0 0 0       mkpath($dir) if($dir && !-e $dir);
622 0           overwrite_file($storage,$data);
623             }
624             }
625              
626             =head3 Page Creation Methods
627              
628             =over 4
629              
630             =item * _write_basics
631              
632             Write out basic pages, all of which are simply built from the templates,
633             without any data processing required.
634              
635             =cut
636              
637             sub _write_basics {
638 0     0     my $self = shift;
639 0           my $directory = $self->{parent}->directory;
640 0           my $templates = $self->{parent}->templates;
641 0           my $results = "$directory/stats";
642 0           mkpath($results);
643              
644 0           $self->{parent}->_log("writing basic files");
645              
646 0           my $ranges1 = $self->{parent}->ranges('TEST_RANGES');
647 0           my $ranges2 = $self->{parent}->ranges('CPAN_RANGES');
648              
649             # additional pages not requiring metrics
650 0           my %pages = (
651             cpanmail => {},
652             response => {},
653             perform => {},
654             terms => {},
655             graphs => {},
656             graphs1 => {RANGES => $ranges1, template=>'archive', PREFIX=>'stats1' ,TITLE=>'Monthly Report Counts'},
657             graphs2 => {RANGES => $ranges1, template=>'archive', PREFIX=>'stats2' ,TITLE=>'Testers, Platforms and Perls'},
658             graphs3 => {RANGES => $ranges1, template=>'archive', PREFIX=>'stats3' ,TITLE=>'Monthly Non-Passing Reports Counts'},
659             graphs4 => {RANGES => $ranges1, template=>'archive', PREFIX=>'stats4' ,TITLE=>'Monthly Tester Fluctuations'},
660             graphs5 => {RANGES => $ranges1, template=>'archive', PREFIX=>'pcent1' ,TITLE=>'Monthly Report Percentages'},
661             graphs6 => {RANGES => $ranges2, template=>'archive', PREFIX=>'stats6' ,TITLE=>'All Distribution Uploads per Month'},
662             graphs12 => {RANGES => $ranges2, template=>'archive', PREFIX=>'stats12',TITLE=>'New Distribution Uploads per Month'}
663             );
664              
665 0           $self->{parent}->_log("building support pages");
666 0           $self->_writepage($_,$pages{$_}) for(keys %pages);
667              
668             # copy files
669 0           $self->{parent}->_log("copying static files");
670 0           my $tocopy = $self->{parent}->tocopy;
671 0           $self->{parent}->_log("files to copy = " . scalar(@$tocopy));
672 0           for my $filename (@$tocopy) {
673 0           my $source = $templates . "/$filename";
674 0 0         if(-f $source) {
675 0           my $target = $directory . "/$filename";
676 0 0         next if(-f $target);
677              
678 0           mkpath( dirname($target) );
679 0 0         if(-d dirname($target)) {
680 0           $self->{parent}->_log("copying '$source' to '$target'");
681 0           copy( $source, $target );
682             } else {
683 0           $self->{parent}->_log("copy error: Missing directory: $target");
684 0           warn "Missing directory: $target\n";
685             }
686             } else {
687 0           $self->{parent}->_log("copy error: Missing file: $source");
688 0           warn "Missing file: $source\n";
689             }
690             }
691              
692             #link files
693 0           $self->{parent}->_log("linking static files");
694 0           my $tolink = $self->{parent}->tolink;
695 0           for my $filename (keys %$tolink) {
696 0           my $source = $directory . "/$filename";
697 0           my $target = $directory . '/'.$tolink->{$filename};
698              
699 0 0         next if(-f $target);
700 0 0         if(-f $source) {
701 0           link($target,$source);
702             } else {
703 0           warn "Missing file: $source\n";
704             }
705             }
706              
707             # wget
708 0           my $cmd = sprintf "wget -O %s/sponsors.json http://iheart.cpantesters.org/home/sponsors?images=1 2>/dev/null", $directory;
709 0           $self->{parent}->_log("sponsors: '$cmd'");
710 0           system($cmd);
711             }
712              
713             =item * _write_index
714              
715             Writes out the main index page, after all stats have been calculated.
716              
717             =cut
718              
719             sub _write_index {
720 0     0     my $self = shift;
721 0           my $directory = $self->{parent}->directory;
722 0           my $templates = $self->{parent}->templates;
723              
724 0           $self->{parent}->_log("writing index file");
725              
726             # calculate growth rates
727 0           my ($d1,$d2) = (time(), time() - $ADAY);
728 0           my @date = localtime($d2);
729 0           my $date = sprintf "%04d%02d%02d", $date[5]+1900, $date[4]+1, $date[3];
730              
731 0           my @rows = $self->{parent}->{CPANSTATS}->get_query('array',"SELECT COUNT(*) FROM cpanstats WHERE type = 2 AND fulldate like '$date%'");
732 0 0         $self->{rates}{report} = $rows[0]->[0] ? $ADAY / $rows[0]->[0] * 1000 : $ADAY / 10000 * 1000;
733 0           @rows = $self->{parent}->{CPANSTATS}->get_query('array',"SELECT COUNT(*) FROM uploads WHERE released > $d2 and released < $d1");
734 0 0         $self->{rates}{distro} = $rows[0]->[0] ? $ADAY / $rows[0]->[0] * 1000 : $ADAY / 60 * 1000;
735              
736 0 0         $self->{rates}{report} = 1000 if($self->{rates}{report} < 1000);
737 0 0         $self->{rates}{distro} = 1000 if($self->{rates}{distro} < 1000);
738              
739             # index page
740             my %pages = (
741             index => {
742             LASTMONTH => $self->{dates}{LASTMONTH},
743             report_count => $self->{count}{reports},
744             distro_count => $self->{count}{distros},
745             report_rate => $self->{rates}{report},
746             distro_rate => $self->{rates}{distro}
747             },
748 0           );
749              
750 0           $self->_writepage($_,$pages{$_}) for(keys %pages);
751             }
752              
753             =item * _report_interesting
754              
755             Generates the interesting stats page
756              
757             =cut
758              
759             sub _report_interesting {
760 0     0     my $self = shift;
761 0           my %tvars;
762              
763 0           $self->{parent}->_log("building interesting page");
764              
765 0           $tvars{sizes}{reports} = $self->{sizes}{dir_reports};
766              
767 0           my (@bydist,@byvers);
768 0           my $inx = 20;
769 0 0         for my $dist (sort {$self->{dists}{$b}{ALL} <=> $self->{dists}{$a}{ALL} || $a cmp $b} keys %{$self->{dists}}) {
  0            
  0            
770 0           push @bydist, [$self->{dists}{$dist}{ALL},$dist];
771 0 0         last if(--$inx <= 0);
772             }
773 0           $inx = 20;
774 0 0         for my $dist (sort {$self->{dists}{$b}{IXL} <=> $self->{dists}{$a}{IXL} || $a cmp $b} keys %{$self->{dists}}) {
  0            
  0            
775 0           push @byvers, [$self->{dists}{$dist}{IXL},$dist,$self->{dists}{$dist}{VER}];
776 0 0         last if(--$inx <= 0);
777             }
778              
779 0           $tvars{BYDIST} = \@bydist;
780 0           $tvars{BYVERS} = \@byvers;
781              
782 0           my $type = 'reports';
783 0   0       $self->{count}{$type} ||= 0;
784 0 0         $self->{xrefs}{$type}{$self->{count}{$type}} = $self->{xlast} ? $self->{xlast}{$type} : [];
785              
786 0           for my $key (sort {$b <=> $a} keys %{ $self->{xrefs}{$type} }) {
  0            
  0            
787 0           my @row = @{ $self->{xrefs}{$type}{$key} };
  0            
788              
789 0           $row[0] = $key;
790 0 0         $row[3] = uc $row[3] if($row[3]);
791 0 0 0       ($row[5]) = $self->{parent}->tester($row[5]) if($row[5] && $row[5] =~ /\@/);
792 0           push @{ $tvars{ uc($type) } }, \@row;
  0            
793             }
794              
795 0           my @headings = qw( count grade postdate tester dist version platform perl osname osvers fulldate );
796 0           $tvars{HEADINGS} = \@headings;
797 0           $self->_writepage('interest',\%tvars);
798             }
799              
800             =item * _report_cpan
801              
802             Generates the statistic pages that relate specifically to CPAN.
803              
804             =cut
805              
806             sub _report_cpan {
807 0     0     my $self = shift;
808 0           my (%authors,%distros,%tvars);
809              
810 0           $self->{parent}->_log("building cpan trends page");
811              
812 0           my $directory = $self->{parent}->directory;
813 0           my $results = "$directory/stats";
814 0           mkpath($results);
815              
816 0           my $next = $self->{parent}->{CPANSTATS}->iterator('hash',"SELECT * FROM uploads ORDER BY released");
817 0           while(my $row = $next->()) {
818 0 0         next if($row->{dist} eq 'perl');
819              
820 0           my $date = _parsedate($row->{released});
821 0           $authors{$row->{author}}{count}++;
822 0           $distros{$row->{dist}}{count}++;
823 0           $authors{$row->{author}}{dist}{$row->{dist}}++;
824 0 0         $authors{$row->{author}}{dists}++ if($authors{$row->{author}}{dist}{$row->{dist}} == 1);
825              
826 0           $self->{counts}{$date}{authors}{$row->{author}}++;
827 0           $self->{counts}{$date}{distros}{$row->{dist}}++;
828              
829 0 0         $self->{counts}{$date}{newauthors}++ if($authors{$row->{author}}{count} == 1);
830 0 0         $self->{counts}{$date}{newdistros}++ if($distros{$row->{dist}}{count} == 1);
831              
832 0           $self->{pause}{$date}++;
833             }
834              
835 0 0         my $stat6 = IO::File->new("$results/stats6.txt",'w+') or die "Cannot write to file [$results/stats6.txt]: $!\n";
836 0           print $stat6 "#DATE,AUTHORS,DISTROS\n";
837 0 0         my $stat12 = IO::File->new("$results/stats12.txt",'w+') or die "Cannot write to file [$results/stats12.txt]: $!\n";
838 0           print $stat12 "#DATE,AUTHORS,DISTROS\n";
839              
840 0           for my $date (sort keys %{ $self->{counts} }) {
  0            
841 0           my $authors = scalar(keys %{ $self->{counts}{$date}{authors} });
  0            
842 0           my $distros = scalar(keys %{ $self->{counts}{$date}{distros} });
  0            
843              
844 0   0       $self->{counts}{$date}{newauthors} ||= 0;
845 0   0       $self->{counts}{$date}{newdistros} ||= 0;
846              
847 0           print $stat6 "$date,$authors,$distros\n";
848 0           print $stat12 "$date,$self->{counts}{$date}{newauthors},$self->{counts}{$date}{newdistros}\n";
849              
850             # print $stat6 "$date,$authors\n";
851             # print $stat7 "$date,$distros\n";
852             # print $stat12 "$date,$self->{counts}{$date}{newauthors}\n";
853             # print $stat13 "$date,$self->{counts}{$date}{newdistros}\n";
854             }
855              
856 0           $stat6->close;
857             # $stat7->close;
858 0           $stat12->close;
859             # $stat13->close;
860              
861 0           $tvars{maxyear} = DateTime->now->year;
862 0           $self->_writepage('trends',\%tvars);
863              
864 0           $self->_report_new_distros();
865 0           $self->_report_submissions();
866              
867 0           $self->{parent}->_log("building cpan leader page");
868              
869 0           my $query = 'SELECT x.author,COUNT(x.dist) AS count FROM ixlatest AS x '.
870             'INNER JOIN uploads AS u ON u.dist=x.dist AND u.version=x.version '.
871             "WHERE u.type != 'backpan' GROUP BY x.author";
872 0           my @latest = $self->{parent}->{CPANSTATS}->get_query('hash',$query);
873 0           my (@allcurrent,@alluploads,@allrelease,@alldistros);
874 0           my $inx = 1;
875 0           for my $latest (sort {$b->{count} <=> $a->{count}} @latest) {
  0            
876 0           push @allcurrent, {inx => $inx++, count => $latest->{count}, name => $latest->{author}};
877 0 0         last if($inx > 20);
878             }
879              
880 0           $inx = 1;
881 0 0         for my $author (sort {$authors{$b}{dists} <=> $authors{$a}{dists} || $a cmp $b} keys %authors) {
  0            
882 0           push @alluploads, {inx => $inx++, count => $authors{$author}{dists}, name => $author};
883 0 0         last if($inx > 20);
884             }
885              
886 0           $inx = 1;
887 0 0         for my $author (sort {$authors{$b}{count} <=> $authors{$a}{count} || $a cmp $b} keys %authors) {
  0            
888 0           push @allrelease, {inx => $inx++, count => $authors{$author}{count}, name => $author};
889 0 0         last if($inx > 20);
890             }
891              
892 0           $inx = 1;
893 0 0         for my $distro (sort {$distros{$b}{count} <=> $distros{$a}{count} || $a cmp $b} keys %distros) {
  0            
894 0           push @alldistros, {inx => $inx++, count => $distros{$distro}{count}, name => $distro};
895 0 0         last if($inx > 20);
896             }
897              
898 0           $tvars{allcurrent} = \@allcurrent;
899 0           $tvars{alluploads} = \@alluploads;
900 0           $tvars{allrelease} = \@allrelease;
901 0           $tvars{alldistros} = \@alldistros;
902              
903 0           $self->_writepage('leadercpan',\%tvars);
904              
905              
906 0           $self->{parent}->_log("building cpan interesting stats page (part 1)");
907              
908 0           $tvars{sizes}{cpan} = $self->{sizes}{dir_cpan};
909 0           $tvars{sizes}{backpan} = $self->{sizes}{dir_backpan};
910              
911 0           $tvars{authors}{total} = $self->_count_mailrc();
912 0           my @rows = $self->{parent}->{CPANSTATS}->get_query('array',"SELECT COUNT(distinct author) FROM uploads");
913 0           $tvars{authors}{active} = $rows[0]->[0];
914 0           $tvars{authors}{inactive} = $tvars{authors}{total} - $rows[0]->[0];
915              
916 0           @rows = $self->{parent}->{CPANSTATS}->get_query('array',"SELECT COUNT(distinct dist) FROM uploads WHERE type != 'backpan'");
917 0           $tvars{distros}{uploaded1} = $rows[0]->[0];
918 0           $self->{count}{distros} = $rows[0]->[0];
919 0           @rows = $self->{parent}->{CPANSTATS}->get_query('array',"SELECT COUNT(distinct dist) FROM uploads");
920 0           $tvars{distros}{uploaded2} = $rows[0]->[0];
921 0           $tvars{distros}{uploaded3} = $tvars{distros}{uploaded2} - $tvars{distros}{uploaded1};
922              
923 0           @rows = $self->{parent}->{CPANSTATS}->get_query('array',"SELECT COUNT(*) FROM uploads WHERE type != 'backpan'");
924 0           $tvars{distros}{uploaded4} = $rows[0]->[0];
925 0           @rows = $self->{parent}->{CPANSTATS}->get_query('array',"SELECT COUNT(*) FROM uploads");
926 0           $tvars{distros}{uploaded5} = $rows[0]->[0];
927 0           $tvars{distros}{uploaded6} = $tvars{distros}{uploaded5} - $tvars{distros}{uploaded4};
928              
929              
930 0           $self->{parent}->_log("building cpan interesting stats page (part 2)");
931              
932 0           my (%stats,%dists,%pause,%last);
933 0           $next = $self->{parent}->{CPANSTATS}->iterator('hash','SELECT * FROM uploads ORDER BY released');
934 0           while(my $row = $next->()) {
935 0           $stats{vcounter}++;
936 0 0         if($stats{vcounter} % 10000 == 0) {
937 0           $stats{'uploads'}{$stats{vcounter}}{dist} = $row->{dist};
938 0           $stats{'uploads'}{$stats{vcounter}}{vers} = $row->{version};
939 0           $stats{'uploads'}{$stats{vcounter}}{date} = $row->{released};
940 0           $stats{'uploads'}{$stats{vcounter}}{name} = $row->{author};
941             }
942              
943 0           $last{'uploads'}{counter} = $stats{vcounter};
944 0           $last{'uploads'}{dist} = $row->{dist};
945 0           $last{'uploads'}{vers} = $row->{version};
946 0           $last{'uploads'}{date} = $row->{released};
947 0           $last{'uploads'}{name} = $row->{author};
948              
949 0 0         unless($pause{$row->{author}}) {
950 0           $pause{$row->{author}} = 1;
951 0           $stats{pcounter}++;
952 0 0         if($stats{pcounter} % 1000 == 0) {
953 0           $stats{'uploaders'}{$stats{pcounter}}{dist} = $row->{dist};
954 0           $stats{'uploaders'}{$stats{pcounter}}{vers} = $row->{version};
955 0           $stats{'uploaders'}{$stats{pcounter}}{date} = $row->{released};
956 0           $stats{'uploaders'}{$stats{pcounter}}{name} = $row->{author};
957             }
958              
959 0           $last{'uploaders'}{counter} = $stats{pcounter};
960 0           $last{'uploaders'}{dist} = $row->{dist};
961 0           $last{'uploaders'}{vers} = $row->{version};
962 0           $last{'uploaders'}{date} = $row->{released};
963 0           $last{'uploaders'}{name} = $row->{author};
964             }
965              
966 0 0         next if($dists{$row->{dist}});
967              
968 0           $dists{$row->{dist}} = 1;
969 0           $stats{dcounter}++;
970 0 0         if($stats{dcounter} % 5000 == 0) {
971 0           $stats{'distributions'}{$stats{dcounter}}{dist} = $row->{dist};
972 0           $stats{'distributions'}{$stats{dcounter}}{vers} = $row->{version};
973 0           $stats{'distributions'}{$stats{dcounter}}{date} = $row->{released};
974 0           $stats{'distributions'}{$stats{dcounter}}{name} = $row->{author};
975             }
976              
977 0           $last{'distributions'}{counter} = $stats{dcounter};
978 0           $last{'distributions'}{dist} = $row->{dist};
979 0           $last{'distributions'}{vers} = $row->{version};
980 0           $last{'distributions'}{date} = $row->{released};
981 0           $last{'distributions'}{name} = $row->{author};
982             }
983              
984 0           for my $type (qw(distributions uploads uploaders)) {
985 0           my @list;
986 0           $stats{$type}{$last{$type}{counter}} = $last{$type};
987 0           for my $count (sort {$a <=> $b} keys %{$stats{$type}}) {
  0            
  0            
988 0           my @date = localtime($stats{$type}{$count}{date});
989 0           my $date = sprintf "%04d-%02d-%02d %02d:%02d:%02d", $date[5]+1900, $date[4]+1, $date[3], $date[2], $date[1], $date[0] ;
990 0           $stats{$type}{$count}{counter} = $count;
991 0           $stats{$type}{$count}{date} = $date;
992 0           push @list, $stats{$type}{$count};
993             }
994 0 0         $tvars{$type} = \@list if(@list);
995             }
996              
997 0           $self->_writepage('statscpan',\%tvars);
998              
999              
1000 0           $self->{parent}->_log("building cpan/backpan 100s");
1001              
1002             # calculate CPAN 100 data
1003 0           $self->_count_mailrc();
1004 0           @rows = $self->{parent}->{CPANSTATS}->get_query('hash',"SELECT t.author,t.count FROM (SELECT author,count(distinct dist) AS count FROM uploads WHERE type!='backpan' GROUP BY author ORDER BY count DESC LIMIT 100) AS t WHERE t.count >= 100");
1005 0           my $fh = IO::File->new(">$results/cpan100.csv");
1006 0           printf $fh "# DATE: %s\n", DateTime->now->datetime;
1007 0           print $fh "#Pause,Count,Name\n";
1008 0           for my $row (@rows) {
1009 0   0       printf $fh "%s,%d,%s\n", $row->{author}, $row->{count}, $self->{alias}{$row->{author}}||'???';
1010             }
1011 0           $fh->close;
1012              
1013             # calculate BACKCPAN 100 data
1014 0           @rows = $self->{parent}->{CPANSTATS}->get_query('hash',"SELECT t.author,t.count FROM (SELECT author,count(distinct dist) AS count FROM uploads GROUP BY author ORDER BY count DESC LIMIT 100) AS t WHERE t.count >= 100");
1015 0           $fh = IO::File->new(">$results/backpan100.csv");
1016 0           printf $fh "# DATE: %s\n", DateTime->now->datetime;
1017 0           print $fh "#Pause,Count,Name\n";
1018 0           for my $row (@rows) {
1019 0   0       printf $fh "%s,%d,%s\n", $row->{author}, $row->{count}, $self->{alias}{$row->{author}}||'???';
1020             }
1021 0           $fh->close;
1022             }
1023              
1024             sub _report_new_distros {
1025 0     0     my $self = shift;
1026              
1027 0           $self->{parent}->_log("building new distro pages");
1028              
1029 0           my (%seen,%allversions,%newversions);
1030 0           my $start_year = 1995;
1031 0           my $start_month = 8;
1032 0           my $this_year = DateTime->now->year;
1033 0           my $sql = 'select author,dist,version,from_unixtime(released) as reldate from uploads where released >= ? AND released < ? order by released';
1034              
1035 0           for my $year (1995 .. $this_year) {
1036 0           my $tvars = { template => 'newdistros', year => $year };
1037              
1038 0           for my $month (1 .. 12) {
1039 0 0 0       next if($year == $start_year && $month < $start_month);
1040              
1041 0           my $thismon = DateTime->new( year => $year, month => $month, day => 1, hour => 0, minute => 0, second => 0);
1042 0           my $nextmon = DateTime->new( year => $thismon->clone->add( months => 1 )->year, month => $thismon->clone->add( months => 1 )->month, day => 1, hour => 0, minute => 0, second => 0);
1043              
1044 0 0         last if($thismon > DateTime->now);
1045              
1046 0           $tvars->{newdistros}{$month}{month} = $thismon->month_name;
1047 0           $tvars->{newdistros}{$month}{counter} = 0;
1048              
1049 0           my @rows = $self->{parent}->{CPANSTATS}->get_query('hash',$sql,$thismon->epoch(),$nextmon->epoch());
1050 0           for my $row (@rows) {
1051 0           $allversions{$row->{version}}++;
1052              
1053 0 0         next if($seen{$row->{dist}});
1054              
1055 0           $seen{$row->{dist}} = 1;
1056 0           push @{$tvars->{newdistros}{$month}{dists}},
1057             {
1058             author => $row->{author},
1059             dist => $row->{dist},
1060             version => $row->{version},
1061             reldate => $row->{reldate}
1062 0           };
1063              
1064 0           $tvars->{newdistros}{$month}{counter}++;
1065 0           $newversions{$row->{version}}++;
1066             }
1067             }
1068              
1069 0           $self->_writepage("newdistros/$year",$tvars);
1070             }
1071              
1072 0           $self->{parent}->_log("building new distro versions page");
1073              
1074 0           my (@allversions,@newversions);
1075 0 0         for my $v (sort {$allversions{$b} <=> $allversions{$a} || $a cmp $b} keys %allversions) {
  0            
1076 0           push @allversions, { version => $v, count => $allversions{$v} };
1077             }
1078 0           my $tvars = { template => 'versions', type => 'All', versions => \@allversions };
1079 0           $self->_writepage("newdistros/allversions",$tvars);
1080              
1081 0 0         for my $v (sort {$newversions{$b} <=> $newversions{$a} || $a cmp $b} keys %newversions) {
  0            
1082 0           push @newversions, { version => $v, count => $newversions{$v} };
1083             }
1084 0           $tvars = { template => 'versions', type => 'New', versions => \@newversions };
1085 0           $self->_writepage("newdistros/newversions",$tvars);
1086             }
1087              
1088             sub _report_submissions {
1089 0     0     my $self = shift;
1090              
1091 0           $self->{parent}->_log("building submission data files");
1092              
1093 0           my $sql = 'select from_unixtime(released) as reldate from uploads';
1094              
1095 0           my $now = DateTime->now;
1096 0           my (%hours,%days,%months,%dotw,%tvars);
1097              
1098 0           my $next = $self->{parent}->{CPANSTATS}->iterator('hash',$sql);
1099 0           while( my $row = $next->() ) {
1100 0 0 0       next unless($row->{reldate} && $row->{reldate} =~ /^(\d+)\-(\d+)\-(\d+).(\d+):(\d+):(\d+)/);
1101 0           my ($year,$month,$day,$hour,$minute,$second) = ($1,$2,$3,$4,$5,$6);
1102              
1103 0           my $date = DateTime->new( year => $year, month => $month, day => $day, hour => $hour, minute => $minute, second => $second );
1104 0           my $dotw = $date->day_of_week;
1105              
1106 0           $months{that}{$month}++;
1107 0           $dotw{that}{$dotw}++;
1108 0           $days{that}{$day}++;
1109 0           $hours{that}{$hour}++;
1110              
1111 0 0         if($year != $now->year) {
    0          
1112 0           $months{this}{$month}++;
1113 0           $dotw{this}{$dotw}++;
1114             } elsif($date->week_number != $now->week_number) {
1115 0           $dotw{this}{$dotw}++;
1116             }
1117              
1118 0 0 0       if(( $year != $now->year) ||
      0        
1119             ( $year == $now->year && $month != $now->month) ) {
1120 0           $days{this}{$day}++;
1121             }
1122              
1123 0 0 0       if(( $year != $now->year) ||
      0        
      0        
      0        
      0        
1124             ( $year == $now->year && $month != $now->month) ||
1125             ( $year == $now->year && $month == $now->month && $day != $now->day) ) {
1126 0           $hours{this}{$hour}++;
1127             }
1128             }
1129              
1130 0           my $directory = $self->{parent}->directory;
1131 0           my $results = "$directory/rates";
1132 0           mkpath($results);
1133              
1134 0           $self->{parent}->_log("writing $results/submit1.txt");
1135 0           my $fh = IO::File->new(">$results/submit1.txt");
1136 0           print $fh "#INDEX,EXCLUSIVE,INCLUSIVE\n";
1137 0           for my $month (sort {$a <=> $b} keys %{$months{this}}) {
  0            
  0            
1138 0           printf $fh "%d,%d,%d\n", $month, $months{this}{$month}, $months{that}{$month};
1139             }
1140 0           $fh->close;
1141              
1142 0           $self->{parent}->_log("writing $results/submit2.txt");
1143 0           $fh = IO::File->new(">$results/submit2.txt");
1144 0           print $fh "#INDEX,EXCLUSIVE,INCLUSIVE\n";
1145 0           for my $dotw (sort {$a <=> $b} keys %{$dotw{this}}) {
  0            
  0            
1146 0           printf $fh "%d,%d,%d\n", $dotw, $dotw{this}{$dotw}, $dotw{that}{$dotw};
1147             }
1148 0           $fh->close;
1149              
1150 0           $self->{parent}->_log("writing $results/submit3.txt");
1151 0           $fh = IO::File->new(">$results/submit3.txt");
1152 0           print $fh "#INDEX,EXCLUSIVE,INCLUSIVE\n";
1153 0           for my $day (sort {$a <=> $b} keys %{$days{this}}) {
  0            
  0            
1154 0           printf $fh "%d,%d,%d\n", $day, $days{this}{$day}, $days{that}{$day};
1155             }
1156 0           $fh->close;
1157              
1158 0           $self->{parent}->_log("writing $results/submit4.txt");
1159 0           $fh = IO::File->new(">$results/submit4.txt");
1160 0           print $fh "#INDEX,EXCLUSIVE,INCLUSIVE\n";
1161 0           for my $hour (sort {$a <=> $b} keys %{$hours{this}}) {
  0            
  0            
1162 0           printf $fh "%d,%d,%d\n", $hour, $hours{this}{$hour}, $hours{that}{$hour};
1163             }
1164 0           $fh->close;
1165              
1166 0           $self->_writepage('rates',\%tvars);
1167             }
1168              
1169             sub _update_noreports {
1170 0     0     my $self = shift;
1171              
1172 0           $self->{parent}->_log("start update_noreports");
1173              
1174 0           my %phrasebook = (
1175             'DISTS' => q{ SELECT * FROM ixlatest WHERE oncpan=1 ORDER BY released DESC},
1176             'LIST' => q{ SELECT osname,count(*) AS count
1177             FROM cpanstats
1178             WHERE dist=? AND version=?
1179             GROUP BY osname},
1180             'DELETE' => q{DELETE FROM noreports WHERE dist=?},
1181             'INSERT' => q{INSERT INTO noreports (dist,version,osname) VALUES (?,?,?)}
1182             );
1183              
1184 0           my %dists;
1185 0           my $osnames = $self->{parent}->osnames();
1186 0           my $noreports = $self->{parent}->noreports();
1187 0           my $grace = time - 2419200;
1188              
1189 0           my @rows = $self->{parent}->{CPANSTATS}->get_query('hash',$phrasebook{DISTS});
1190 0           for my $row (@rows) {
1191 0 0 0       next if($noreports && $row->{dist} =~ /^$noreports$/);
1192 0 0         next if($dists{$row->{dist}}); # ignore older versions (by other authors)
1193 0 0         next if($row->{released} >= $grace); # ignore recently released distributions
1194 0           for my $osname (keys %$osnames) {
1195 0           $dists{$row->{dist}}{$row->{version}}{$osname} = 1;
1196             }
1197             }
1198              
1199 0           for my $dist (keys %dists) {
1200 0           for my $version (keys %{$dists{$dist}}) {
  0            
1201 0           @rows = $self->{parent}->{CPANSTATS}->get_query('hash',$phrasebook{LIST},$dist,$version);
1202 0           for my $row (@rows) {
1203 0           delete $dists{$dist}{$version}{$row->{osname}};
1204             }
1205              
1206 0           $self->{parent}->{CPANSTATS}->do_query($phrasebook{DELETE},$dist);
1207             $self->{parent}->{CPANSTATS}->do_query($phrasebook{INSERT},$dist,$version,$_)
1208 0           for(keys %{$dists{$dist}{$version}});
  0            
1209             }
1210             }
1211              
1212 0           $self->{parent}->_log("finish update_noreports");
1213             }
1214              
1215             sub _build_noreports {
1216 0     0     my $self = shift;
1217 0           my $grace = time - 2419200;
1218            
1219 0           my $noreports = $self->{parent}->noreports();
1220 0           my $osnames = $self->{parent}->osnames();
1221              
1222 0           my $query =
1223             'SELECT x.*,count(s.id) as count FROM ixlatest AS x '.
1224             'LEFT JOIN release_summary AS s ON (x.dist=s.dist AND x.version=s.version) '.
1225             'GROUP BY x.dist,x.version ORDER BY x.released DESC';
1226 0           my $next = $self->{parent}->{CPANSTATS}->iterator('hash',$query);
1227              
1228 0           my (@rows,%dists);
1229 0           while(my $row = $next->()) {
1230 0 0 0       next if($noreports && $row->{dist} =~ /^$noreports$/);
1231 0 0         next if($dists{$row->{dist}});
1232 0           $dists{$row->{dist}} = $row->{released};
1233              
1234 0 0         next if($row->{count} > 0);
1235 0 0 0       next if(!$row->{oncpan} || $row->{oncpan} != 1);
1236 0 0         next if($row->{released} > $grace);
1237              
1238 0           my @dt = localtime($row->{released});
1239 0           $row->{datetime} = sprintf "%04d-%02d-%02d", $dt[5]+1900,$dt[4]+1,$dt[3];
1240 0           push @rows, $row;
1241             }
1242              
1243 0           my @osnames = map { { osname => $_, ostitle => $osnames->{$_} } } sort {$osnames->{$a} cmp $osnames->{$b}} keys %$osnames;
  0            
  0            
1244 0           my $tvars = { rows => \@rows, rowcount => scalar(@rows), template => 'noreports', osnames => \@osnames, ostitle => 'ALL' };
1245 0           $self->_writepage('noreports/all',$tvars);
1246              
1247             # html files
1248 0           $query = q[select i.* from noreports r inner join ixlatest i on i.dist=r.dist and i.version=r.version where r.osname=? and i.oncpan=1 order by i.dist];
1249 0           for my $os (@osnames) {
1250 0           my @dists = $self->{parent}->{CPANSTATS}->get_query('hash',$query,$os->{osname});
1251 0           for(@dists) {
1252 0           my @dt = localtime($_->{released});
1253 0           $_->{datetime} = sprintf "%04d-%02d-%02d", $dt[5]+1900,$dt[4]+1,$dt[3];
1254             }
1255 0           $tvars = { rows => \@dists, rowcount => scalar(@dists), template => 'noreports', osnames => \@osnames, ostitle => $os->{ostitle}, osname => $os->{osname} };
1256 0           $self->_writepage('noreports/'.$os->{osname},$tvars);
1257             }
1258              
1259             # data files
1260 0           $query = q[select u.* from noreports r inner join uploads u on u.dist=r.dist and u.version=r.version where r.osname=? and u.type='cpan' order by u.dist];
1261 0           for my $os (@osnames) {
1262 0           my @dists = $self->{parent}->{CPANSTATS}->get_query('hash',$query,$os->{osname});
1263 0           for(@dists) {
1264 0           my @dt = localtime($_->{released});
1265 0           $_->{datetime} = sprintf "%04d-%02d-%02d", $dt[5]+1900,$dt[4]+1,$dt[3];
1266             }
1267 0           $tvars = { rows => \@dists, rowcount => scalar(@dists), template => 'noreports', extension => 'csv', osnames => \@osnames, ostitle => $os->{ostitle} };
1268 0           $self->_writepage('noreports/'.$os->{osname},$tvars);
1269             }
1270             }
1271              
1272             sub _missing_in_action {
1273 0     0     my $self = shift;
1274 0           my (%tvars,%missing,@missing);
1275              
1276 0           $self->{parent}->_log("building missing in action page");
1277              
1278 0           my $missing = $self->{parent}->missing();
1279 0 0         return unless(-f $missing);
1280 0 0         my $fh = IO::File->new($missing) or return;
1281 0           while(<$fh>) {
1282 0           chomp;
1283 0           my ($pauseid,$timestamp,$reason) = /^([a-z]+)[ \t]+([^+]+\+0[01]00) (.*)/i;
1284 0 0         next unless($pauseid);
1285 0           $reason =~ s/</&lt;/g;
1286 0           $reason =~ s/>/&gt;/g;
1287 0           $missing{$pauseid}{timestamp} = $timestamp;
1288 0           $missing{$pauseid}{reason} = $reason;
1289             }
1290 0           $fh->close;
1291              
1292 0           for my $pauseid (sort keys %missing) {
1293 0           push @missing, { pauseid => $pauseid, timestamp => $missing{$pauseid}{timestamp}, reason => $missing{$pauseid}{reason} };
1294             }
1295              
1296 0 0         $tvars{missing} = \@missing if(@missing);
1297 0           $self->_writepage('missing',\%tvars);
1298             }
1299              
1300             sub _build_osname_matrix {
1301 0     0     my $self = shift;
1302              
1303 0           my %tvars = (template => 'osmatrix', FULL => 1, MONTH => 0);
1304 0           $self->{parent}->_log("building OS matrix - 1");
1305 0           my $CONTENT = $self->_osname_matrix($self->{versions},'all',1);
1306 0           $tvars{CONTENT} = $CONTENT;
1307 0           $self->_writepage('osmatrix-full',\%tvars);
1308              
1309 0           %tvars = (template => 'osmatrix', FULL => 1, MONTH => 0, layout => 'layout-wide');
1310 0           $tvars{CONTENT} = $CONTENT;
1311 0           $self->{parent}->_log("building OS matrix - 2");
1312 0           $self->_writepage('osmatrix-full-wide',\%tvars);
1313              
1314 0           %tvars = (template => 'osmatrix', FULL => 1, MONTH => 1);
1315 0           $self->{parent}->_log("building OS matrix - 3");
1316 0           $CONTENT = $self->_osname_matrix($self->{versions},'month',1);
1317 0           $tvars{CONTENT} = $CONTENT;
1318 0           $self->_writepage('osmatrix-full-month',\%tvars);
1319              
1320 0           %tvars = (template => 'osmatrix', FULL => 1, MONTH => 1, layout => 'layout-wide');
1321 0           $tvars{CONTENT} = $CONTENT;
1322 0           $self->{parent}->_log("building OS matrix - 4");
1323 0           $self->_writepage('osmatrix-full-month-wide',\%tvars);
1324              
1325 0           my @vers = grep {!/^5\.(11|9|7)\./} @{$self->{versions}};
  0            
  0            
1326              
1327 0           %tvars = (template => 'osmatrix', FULL => 0, MONTH => 0);
1328 0           $self->{parent}->_log("building OS matrix - 5");
1329 0           $CONTENT = $self->_osname_matrix(\@vers,'all',0);
1330 0           $tvars{CONTENT} = $CONTENT;
1331 0           $self->_writepage('osmatrix',\%tvars);
1332              
1333 0           %tvars = (template => 'osmatrix', FULL => 0, MONTH => 0, layout => 'layout-wide');
1334 0           $tvars{CONTENT} = $CONTENT;
1335 0           $self->{parent}->_log("building OS matrix - 6");
1336 0           $self->_writepage('osmatrix-wide',\%tvars);
1337              
1338 0           %tvars = (template => 'osmatrix', FULL => 0, MONTH => 1);
1339 0           $self->{parent}->_log("building OS matrix - 7");
1340 0           $CONTENT = $self->_osname_matrix(\@vers,'month',0);
1341 0           $tvars{CONTENT} = $CONTENT;
1342 0           $self->_writepage('osmatrix-month',\%tvars);
1343              
1344 0           %tvars = (template => 'osmatrix', FULL => 0, MONTH => 1, layout => 'layout-wide');
1345 0           $tvars{CONTENT} = $CONTENT;
1346 0           $self->{parent}->_log("building OS matrix - 8");
1347 0           $self->_writepage('osmatrix-month-wide',\%tvars);
1348             }
1349              
1350             sub _osname_matrix {
1351 0     0     my $self = shift;
1352 0 0         my $vers = shift or return '';
1353 0           my $type = shift;
1354 0   0       my $full = shift || 0;
1355 0 0         return '' unless(@$vers);
1356              
1357 0           my %totals;
1358 0           for my $osname (sort keys %{$self->{osys}}) {
  0            
1359 0 0         if($type eq 'month') {
1360 0           my $check = 0;
1361 0 0         for my $perl (@$vers) { $check++ if(defined $self->{osys}{$osname}{$perl}{month}{$self->{dates}{LASTMONTH}}) }
  0            
1362 0 0         next if($check == 0);
1363             }
1364 0           for my $perl (@$vers) {
1365             my $count = defined $self->{osys}{$osname}{$perl}{$type}
1366             ? ($type eq 'month'
1367 0           ? scalar(keys %{$self->{osys}{$osname}{$perl}{month}{$self->{dates}{LASTMONTH}}})
1368 0 0         : scalar(keys %{$self->{osys}{$osname}{$perl}{$type}}))
  0 0          
1369             : 0;
1370 0   0       $count ||= 0;
1371 0           $totals{os}{$osname} += $count;
1372 0           $totals{perl}{$perl} += $count;
1373             }
1374             }
1375              
1376 0           my $index = 0;
1377             my $content =
1378             "\n"
1379             . '<table class="matrix" summary="OS/Perl Matrix">'
1380             . "\n"
1381             . '<tr><th>OS/Perl</th><th></th><th>'
1382             . join( "</th><th>", @$vers )
1383             . '</th><th></th><th>OS/Perl</th></tr>'
1384             . "\n"
1385             . '<tr><th></th><th class="totals">Totals</th><th class="totals">'
1386 0 0         . join( '</th><th class="totals">', map {$totals{perl}{$_}||0} @$vers )
  0            
1387             . '</th><th class="totals">Totals</th><th></th></tr>';
1388              
1389 0 0         for my $osname (sort {$totals{os}{$b} <=> $totals{os}{$a} || $a cmp $b} keys %{$totals{os}}) {
  0            
  0            
1390 0 0         if($type eq 'month') {
1391 0           my $check = 0;
1392 0 0         for my $perl (@$vers) { $check++ if(defined $self->{osys}{$osname}{$perl}{month}{$self->{dates}{LASTMONTH}}) }
  0            
1393 0 0         next if($check == 0);
1394             }
1395 0           $content .= "\n" . '<tr><th>' . $osname . '</th><th class="totals">' . $totals{os}{$osname} . '</th>';
1396 0           for my $perl (@$vers) {
1397             my $count = defined $self->{osys}{$osname}{$perl}{$type}
1398             ? ($type eq 'month'
1399 0           ? scalar(keys %{$self->{osys}{$osname}{$perl}{month}{$self->{dates}{LASTMONTH}}})
1400 0 0         : scalar(keys %{$self->{osys}{$osname}{$perl}{$type}}))
  0 0          
1401             : 0;
1402 0   0       $count ||= 0;
1403 0 0         if($count) {
1404 0 0         if($self->{list}{osname}{$osname}{$perl}{$type}) {
1405 0           $index = $self->{list}{osname}{$osname}{$perl}{$type};
1406             } else {
1407 0 0         my %tvars = (template => 'distlist', OS => 1, MONTH => ($type eq 'month' ? 1 : 0), FULL => $full);
1408 0           my @list = sort keys %{$self->{osys}{$osname}{$perl}{$type}};
  0            
1409 0           $tvars{dists} = \@list;
1410 0           $tvars{vplatform} = $osname;
1411 0           $tvars{vperl} = $perl;
1412 0           $tvars{count} = $count;
1413              
1414 0           $index = join('-','osys', $type, $osname, $perl);
1415 0           $index =~ s/[^-.\w]/-/g;
1416 0           $index = 'matrix/' . $index;
1417 0           $self->{list}{osname}{$osname}{$perl}{$type} = $index;
1418 0           $self->_writepage($index,\%tvars);
1419             }
1420             }
1421              
1422 0 0         my $number = ($type eq 'month' ? $self->{osname}{$osname}{$perl}{month}{$self->{dates}{LASTMONTH}} : $self->{osname}{$osname}{$perl}{$type});
1423 0   0       $number ||= 0;
1424 0           my $class = 'none';
1425 0 0         $class = 'some' if($number > 0);
1426 0 0         $class = 'more' if($number > $matrix_limits{$type}->[0]);
1427 0 0         $class = 'lots' if($number > $matrix_limits{$type}->[1]);
1428              
1429             # count = number of distributions with a pass
1430             # number = number of reports submitted for that platform/perl
1431 0 0         $content .= qq{<td class="$class">}
1432             . ($count ? qq|<a href="$index.html" title="Distribution List for $osname/$perl">$count</a><br />$number| : '-')
1433             . '</td>';
1434             }
1435 0           $content .= '<th class="totals">' . $totals{os}{$osname} . '</th><th>' . $osname . '</th>';
1436 0           $content .= '</tr>';
1437             }
1438              
1439             $content .=
1440             "\n"
1441             . '<tr><th></th><th class="totals">Totals</th><th class="totals">'
1442 0 0         . join( '</th><th class="totals">', map {$totals{perl}{$_}||0} @$vers )
  0            
1443             . '</th><th class="totals">Totals</th><th></th></tr>'
1444             . "\n"
1445             . '<tr><th>OS/Perl</th><th></th><th>'
1446             . join( "</th><th>", @$vers )
1447             . '</th><th></th><th>OS/Perl</th></tr>'
1448             . "\n" .
1449             '</table>';
1450              
1451 0           return $content;
1452             }
1453              
1454             sub _build_platform_matrix {
1455 0     0     my $self = shift;
1456              
1457 0           my %tvars = (template => 'pmatrix', FULL => 1, MONTH => 0);
1458 0           $self->{parent}->_log("building platform matrix - 1");
1459 0           my $CONTENT = $self->_platform_matrix($self->{versions},'all',1);
1460 0           $tvars{CONTENT} = $CONTENT;
1461 0           $self->_writepage('pmatrix-full',\%tvars);
1462              
1463 0           %tvars = (template => 'pmatrix', FULL => 1, MONTH => 0, layout => 'layout-wide');
1464 0           $tvars{CONTENT} = $CONTENT;
1465 0           $self->{parent}->_log("building platform matrix - 2");
1466 0           $self->_writepage('pmatrix-full-wide',\%tvars);
1467              
1468 0           %tvars = (template => 'pmatrix', FULL => 1, MONTH => 1);
1469 0           $self->{parent}->_log("building platform matrix - 3");
1470 0           $CONTENT = $self->_platform_matrix($self->{versions},'month',1);
1471 0           $tvars{CONTENT} = $CONTENT;
1472 0           $self->_writepage('pmatrix-full-month',\%tvars);
1473              
1474 0           %tvars = (template => 'pmatrix', FULL => 1, MONTH => 1, layout => 'layout-wide');
1475 0           $tvars{CONTENT} = $CONTENT;
1476 0           $self->{parent}->_log("building platform matrix - 4");
1477 0           $self->_writepage('pmatrix-full-month-wide',\%tvars);
1478              
1479 0           my @vers = grep {!/^5\.(11|9|7)\./} @{$self->{versions}};
  0            
  0            
1480              
1481 0           %tvars = (template => 'pmatrix', FULL => 0, MONTH => 0);
1482 0           $self->{parent}->_log("building platform matrix - 5");
1483 0           $CONTENT = $self->_platform_matrix(\@vers,'all',0);
1484 0           $tvars{CONTENT} = $CONTENT;
1485 0           $self->_writepage('pmatrix',\%tvars);
1486              
1487 0           %tvars = (template => 'pmatrix', FULL => 0, MONTH => 0, layout => 'layout-wide');
1488 0           $tvars{CONTENT} = $CONTENT;
1489 0           $self->{parent}->_log("building platform matrix - 6");
1490 0           $self->_writepage('pmatrix-wide',\%tvars);
1491              
1492 0           %tvars = (template => 'pmatrix', FULL => 0, MONTH => 1);
1493 0           $self->{parent}->_log("building platform matrix - 7");
1494 0           $CONTENT = $self->_platform_matrix(\@vers,'month',0);
1495 0           $tvars{CONTENT} = $CONTENT;
1496 0           $self->_writepage('pmatrix-month',\%tvars);
1497              
1498 0           %tvars = (template => 'pmatrix', FULL => 0, MONTH => 1, layout => 'layout-wide');
1499 0           $tvars{CONTENT} = $CONTENT;
1500 0           $self->{parent}->_log("building platform matrix - 8");
1501 0           $self->_writepage('pmatrix-month-wide',\%tvars);
1502             }
1503              
1504             sub _platform_matrix {
1505 0     0     my $self = shift;
1506 0 0         my $vers = shift or return '';
1507 0           my $type = shift;
1508 0   0       my $full = shift || 0;
1509 0 0         return '' unless(@$vers);
1510              
1511 0           my %totals;
1512 0           for my $platform (sort keys %{$self->{pass}}) {
  0            
1513 0 0         if($type eq 'month') {
1514 0           my $check = 0;
1515 0 0         for my $perl (@$vers) { $check++ if(defined $self->{pass}{$platform}{$perl}{month}{$self->{dates}{LASTMONTH}}) }
  0            
1516 0 0         next if($check == 0);
1517             }
1518 0           for my $perl (@$vers) {
1519             my $count = defined $self->{pass}{$platform}{$perl}{$type}
1520             ? ($type eq 'month'
1521 0           ? scalar(keys %{$self->{pass}{$platform}{$perl}{month}{$self->{dates}{LASTMONTH}}})
1522 0 0         : scalar(keys %{$self->{pass}{$platform}{$perl}{$type}}))
  0 0          
1523             : 0;
1524 0   0       $count ||= 0;
1525 0           $totals{platform}{$platform} += $count;
1526 0           $totals{perl}{$perl} += $count;
1527             }
1528             }
1529              
1530 0           my $index = 0;
1531             my $content =
1532             "\n"
1533             . '<table class="matrix" summary="Platform/Perl Matrix">'
1534             . "\n"
1535             . '<tr><th>Platform/Perl</th><th></th><th>'
1536             . join( "</th><th>", @$vers )
1537             . '</th><th></th><th>Platform/Perl</th></tr>'
1538             . "\n"
1539             . '<tr><th></th><th class="totals">Totals</th><th class="totals">'
1540 0 0         . join( '</th><th class="totals">', map {$totals{perl}{$_}||0} @$vers )
  0            
1541             . '</th><th class="totals">Totals</th><th></th></tr>';
1542              
1543 0 0         for my $platform (sort {$totals{platform}{$b} <=> $totals{platform}{$a} || $a cmp $b} keys %{$totals{platform}}) {
  0            
  0            
1544 0 0         if($type eq 'month') {
1545 0           my $check = 0;
1546 0 0         for my $perl (@$vers) { $check++ if(defined $self->{pass}{$platform}{$perl}{month}{$self->{dates}{LASTMONTH}}) }
  0            
1547 0 0         next if($check == 0);
1548             }
1549 0           $content .= "\n" . '<tr><th>' . $platform . '</th><th class="totals">' . $totals{platform}{$platform} . '</th>';
1550 0           for my $perl (@$vers) {
1551             my $count = defined $self->{pass}{$platform}{$perl}{$type}
1552             ? ($type eq 'month'
1553 0           ? scalar(keys %{$self->{pass}{$platform}{$perl}{month}{$self->{dates}{LASTMONTH}}})
1554 0 0         : scalar(keys %{$self->{pass}{$platform}{$perl}{$type}}))
  0 0          
1555             : 0;
1556 0   0       $count ||= 0;
1557 0 0         if($count) {
1558 0 0         if($self->{list}{platform}{$platform}{$perl}{$type}) {
1559 0           $index = $self->{list}{platform}{$platform}{$perl}{$type};
1560             } else {
1561 0 0         my %tvars = (template => 'distlist', OS => 0, MONTH => ($type eq 'month' ? 1 : 0), FULL => $full);
1562 0           my @list = sort keys %{$self->{pass}{$platform}{$perl}{$type}};
  0            
1563 0           $tvars{dists} = \@list;
1564 0           $tvars{vplatform} = $platform;
1565 0           $tvars{vperl} = $perl;
1566 0           $tvars{count} = $count;
1567              
1568 0           $index = join('-','platform', $type, $platform, $perl);
1569 0           $index =~ s/[^-.\w]/-/g;
1570 0           $index = 'matrix/' . $index;
1571 0           $self->{list}{platform}{$platform}{$perl}{$type} = $index;
1572 0           $self->_writepage($index,\%tvars);
1573             }
1574             }
1575              
1576 0 0         my $number = ($type eq 'month' ? $self->{platform}{$platform}{$perl}{month}{$self->{dates}{LASTMONTH}} : $self->{platform}{$platform}{$perl}{$type});
1577 0   0       $number ||= 0;
1578 0           my $class = 'none';
1579 0 0         $class = 'some' if($number > 0);
1580 0 0         $class = 'more' if($number > $matrix_limits{$type}->[0]);
1581 0 0         $class = 'lots' if($number > $matrix_limits{$type}->[1]);
1582              
1583             # count = number of distributions with a pass
1584             # number = number of reports submitted for that platform/perl
1585 0 0         $content .= qq{<td class="$class">}
1586             . ($count ? qq|<a href="$index.html" title="Distribution List for $platform/$perl">$count</a><br />$number| : '-')
1587             . '</td>';
1588             }
1589 0           $content .= '<th class="totals">' . $totals{platform}{$platform} . '</th><th>' . $platform . '</th>';
1590 0           $content .= '</tr>';
1591             }
1592             $content .=
1593             "\n"
1594             . '<tr><th></th><th class="totals">Totals</th><th class="totals">'
1595 0 0         . join( '</th><th class="totals">', map {$totals{perl}{$_}||0} @$vers )
  0            
1596             . '</th><th class="totals">Totals</th><th></th></tr>'
1597             . "\n"
1598             . '<tr><th>Platform/Perl</th><th></th><th>'
1599             . join( "</th><th>", @$vers )
1600             . '</th><th></th><th>Platform/Perl</th></tr>'
1601             . "\n"
1602             . '</table>';
1603              
1604 0           return $content;
1605             }
1606              
1607             # Notes:
1608             #
1609             # * use a JSON store (e.g. cpanstats-platform.json)
1610             # * find the last month stored
1611             # * rebuild from last month to current month
1612             # * store JSON data
1613              
1614             sub _build_monthly_stats {
1615 0     0     my $self = shift;
1616 0           my (%tvars,%stats,%testers,%monthly);
1617 0           my %templates = (
1618             platform => 'mplatforms',
1619             osname => 'mosname',
1620             perl => 'mperls',
1621             tester => 'mtesters'
1622             );
1623              
1624 0           $self->{parent}->_log("building monthly tables");
1625              
1626 0           my $query = q!SELECT postdate,%s,count(id) AS count FROM cpanstats ! .
1627             q!WHERE type = 2 %s ! .
1628             q!GROUP BY postdate,%s ORDER BY postdate,count DESC,%s!;
1629              
1630 0           for my $type (qw(platform osname perl)) {
1631 0           $self->{parent}->_log("building monthly $type table");
1632 0           (%tvars,%stats,%monthly) = ();
1633 0           my $postdate = '';
1634              
1635 0           my $json = $self->storage_read($type);
1636 0 0         if($json) {
1637 0           my $last = 0;
1638 0           for my $date (keys %{ $json->{monthly} }) {
  0            
1639 0 0         $last = $date if($date > $last);
1640             }
1641              
1642 0           delete $json->{$_}{$last} for(qw(monthly stats));
1643              
1644 0           %monthly = %{ $json->{monthly} };
  0            
1645 0           %stats = %{ $json->{stats} };
  0            
1646              
1647 0 0         $postdate = "AND postdate >= '$last'" if($last);
1648             }
1649              
1650 0           my $sql = sprintf $query, $type, $postdate, $type, $type;
1651 0           my $next = $self->{parent}->{CPANSTATS}->iterator('hash',$sql);
1652 0           while(my $row = $next->()) {
1653 0           $monthly{$row->{postdate}}{$type}{$row->{$type}} = 1;
1654 0 0         $row->{$type} = $self->{parent}->osname($row->{$type}) if($type eq 'osname');
1655 0           push @{$stats{$row->{postdate}}{list}}, "[$row->{count}] $row->{$type}";
  0            
1656             }
1657              
1658 0           for my $date (sort {$b <=> $a} keys %stats) {
  0            
1659 0           $stats{$date}{count} = scalar(@{$stats{$date}{list}});
  0            
1660 0           push @{$tvars{STATS}}, [$date,$stats{$date}{count},join(', ',@{$stats{$date}{list}})];
  0            
  0            
1661             }
1662 0           $self->_writepage($templates{$type},\%tvars);
1663              
1664             # remember monthly counts for monthly files later
1665 0           for my $date (keys %monthly) {
1666 0           $self->{monthly}{$date}{$type} = keys %{ $monthly{$date}{$type} };
  0            
1667             }
1668              
1669             # store data
1670 0           my $hash = { monthly => \%monthly, stats => \%stats };
1671 0           $self->storage_write($type,$hash);
1672             }
1673              
1674             {
1675 0           my $type = 'tester';
  0            
1676 0           $self->{parent}->_log("building monthly $type table");
1677 0           (%tvars,%stats,%monthly) = ();
1678 0           my $postdate = '';
1679              
1680 0           my $json = $self->storage_read($type);
1681 0 0         if($json) {
1682 0           my $last = 0;
1683 0           for my $date (keys %{ $json->{monthly} }) {
  0            
1684 0 0         $last = $date if($date > $last);
1685             }
1686              
1687 0           delete $json->{$_}{$last} for(qw(monthly stats));
1688              
1689 0           %monthly = %{ $json->{monthly} };
  0            
1690 0           %stats = %{ $json->{stats} };
  0            
1691              
1692 0 0         $postdate = "AND postdate >= '$last'" if($last);
1693             }
1694              
1695 0           my $sql = sprintf $query, $type, $postdate, $type, $type;
1696 0           my $next = $self->{parent}->{CPANSTATS}->iterator('hash',$sql);
1697 0           while(my $row = $next->()) {
1698 0           my ($name) = $self->{parent}->tester($row->{tester});
1699 0           $testers{$name} += $row->{count};
1700 0           $stats{$row->{postdate}}{list}{$name} += $row->{count};
1701 0           $monthly{$row->{postdate}}{$type}{$name} = 1;
1702             }
1703              
1704 0           for my $date (sort {$b <=> $a} keys %stats) {
  0            
1705 0           $stats{$date}{count} = keys %{$stats{$date}{list}};
  0            
1706 0           push @{$tvars{STATS}}, [$date,$stats{$date}{count},
1707             join(', ',
1708 0           map {"[$stats{$date}{list}{$_}] $_"}
1709 0 0         sort {$stats{$date}{list}{$b} <=> $stats{$date}{list}{$a} || $a cmp $b}
1710 0           keys %{$stats{$date}{list}})];
  0            
1711             }
1712 0           $self->_writepage($templates{$type},\%tvars);
1713              
1714             # remember monthly counts for monthly files later
1715 0           for my $date (keys %monthly) {
1716 0           $self->{monthly}{$date}{$type} = keys %{ $monthly{$date}{$type} };
  0            
1717             }
1718              
1719             # store data
1720 0           my $hash = { monthly => \%monthly, stats => \%stats };
1721 0           $self->storage_write($type,$hash);
1722             }
1723             }
1724              
1725             sub _build_osname_leaderboards {
1726 0     0     my $self = shift;
1727              
1728 0           $self->{parent}->_log("building osname leaderboards");
1729              
1730             # set dates
1731 0           my $post0 = '999999';
1732 0           my $post1 = $self->{dates}{THATMONTH};
1733 0           my $post2 = $self->{dates}{LASTMONTH};
1734 0           my $post3 = $self->{dates}{THISMONTH};
1735              
1736 0           my @dates = ($post0, $post1, $post2, $post3);
1737 0           my %dates = map {$_ => 1} @dates;
  0            
1738              
1739 0           $self->{parent}->_log("1.post0=$post0");
1740 0           $self->{parent}->_log("2.post1=$post1");
1741 0           $self->{parent}->_log("3.post2=$post2");
1742 0           $self->{parent}->_log("4.post3=$post3");
1743              
1744             # load data
1745 0           my $data = $self->{parent}->leaderboard( results => \@dates );
1746 0           $self->{parent}->tester( 'test' );
1747              
1748 0           my @posts = sort keys %$data;
1749 0           $self->{parent}->_log("5.posts[0]=$posts[0]");
1750              
1751             # store data for the last 3 months, and in total
1752 0           my %oses;
1753 0           for my $post (keys %$data) {
1754 0 0         if($dates{$post}) {
1755 0           for my $os (keys %{$data->{$post}}) {
  0            
1756 0 0         next unless($os);
1757 0           $oses{$os} = 1;
1758 0           for my $tester (keys %{$data->{$post}{$os}}) {
  0            
1759 0   0       $data->{$post0}{$os}{$tester} ||= 0; # make sure we include all testers
1760             }
1761             }
1762             } else {
1763 0           for my $os (keys %{$data->{$post}}) {
  0            
1764 0 0         next unless($os);
1765 0           $oses{$os} = 1;
1766 0           for my $tester (keys %{$data->{$post}{$os}}) {
  0            
1767 0           $data->{$post0}{$os}{$tester} += $data->{$post}{$os}{$tester};
1768             }
1769             }
1770 0           delete $data->{$post};
1771             }
1772             }
1773              
1774             #$self->{parent}->_log("6.data=".Dumper($data));
1775              
1776             # reorganise data
1777 0           my %hash;
1778 0           for my $os (keys %oses) {
1779 0           for my $tester (keys %{$data->{$post0}{$os}}) {
  0            
1780 0   0       $hash{$os}{$tester}{this} = $data->{$post3}{$os}{$tester} || 0;
1781 0   0       $hash{$os}{$tester}{that} = $data->{$post2}{$os}{$tester} || 0;
1782             $hash{$os}{$tester}{all} = ($data->{$post3}{$os}{$tester} || 0) + ($data->{$post2}{$os}{$tester} || 0) +
1783 0   0       ($data->{$post1}{$os}{$tester} || 0) + ($data->{$post0}{$os}{$tester} || 0);
      0        
      0        
      0        
1784             }
1785             }
1786              
1787 0           $self->{parent}->_log("1.reorg");
1788              
1789 0           my %titles = (
1790             this => 'This Month',
1791             that => 'Last Month',
1792             all => 'All Months'
1793             );
1794              
1795 0           my $sql = 'SELECT * FROM osname ORDER BY ostitle';
1796 0           my @rows = $self->{parent}->{CPANSTATS}->get_query('hash',$sql);
1797 0           my @oses = grep {$_->{osname}} @rows;
  0            
1798              
1799 0           for my $osname (keys %oses) {
1800 0 0         next unless($osname);
1801 0           for my $type (qw(this that all)) {
1802 0           my @leaders;
1803 0 0 0       for my $tester (sort {($hash{$osname}{$b}{$type} || 0) <=> ($hash{$osname}{$a}{$type} || 0) || $a cmp $b} keys %{$hash{$osname}}) {
  0   0        
  0            
1804             push @leaders,
1805             { col2 => $hash{$osname}{$tester}{this},
1806             col1 => $hash{$osname}{$tester}{that},
1807             col3 => $hash{$osname}{$tester}{all},
1808 0           tester => $tester
1809             } ;
1810             }
1811              
1812 0           my $os = lc $osname;
1813              
1814 0           my %tvars;
1815 0           $tvars{osnames} = \@oses;
1816 0           $tvars{template} = 'leaderos';
1817 0           $tvars{osname} = $self->{parent}->osname($osname);
1818 0           $tvars{leaders} = \@leaders;
1819 0           $tvars{headers} = { col1 => $post2, col2 => $post3, title => "$tvars{osname} Leaderboard ($titles{$type})" };
1820 0 0         $tvars{links}{this} = $type eq 'this' ? '' : "leaders-$os-this.html";
1821 0 0         $tvars{links}{that} = $type eq 'that' ? '' : "leaders-$os-that.html";
1822 0 0         $tvars{links}{all} = $type eq 'all' ? '' : "leaders-$os-all.html";
1823 0           $self->{parent}->_log("1.leaders/leaders-$os-$type");
1824              
1825 0           $self->_writepage("leaders/leaders-$os-$type",\%tvars);
1826             }
1827             }
1828              
1829 0           $self->{parent}->_log("building leader board");
1830 0           my (%tvars,%stats,%testers) = ();
1831              
1832 0           $tvars{osnames} = \@oses;
1833 0           for my $post ($post0, $post1, $post2, $post3) {
1834 0           for my $os (keys %{$data->{$post}}) {
  0            
1835 0 0         next unless($os);
1836 0           for my $tester (keys %{$data->{$post}{$os}}) {
  0            
1837 0           $testers{$tester} += $data->{$post}{$os}{$tester};
1838             }
1839             }
1840             }
1841              
1842 0           my $count = 1;
1843 0 0         for my $tester (sort {$testers{$b} <=> $testers{$a} || $a cmp $b} keys %testers) {
  0            
1844 0           push @{$tvars{STATS}}, [$count++, $testers{$tester}, $tester];
  0            
1845             }
1846              
1847 0           $count--;
1848              
1849 0           $self->{parent}->tester_loader();
1850              
1851 0           $self->{parent}->_log("Unknown Addresses: ".($count-$self->{parent}->known_t));
1852 0           $self->{parent}->_log("Known Addresses: ".($self->{parent}->known_s));
1853 0           $self->{parent}->_log("Listed Addresses: ".($self->{parent}->known_s + $count - $self->{parent}->known_t));
1854 0           $self->{parent}->_log("Unknown Testers: ".($count-$self->{parent}->known_t));
1855 0           $self->{parent}->_log("Known Testers: ".($self->{parent}->known_t));
1856 0           $self->{parent}->_log("Listed Testers: ".($count));
1857              
1858 0           push @{$tvars{COUNTS}},
1859             ($count-$self->{parent}->known_t),
1860             $self->{parent}->known_s,
1861             ($self->{parent}->known_s + $count - $self->{parent}->known_t),
1862             ($count - $self->{parent}->known_t),
1863             $self->{parent}->known_t,
1864 0           $count;
1865              
1866 0           $self->_writepage('testers',\%tvars);
1867             }
1868              
1869             sub _build_monthly_stats_files {
1870 0     0     my $self = shift;
1871 0           my %tvars;
1872              
1873 0           my $directory = $self->{parent}->directory;
1874 0           my $results = "$directory/stats";
1875 0           mkpath($results);
1876              
1877 0           $self->{parent}->_log("building monthly stats for graphs - 1,3,pcent1");
1878              
1879             #print "DATE,UPLOADS,REPORTS,NA,PASS,FAIL,UNKNOWN\n";
1880 0           my $fh1 = IO::File->new(">$results/stats1.txt");
1881 0           print $fh1 "#DATE,UPLOADS,REPORTS,PASS,FAIL\n";
1882              
1883 0           my $fh2 = IO::File->new(">$results/pcent1.txt");
1884 0           print $fh2 "#DATE,FAIL,OTHER,PASS\n";
1885              
1886 0           my $fh3 = IO::File->new(">$results/stats3.txt");
1887 0           print $fh3 "#DATE,FAIL,NA,UNKNOWN\n";
1888              
1889 0           for my $date (sort keys %{$self->{stats}}) {
  0            
1890 0 0         next if($date > $self->{dates}{THISMONTH});
1891              
1892 0   0       my $uploads = ($self->{pause}{$date} || 0);
1893 0   0       my $reports = ($self->{stats}{$date}{reports} || 0);
1894 0   0       my $passes = ($self->{stats}{$date}{state}{pass} || 0);
1895 0   0       my $fails = ($self->{stats}{$date}{state}{fail} || 0);
1896 0           my $others = $reports - $passes - $fails;
1897              
1898 0           my @fields = (
1899             $date, $uploads, $reports, $passes, $fails
1900             );
1901              
1902 0 0         my @pcent = (
    0          
    0          
1903             $date,
1904             ($reports > 0 ? int($fails / $reports * 100) : 0),
1905             ($reports > 0 ? int($others / $reports * 100) : 0),
1906             ($reports > 0 ? int($passes / $reports * 100) : 0)
1907             );
1908              
1909 0           unshift @{$tvars{STATS}},
1910             [ @fields,
1911             $self->{stats}{$date}{state}{na},
1912 0           $self->{stats}{$date}{state}{unknown}];
1913              
1914             # graphs don't include current month
1915 0 0         next if($date > $self->{dates}{THISMONTH}-1);
1916              
1917 0           my $content = sprintf "%d,%d,%d,%d,%d\n", @fields;
1918 0           print $fh1 $content;
1919              
1920 0           $content = sprintf "%d,%d,%d,%d\n", @pcent;
1921 0           print $fh2 $content;
1922              
1923             $content = sprintf "%d,%d,%d,%d\n",
1924             $date,
1925             ($self->{stats}{$date}{state}{fail} || 0),
1926             ($self->{stats}{$date}{state}{na} || 0),
1927 0   0       ($self->{stats}{$date}{state}{unknown} || 0);
      0        
      0        
1928 0           print $fh3 $content;
1929             }
1930 0           $fh1->close;
1931 0           $fh2->close;
1932 0           $fh3->close;
1933              
1934 0           $self->_writepage('mreports',\%tvars);
1935              
1936 0           $self->{parent}->_log("building monthly stats for graphs - 2");
1937              
1938             #print "DATE,TESTERS,PLATFORMS,PERLS\n";
1939 0           $fh2 = IO::File->new(">$results/stats2.txt");
1940 0           print $fh2 "#DATE,TESTERS,PLATFORMS,PERLS\n";
1941              
1942 0           for my $date (sort keys %{$self->{stats}}) {
  0            
1943 0 0         next if($date > $self->{dates}{THISMONTH}-1);
1944             printf $fh2 "%d,%d,%d,%d\n",
1945             $date,
1946             ($self->{monthly}{$date}{tester} || 0),
1947             ($self->{monthly}{$date}{platform} || 0),
1948 0   0       ($self->{monthly}{$date}{perl} || 0);
      0        
      0        
1949             }
1950 0           $fh2->close;
1951              
1952 0           $self->{parent}->_log("building monthly stats for graphs - 4");
1953              
1954             #print "DATE,ALL,FIRST,LAST\n";
1955 0           $fh1 = IO::File->new(">$results/stats4.txt");
1956 0           print $fh1 "#DATE,ALL,FIRST,LAST\n";
1957              
1958 0           for my $date (sort keys %{ $self->{stats} }) {
  0            
1959 0 0         next if($date > $self->{dates}{THISMONTH}-1);
1960              
1961 0 0         if(defined $self->{counts}{$date}) {
1962 0           $self->{counts}{$date}{all} = scalar(keys %{$self->{counts}{$date}{testers}});
  0            
1963             }
1964 0   0       $self->{counts}{$date}{all} ||= 0;
1965 0   0       $self->{counts}{$date}{first} ||= 0;
1966 0   0       $self->{counts}{$date}{last} ||= 0;
1967 0 0         $self->{counts}{$date}{last} = '' if($date > $self->{dates}{LASTMONTH});
1968              
1969             printf $fh1 "%d,%s,%s,%s\n",
1970             $date,
1971             $self->{counts}{$date}{all},
1972             $self->{counts}{$date}{first},
1973 0           $self->{counts}{$date}{last};
1974             }
1975 0           $fh1->close;
1976             }
1977              
1978             sub _build_failure_rates {
1979 0     0     my $self = shift;
1980 0           my (%tvars,%dists);
1981              
1982 0           $self->{parent}->_log("building failure rates");
1983              
1984 0           my $query =
1985             'SELECT x.dist,x.version,u.released FROM ixlatest AS x '.
1986             'INNER JOIN uploads AS u ON u.dist=x.dist AND u.version=x.version '.
1987             "WHERE u.type != 'backpan'";
1988 0           my $next = $self->{parent}->{CPANSTATS}->iterator('hash',$query);
1989 0           while(my $row = $next->()) {
1990 0           $dists{$row->{dist}}{$row->{version}} = $row->{released};
1991             }
1992              
1993 0           $self->{parent}->_log("selecting failure rates");
1994              
1995             # select worst failure rates - latest version, and ignoring backpan only.
1996 0           my %worst;
1997 0           for my $dist (keys %{ $self->{fails} }) {
  0            
1998 0 0         next unless($dists{$dist});
1999 0           my ($version) = sort {$dists{$dist}{$b} <=> $dists{$dist}{$a}} keys %{$dists{$dist}};
  0            
  0            
2000              
2001 0           $worst{"$dist-$version"} = $self->{fails}->{$dist}{$version};
2002 0           $worst{"$dist-$version"}->{dist} = $dist;
2003             $worst{"$dist-$version"}->{pcent} = $self->{fails}{$dist}{$version}{fail}
2004 0 0         ? int(($self->{fails}{$dist}{$version}{fail}/$self->{fails}{$dist}{$version}{total})*10000)/100
2005             : 0.00;
2006 0   0       $worst{"$dist-$version"}->{pass} ||= 0;
2007 0   0       $worst{"$dist-$version"}->{fail} ||= 0;
2008              
2009 0           my @post = localtime($dists{$dist}{$version});
2010 0           $worst{"$dist-$version"}->{post} = sprintf "%04d%02d", $post[5]+1900, $post[4]+1;
2011             }
2012              
2013 0           $self->{parent}->_log("worst = " . scalar(keys %worst) . " entries");
2014 0           $self->{parent}->_log("building failure counts");
2015              
2016             # calculate worst failure rates - by failure count
2017 0           my $count = 1;
2018 0 0         for my $dist (sort {$worst{$b}->{fail} <=> $worst{$a}->{fail} || $worst{$b}->{pcent} <=> $worst{$a}->{pcent}} keys %worst) {
  0            
2019 0 0         last unless($worst{$dist}->{fail});
2020 0           my $pcent = sprintf "%3.2f%%", $worst{$dist}->{pcent};
2021 0           push @{$tvars{WORST}}, [$count++, $worst{$dist}->{fail}, $dist, $worst{$dist}->{post}, $worst{$dist}->{pass}, $worst{$dist}->{total}, $pcent, $worst{$dist}->{dist}];
  0            
2022 0 0         last if($count > 100);
2023             }
2024              
2025 0           $self->_writepage('wdists',\%tvars);
2026 0           undef %tvars;
2027              
2028 0           $self->{parent}->_log("building failure pecentages");
2029              
2030             # calculate worst failure rates - by percentage
2031 0           $count = 1;
2032 0 0         for my $dist (sort {$worst{$b}->{pcent} <=> $worst{$a}->{pcent} || $worst{$b}->{fail} <=> $worst{$a}->{fail}} keys %worst) {
  0            
2033 0 0         last unless($worst{$dist}->{fail});
2034 0           my $pcent = sprintf "%3.2f%%", $worst{$dist}->{pcent};
2035 0           push @{$tvars{WORST}}, [$count++, $worst{$dist}->{fail}, $dist, $worst{$dist}->{post}, $worst{$dist}->{pass}, $worst{$dist}->{total}, $pcent, $worst{$dist}->{dist}];
  0            
2036 0 0         last if($count > 100);
2037             }
2038              
2039 0           $self->_writepage('wpcent',\%tvars);
2040 0           undef %tvars;
2041              
2042 0           $self->{parent}->_log("done building failure rates");
2043              
2044             # now we do as above but for the last 6 months
2045              
2046 0           my @recent = localtime(time() - 15778463); # 6 months ago
2047 0           my $recent = sprintf "%04d%02d", $recent[5]+1900, $recent[4]+1;
2048              
2049 0           for my $dist (keys %worst) {
2050 0 0         next if($worst{$dist}->{post} ge $recent);
2051 0           delete $worst{$dist};
2052             }
2053              
2054             # calculate worst failure rates - by failure count
2055 0           $count = 1;
2056 0 0         for my $dist (sort {$worst{$b}->{fail} <=> $worst{$a}->{fail} || $worst{$b}->{pcent} <=> $worst{$a}->{pcent}} keys %worst) {
  0            
2057 0 0         last unless($worst{$dist}->{fail});
2058 0           my $pcent = sprintf "%3.2f%%", $worst{$dist}->{pcent};
2059 0           push @{$tvars{WORST}}, [$count++, $worst{$dist}->{fail}, $dist, $worst{$dist}->{post}, $worst{$dist}->{pass}, $worst{$dist}->{total}, $pcent, $worst{$dist}->{dist}];
  0            
2060 0 0         last if($count > 100);
2061             }
2062              
2063 0           $self->_writepage('wdists-recent',\%tvars);
2064 0           undef %tvars;
2065              
2066 0           $self->{parent}->_log("building failure pecentages");
2067              
2068             # calculate worst failure rates - by percentage
2069 0           $count = 1;
2070 0 0         for my $dist (sort {$worst{$b}->{pcent} <=> $worst{$a}->{pcent} || $worst{$b}->{fail} <=> $worst{$a}->{fail}} keys %worst) {
  0            
2071 0 0         last unless($worst{$dist}->{fail});
2072 0           my $pcent = sprintf "%3.2f%%", $worst{$dist}->{pcent};
2073 0           push @{$tvars{WORST}}, [$count++, $worst{$dist}->{fail}, $dist, $worst{$dist}->{post}, $worst{$dist}->{pass}, $worst{$dist}->{total}, $pcent, $worst{$dist}->{dist}];
  0            
2074 0 0         last if($count > 100);
2075             }
2076              
2077 0           $self->_writepage('wpcent-recent',\%tvars);
2078             }
2079              
2080             sub _build_performance_stats {
2081 0     0     my $self = shift;
2082              
2083 0           my $directory = $self->{parent}->directory;
2084 0           my $results = "$directory/stats";
2085 0           mkpath($results);
2086              
2087 0           $self->{parent}->_log("building peformance stats for graphs");
2088              
2089 0           my $fh = IO::File->new(">$results/build1.txt");
2090 0           print $fh "#DATE,REQUESTS,PAGES,REPORTS\n";
2091              
2092 0           my $count = scalar(keys %{$self->{build}});
  0            
2093 0   0       my $limit = $self->{parent}->build_history || 90;
2094 0           my $diff = $count - $limit;
2095              
2096 0           for my $date (sort {$a <=> $b} keys %{$self->{build}}) {
  0            
  0            
2097 0 0         next if(--$diff > 0);
2098              
2099             #$self->{parent}->_log("build_stats: date=$date, old=$self->{build}{$date}->{old}");
2100 0 0         next if($self->{build}{$date}->{old} == 2); # ignore todays tally
2101             #next if($date > $self->{dates}{THISMONTH}-1);
2102              
2103             printf $fh "%d,%d,%d,%d\n",
2104             $date,
2105             ($self->{build}{$date}{webtotal} || 0),
2106             ($self->{build}{$date}{webunique} || 0),
2107 0   0       ($self->{build}{$date}{reports} || 0);
      0        
      0        
2108             }
2109 0           $fh->close;
2110             }
2111              
2112             sub _build_sizes {
2113 0     0     my $self = shift;
2114 0           my $du = 'du -h --max-depth=0';
2115              
2116 0           for my $dir (qw( dir_cpan dir_backpan dir_reports )) {
2117 0           my $path = $self->{parent}->$dir();
2118 0           my $res =`$du $path`;
2119 0   0       $res ||= '';
2120 0 0         $res =~ s/\s.*$//s if($res);
2121 0           $self->{sizes}{$dir} = $res;
2122 0           $self->{parent}->_log(".. size for $dir ($path) = $res");
2123             }
2124             }
2125              
2126             =item * _writepage
2127              
2128             Creates a single HTML page.
2129              
2130             =cut
2131              
2132             sub _writepage {
2133 0     0     my ($self,$page,$vars) = @_;
2134 0           my $directory = $self->{parent}->directory;
2135 0           my $templates = $self->{parent}->templates;
2136              
2137             #$self->{parent}->_log("_writepage: page=$page");
2138              
2139 0   0       my $extension = $vars->{extension} || 'html';
2140 0   0       my $template = $vars->{template} || $page;
2141 0   0       my $tlayout = $vars->{layout} || 'layout';
2142 0           my $layout = "$tlayout.$extension";
2143 0           my $source = "$template.$extension";
2144 0           my $target = "$directory/$page.$extension";
2145              
2146             #$self->{parent}->_log("_writepage: layout=$layout, source=$source, target=$target");
2147              
2148 0           mkdir(dirname($target));
2149              
2150 0           $vars->{SOURCE} = $source;
2151 0           $vars->{VERSION} = $VERSION;
2152 0           $vars->{copyright} = $self->{parent}->copyright;
2153 0           $vars->{$_} = $self->{dates}{$_} for(keys %{ $self->{dates} });
  0            
2154              
2155             #if($page =~ /(statscpan|interest)/) {
2156             # $self->{parent}->_log("$page:" . Dumper($vars));
2157             #}
2158              
2159 0           my %config = ( # provide config info
2160             RELATIVE => 1,
2161             ABSOLUTE => 1,
2162             INCLUDE_PATH => $templates,
2163             INTERPOLATE => 0,
2164             POST_CHOMP => 1,
2165             TRIM => 1,
2166             );
2167              
2168 0           my $parser = Template->new(\%config); # initialise parser
2169 0 0         $parser->process($layout,$vars,$target) # parse the template
2170             or die $parser->error() . "\n";
2171             }
2172              
2173             # Provides the ordinal for dates.
2174              
2175             sub _ext {
2176 0     0     my $num = shift;
2177 0 0 0       return 'st' if($num == 1 || $num == 21 || $num == 31);
      0        
2178 0 0 0       return 'nd' if($num == 2 || $num == 22);
2179 0 0 0       return 'rd' if($num == 3 || $num == 23);
2180 0           return 'th';
2181             }
2182              
2183             sub _parsedate {
2184 0     0     my $time = shift;
2185 0           my @time = localtime($time);
2186 0           return sprintf "%04d%02d", $time[5]+1900,$time[4]+1;
2187             }
2188              
2189             sub _count_mailrc {
2190 0     0     my $self = shift;
2191 0           my $count = 0;
2192 0           my $mailrc = $self->{parent}->mailrc();
2193              
2194 0 0         my $fh = IO::File->new($mailrc,'r') or die "Cannot read file [$mailrc]: $!\n";
2195 0           while(<$fh>) {
2196 0 0         next unless(/^alias\s*(\w+)\s+"([\s\w]+)\s+<[^>]+>"/);
2197 0           $self->{alias}{$1} = $2;
2198 0           $count++;
2199             }
2200 0           $fh->close;
2201              
2202 0           return $count;
2203             }
2204              
2205             q("Will code for Guinness!");
2206              
2207             __END__
2208              
2209             =back
2210              
2211             =head1 CPAN TESTERS FUND
2212              
2213             CPAN Testers wouldn't exist without the help and support of the Perl
2214             community. However, since 2008 CPAN Testers has grown far beyond the
2215             expectations of it's original creators. As a consequence it now requires
2216             considerable funding to help support the infrastructure.
2217              
2218             In early 2012 the Enlightened Perl Organisation very kindly set-up a
2219             CPAN Testers Fund within their donatation structure, to help the project
2220             cover the costs of servers and services.
2221              
2222             If you would like to donate to the CPAN Testers Fund, please follow the link
2223             below to the Enlightened Perl Organisation's donation site.
2224              
2225             F<https://members.enlightenedperl.org/drupal/donate-cpan-testers>
2226              
2227             If your company would like to support us, you can donate financially via the
2228             fund link above, or if you have servers or services that we might use, please
2229             send an email to admin@cpantesters.org with details.
2230              
2231             Our full list of current sponsors can be found at our I <3 CPAN Testers site.
2232              
2233             F<http://iheart.cpantesters.org>
2234              
2235             =head1 BUGS, PATCHES & FIXES
2236              
2237             There are no known bugs at the time of this release. However, if you spot a
2238             bug or are experiencing difficulties, that is not explained within the POD
2239             documentation, please send bug reports and patches to the RT Queue (see below).
2240              
2241             Fixes are dependent upon their severity and my availability. Should a fix not
2242             be forthcoming, please feel free to (politely) remind me.
2243              
2244             RT Queue -
2245             http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Testers-WWW-Statistics
2246              
2247             =head1 SEE ALSO
2248              
2249             L<CPAN::Testers::Data::Generator>,
2250             L<CPAN::Testers::WWW::Reports>
2251              
2252             F<http://www.cpantesters.org/>,
2253             F<http://stats.cpantesters.org/>,
2254             F<http://wiki.cpantesters.org/>
2255              
2256             =head1 AUTHOR
2257              
2258             Barbie, <barbie@cpan.org>
2259             for Miss Barbell Productions <http://www.missbarbell.co.uk>.
2260              
2261             =head1 COPYRIGHT AND LICENSE
2262              
2263             Copyright (C) 2005-2017 Barbie for Miss Barbell Productions.
2264              
2265             This distribution is free software; you can redistribute it and/or
2266             modify it under the Artistic Licence v2.
2267              
2268             =cut