File Coverage

blib/lib/CPAN/Testers/WWW/Statistics/Leaderboard.pm
Criterion Covered Total %
statement 9 80 11.2
branch 0 10 0.0
condition 0 3 0.0
subroutine 3 10 30.0
pod 6 6 100.0
total 18 109 16.5


line stmt bran cond sub pod time code
1             package CPAN::Testers::WWW::Statistics::Leaderboard;
2              
3 15     15   102 use warnings;
  15         46  
  15         1035  
4 15     15   90 use strict;
  15         39  
  15         381  
5 15     15   79 use vars qw($VERSION);
  15         35  
  15         12734  
6              
7             $VERSION = '1.22';
8              
9             #----------------------------------------------------------------------------
10              
11             =head1 NAME
12              
13             CPAN::Testers::WWW::Statistics::Leaderboard - CPAN Testers Statistics leaderboard.
14              
15             =head1 SYNOPSIS
16              
17             my %hash = { config => 'options' };
18             my $obj = CPAN::Testers::WWW::Statistics->new(%hash);
19             my $lb = CPAN::Testers::WWW::Statistics::Leaderboard->new(parent => $obj);
20              
21             $ct->process( renew => 1 ); # renew all counts
22             $ct->process( update => 1 ); # update counts for the last 3 months
23             $ct->process( postdate => '201206' ); # update counts for specified month
24             $ct->process( check => 1 ); # check for discrepancies
25              
26             =head1 DESCRIPTION
27              
28             Using the cpanstats database, this module provides the data in the
29             'leaderboard' table within the 'cpanstats' database. The data itself is then
30             used by the Pages module to create the leaderboard pages.
31              
32             Previously this information was held in a JSON file, but maintaining accurate
33             data has been problematic.
34              
35             Note that this package should not be called directly, but via its parent as:
36              
37             my %hash = { config => 'options' };
38             my $obj = CPAN::Testers::WWW::Statistics->new(%hash);
39              
40             $obj->leaderboard( %options ); # above for the list of options
41              
42             =cut
43              
44             # -------------------------------------
45             # Public Methods
46              
47             =head1 INTERFACE
48              
49             =head2 The Constructor
50              
51             =over 4
52              
53             =item * new
54              
55             Page creation object. Allows the user to turn or off the progress tracking.
56              
57             new() takes an option hash as an argument, which may contain 'progress => 1'
58             to turn on the progress tracker.
59              
60             =back
61              
62             =cut
63              
64             sub new {
65 0     0 1   my $class = shift;
66 0           my %hash = @_;
67              
68 0 0         die "Must specify the parent statistics object\n" unless(defined $hash{parent});
69              
70 0           my $self = {parent => $hash{parent}};
71 0           bless $self, $class;
72              
73 0           return $self;
74             }
75              
76             =head2 Public Methods
77              
78             =over 4
79              
80             =item * renew
81              
82             Renew all OS counts for all month entries.
83              
84             =item * update
85              
86             Update all OS counts for the last 3 months.
87              
88             =item * postdate
89              
90             Update all OS counts for the specified month.
91              
92             =item * check
93              
94             Verify monthy counts with source table to ensure all OS counts have been
95             appropriately applied.
96              
97             =item * results
98              
99             Provides the data as a hash for the required months, with the OS and tester
100             names as subsidary keys.
101              
102             Note that month '999999' is a special case, and is an accumulation of all other
103             months, from those requested. Thus if only '999999' is requested the top level
104             hash return will only consist of one date, and will be a sum of all months.
105              
106             =back
107              
108             =cut
109              
110             sub renew {
111 0     0 1   my $self = shift;
112              
113 0           $self->{parent}->_log("START renew");
114 0           $self->_update( 'SELECT distinct(postdate) as postdate FROM cpanstats' );
115 0           $self->{parent}->_log("STOP renew");
116             }
117              
118             sub postdate {
119 0     0 1   my ($self,$date) = @_;
120              
121 0           $self->{parent}->_log("START postdate = $date");
122 0           $self->_update( "SELECT '$date' as postdate" );
123 0           $self->{parent}->_log("STOP postdate");
124             }
125              
126             sub update {
127 0     0 1   my $self = shift;
128              
129 0           $self->{parent}->_log("START update");
130 0           $self->_update( 'SELECT distinct(postdate) as postdate FROM cpanstats ORDER BY postdate DESC LIMIT 3' );
131 0           $self->{parent}->_log("STOP update");
132             }
133              
134             sub check {
135 0     0 1   my $self = shift;
136              
137 0           my $sql1 =
138             'SELECT postdate,COUNT(id) AS qty FROM cpanstats '.
139             'WHERE type=2 '.
140             'GROUP BY postdate';
141 0           my $sql2 =
142             'SELECT postdate,SUM(score) AS qty FROM leaderboard '.
143             'GROUP BY postdate '.
144             'ORDER BY postdate';
145              
146 0           my %hash;
147 0           my @rows = $self->{parent}->{CPANSTATS}->get_query('hash',$sql1);
148 0           for my $row (@rows) {
149 0           $hash{ $row->{postdate} } = $row->{qty};
150             }
151              
152 0           my %data;
153 0           @rows = $self->{parent}->{CPANSTATS}->get_query('hash',$sql2);
154 0           for my $row (@rows) {
155 0 0         next if($hash{ $row->{postdate} } == $row->{qty});
156 0           my $str = sprintf "%s, %d, %d", $row->{postdate}, $hash{ $row->{postdate} }, $row->{qty};
157 0           $self->{parent}->_log($str);
158              
159 0           $data{$row->{postdate}}{cpanstats} = $hash{ $row->{postdate} };
160 0           $data{$row->{postdate}}{leaderboard} = $row->{qty};
161             }
162              
163 0           return \%data;
164             }
165              
166             sub results {
167 0     0 1   my $self = shift;
168 0           my %dates = map {$_ => 1} @{ shift() };
  0            
  0            
169              
170 0           my $sql1 = q{SELECT * FROM leaderboard ORDER BY postdate,osname};
171             # my $sql1 = q{
172             # SELECT l.*, p.name, p.pause
173             # FROM leaderboard l
174             # LEFT JOIN testers.profile p ON p.testerid=l.testerid
175             # ORDER BY postdate,osname
176             # };
177              
178 0           my %hash;
179 0           my @rows = $self->{parent}->{CPANSTATS}->get_query('hash',$sql1);
180 0           for my $row (@rows) {
181 0           my $tester = $self->{parent}->tester_lookup($row->{addressid},$row->{testerid});
182 0   0       $tester ||= $row->{tester};
183              
184 0 0         if($dates{ $row->{postdate} }) {
    0          
185 0           $hash{ $row->{postdate} }{$row->{osname}}{$tester} = $row->{score};
186             } elsif($dates{ '999999' }) {
187 0           $hash{ '999999' }{$row->{osname}}{$tester} += $row->{score};
188             }
189             }
190              
191             # make sure we reference an empty hash, not undef
192 0           for(keys %dates) {
193 0 0         $hash{$_} = {} unless(defined $hash{$_});
194             }
195              
196 0           return \%hash;
197             }
198              
199             # -------------------------------------
200             # Private Methods
201              
202             sub _update {
203 0     0     my $self = shift;
204              
205 0           my $sql1 = shift;
206 0           my $sql2 = 'SELECT osname,tester,COUNT(id) AS count FROM cpanstats '.
207             'WHERE postdate=? AND type=2 '.
208             'GROUP BY osname,tester ORDER BY tester,osname';
209 0           my $sql3 = 'REPLACE INTO leaderboard (postdate,osname,tester,score,addressid,testerid) VALUES (?,?,?,?,?,?)';
210 0           my $sql4 = 'DELETE FROM leaderboard WHERE postdate=?';
211              
212 0           my @rows = $self->{parent}->{CPANSTATS}->get_query('hash',$sql1);
213 0           for my $row (@rows) {
214 0           $self->{parent}->_log("postdate = $row->{postdate}");
215              
216 0           $self->{parent}->{CPANSTATS}->do_query($sql4,$row->{postdate});
217              
218 0           my (%hash,%names);
219 0           my $next = $self->{parent}->{CPANSTATS}->iterator('hash',$sql2,$row->{postdate});
220 0           while(my $row2 = $next->()) {
221 0           my ($name,$addressid,$testerid) = $self->{parent}->tester($row2->{tester});
222 0           my $osname = lc $row2->{osname};
223              
224             #$self->{parent}->_log( sprintf "%s,%s,%d", $osname, $name, $row2->{count} );
225 0           $hash{$osname}{$name}{score} += $row2->{count};
226 0           $hash{$osname}{$name}{addressid} = $addressid;
227 0           $hash{$osname}{$name}{testerid} = $testerid;
228             #$self->{parent}->_log( sprintf "%s,%s,%d", $osname, $name, $hash{$osname}{$name}{score} );
229             }
230              
231 0           for my $osname (keys %hash) {
232 0           for my $name (keys %{ $hash{$osname} }) {
  0            
233             $self->{parent}->{CPANSTATS}->do_query($sql3,
234             $row->{postdate}, $osname, $name,
235             $hash{$osname}{$name}{score},
236             $hash{$osname}{$name}{addressid},
237 0           $hash{$osname}{$name}{testerid});
238             }
239             }
240             }
241             }
242              
243             q("I'll never forget him (the leader of the pack)");
244              
245              
246             __END__
247              
248             =head1 CPAN TESTERS FUND
249              
250             CPAN Testers wouldn't exist without the help and support of the Perl
251             community. However, since 2008 CPAN Testers has grown far beyond the
252             expectations of it's original creators. As a consequence it now requires
253             considerable funding to help support the infrastructure.
254              
255             In early 2012 the Enlightened Perl Organisation very kindly set-up a
256             CPAN Testers Fund within their donatation structure, to help the project
257             cover the costs of servers and services.
258              
259             If you would like to donate to the CPAN Testers Fund, please follow the link
260             below to the Enlightened Perl Organisation's donation site.
261              
262             F<https://members.enlightenedperl.org/drupal/donate-cpan-testers>
263              
264             If your company would like to support us, you can donate financially via the
265             fund link above, or if you have servers or services that we might use, please
266             send an email to admin@cpantesters.org with details.
267              
268             Our full list of current sponsors can be found at our I <3 CPAN Testers site.
269              
270             F<http://iheart.cpantesters.org>
271              
272             =head1 BUGS, PATCHES & FIXES
273              
274             There are no known bugs at the time of this release. However, if you spot a
275             bug or are experiencing difficulties, that is not explained within the POD
276             documentation, please send bug reports and patches to the RT Queue (see below).
277              
278             Fixes are dependent upon their severity and my availability. Should a fix not
279             be forthcoming, please feel free to (politely) remind me.
280              
281             RT Queue -
282             http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Testers-WWW-Statistics
283              
284             =head1 SEE ALSO
285              
286             L<CPAN::Testers::Data::Generator>,
287             L<CPAN::Testers::WWW::Reports>
288              
289             F<http://www.cpantesters.org/>,
290             F<http://stats.cpantesters.org/>,
291             F<http://wiki.cpantesters.org/>
292              
293             =head1 AUTHOR
294              
295             Barbie, <barbie@cpan.org>
296             for Miss Barbell Productions <http://www.missbarbell.co.uk>.
297              
298             =head1 COPYRIGHT AND LICENSE
299              
300             Copyright (C) 2005-2017 Barbie for Miss Barbell Productions.
301              
302             This distribution is free software; you can redistribute it and/or
303             modify it under the Artistic Licence v2.
304              
305             =cut