The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
use strict;
$|++;

my $VERSION = '0.01';

#----------------------------------------------------------------------------

=head1 NAME

uploads.cgi - script to list the last 30 days of uploads.

=head1 SYNOPSIS

  perl uploads.cgi

=head1 DESCRIPTION

Displays a list of the last 30 days of uploads.

=cut

# -------------------------------------
# Library Modules

use CGI;
#use CGI::Carp qw(fatalsToBrowser);
use Config::IniFiles;
use CPAN::Testers::Common::DBUtils;
use DateTime;
use IO::File;
use Sort::Rank qw(rank_sort);
use Template;

# -------------------------------------
# Variables

my $LOG = 'logs/cpanstats.log';
my $CONFIG = './cpanmail.ini';

my %tvars;

# -------------------------------------
# Program

my $cgi = CGI->new();

process();
results();

# -------------------------------------
# Subroutines

=item process

Access the database and retrieve the required article data.

=cut

sub process {
    my %hash = @_;
    my $cfg;

    # load configuration file
    local $SIG{'__WARN__'} = \&_alarm_handler;
    eval { $cfg = Config::IniFiles->new( -file => $CONFIG ); };
    return 0    unless($cfg && !$@);

    # configure databases
    my $db = 'CPANSTATS';
    return 0    unless($cfg->SectionExists($db));
    my %opts = map {my $v = $cfg->val($db,$_); defined($v) ? ($_ => $v) : () }
                    qw(driver database dbfile dbhost dbport dbuser dbpass);
    my $dbh = CPAN::Testers::Common::DBUtils->new(%opts);
    return 0    unless($dbh);

    my $sql = q[
        SELECT DATE(FROM_UNIXTIME(released)) AS reldate,
               COUNT(*) AS num_dists,
               COUNT(distinct author) AS num_authors 
          FROM uploads 
         WHERE DATE(FROM_UNIXTIME(released)) >= DATE_SUB(NOW(),INTERVAL 30 DAY) 
      GROUP BY DATE(FROM_UNIXTIME(released))
      ORDER BY DATE(FROM_UNIXTIME(released)) DESC
    ];

    my @rows = $dbh->get_query('hash',$sql);
    if(@rows) {
        for my $row (@rows) {
            my ($y,$m,$d) = split('-',$row->{reldate});
            my $dt = DateTime->new({ year => $y, month => $m, day => $d });
            $row->{day} = ucfirst $dt->day_abbr;
        }

        $tvars{rows} = \@rows;
    }

    $sql = q[
        SELECT DATE(FROM_UNIXTIME(released)) AS name,
               COUNT(*) AS score
          FROM uploads 
      GROUP BY DATE(FROM_UNIXTIME(released))
      ORDER BY score DESC
         LIMIT 10
    ];

    my @releases = $dbh->get_query('hash',$sql);
    if(@releases) {
        my @sorted = rank_sort(\@releases);
        $tvars{releases} = \@sorted;
    }

    $sql = q[
        SELECT DATE(FROM_UNIXTIME(released)) AS name,
               COUNT(distinct author) AS score 
          FROM uploads 
      GROUP BY DATE(FROM_UNIXTIME(released))
      ORDER BY score DESC
         LIMIT 10
    ];

    my @authors = $dbh->get_query('hash',$sql);
    if(@authors) {
        my @sorted = rank_sort(\@authors);
        $tvars{authors} = \@sorted;
    }

    # top submitters today
    $sql = q[
        SELECT author AS name,
               COUNT(*) AS score 
          FROM uploads 
         WHERE DATE(FROM_UNIXTIME(released)) = DATE(NOW())
      GROUP BY author
      ORDER BY score DESC
         LIMIT 100
    ];

    my @submitters = $dbh->get_query('hash',$sql);
    if(@submitters) {
        my @sorted = rank_sort(\@submitters);
        $tvars{submitters} = \@sorted;
    }


    #neocpanism data
    $sql = q[
        SELECT x.name,
               COUNT(*) AS score 
          FROM (    SELECT dist,
                           DATE(FROM_UNIXTIME(MIN(released))) AS name 
                      FROM uploads
                  GROUP BY dist) AS x
      GROUP BY x.name
      ORDER BY score DESC
         LIMIT 10
    ];

    my @neodist = $dbh->get_query('hash',$sql);
    if(@neodist) {
        my @sorted = rank_sort(\@neodist);
        $tvars{neodist} = \@sorted;
    }

    $sql = q[
        SELECT x.name,
               COUNT(*) AS score 
          FROM (    SELECT author,
                           DATE(FROM_UNIXTIME(MIN(released))) AS name 
                      FROM uploads
                  GROUP BY author) AS x
      GROUP BY x.name
      ORDER BY score DESC
         LIMIT 10
    ];

    my @neoauth = $dbh->get_query('hash',$sql);
    if(@neoauth) {
        my @sorted = rank_sort(\@neoauth);
        $tvars{neoauth} = \@sorted;
    }


    # graph data
    my $today    = DateTime->now;
    my $tomorrow = DateTime->now->add( days => 1 );

    $tvars{start}   = DateTime->new({
        year      => $today->year,
        month     => $today->month,
        day       => $today->day,
        hour      => 0,
        minute    => 0,
        second    => 0,
        time_zone => 'UTC'
    })->epoch;
    $tvars{finish}  = DateTime->new({
        year      => $tomorrow->year,
        month     => $tomorrow->month,
        day       => $tomorrow->day,
        hour      => 0,
        minute    => 0,
        second    => 0,
        time_zone => 'UTC'
    })->epoch;

    $tvars{start}  = int($tvars{start}  / 600);
    $tvars{finish} = int($tvars{finish} / 600);

    $sql = q[
        SELECT round(released/600,0) AS reldate,
               COUNT(*) AS num
          FROM uploads
         WHERE DATE(FROM_UNIXTIME(released)) = DATE(NOW())
      GROUP BY round(released/600,0)
      ORDER BY released
    ];

    my @uploads = $dbh->get_query('hash',$sql);
    {
        my $last = $tvars{start};
        my $sum = 0;
        my (%data1,@data1,@data2,@data3,@data4);
        $data1{ $tvars{start} } = 0;

        for my $row (@uploads) {
            $sum += $row->{num};
            $data1{ $row->{reldate}} = $sum;
            $last = $row->{reldate};
        }

        my $cnt = 0;
        foreach(my $time = $tvars{start} ; $time <= $last ; $time++) {
            $cnt = $data1{$time} if($data1{$time});
            push @data1, { reldate => reldate(DateTime->from_epoch( epoch => $time*600 )->hms('')), num => $cnt };
        }

        foreach(my $time = $last ; $time <= $tvars{finish} ; $time++) {
            $cnt = $sum > 0 ? int( $sum / ($last - $tvars{start}) * ($time - $tvars{start}) ) : 0;
            push @data2, { reldate => reldate(DateTime->from_epoch( epoch => $time*600 )->hms('')), num => $cnt };
        }
        $data2[-1]->{reldate} = '24';

        push @data3, { reldate => '0', num => 150 }, { reldate => '24', num => 150 };
        push @data4, { reldate => '0', num => 1000 }, { reldate => '24', num => 1000 };

        $tvars{data}{layer1} = \@data1;
        $tvars{data}{layer2} = \@data2;
        $tvars{data}{layer3} = \@data3;
        $tvars{data}{layer4} = \@data4;
    }

    $sql = q[
        SELECT author,
               min(released) AS reldate
          FROM uploads
         WHERE DATE(FROM_UNIXTIME(released)) = DATE(NOW())
      GROUP BY author
      ORDER BY reldate
    ];

    my @uauthors = $dbh->get_query('hash',$sql);
    {
        my $last = $tvars{start};
        my $sum = 0;
        my (%data1,@data1,@data2,@data3,@data4);
        $data1{ $tvars{start} } = 0;

        for my $author (@uauthors) {
            my $time = int($author->{reldate} / 600);
            $sum++;
            $data1{ $time } = $sum;
            $last = $time;
        }

        my $cnt = 0;
        foreach(my $time = $tvars{start} ; $time <= $last ; $time++) {
            $cnt = $data1{$time} if($data1{$time});
            push @data1, { reldate => reldate(DateTime->from_epoch( epoch => $time*600 )->hms('')), num => $cnt };
        }

        foreach(my $time = $last ; $time <= $tvars{finish} ; $time++) {
            $cnt = $sum > 0 ? int( $sum / ($last - $tvars{start}) * ($time - $tvars{start}) ) : 0;
            push @data2, { reldate => reldate(DateTime->from_epoch( epoch => $time*600 )->hms('')), num => $cnt };
        }
        $data2[-1]->{reldate} = '24';

        push @data3, { reldate => '0', num => 74 }, { reldate => '24', num => 74 };
        push @data4, { reldate => '0', num => 100 }, { reldate => '24', num => 100 };

        $tvars{data}{layer5} = \@data1;
        $tvars{data}{layer6} = \@data2;
        $tvars{data}{layer7} = \@data3;
        $tvars{data}{layer8} = \@data4;
    }
}

sub reldate {
    my $time = shift;
    $time = int($time) / 10000;
    my $mod = $time - int($time);
    return int($time) if($mod == 0);
    return sprintf "%.2f", int($time) + ($mod/0.6);
}

=item results

Outputs the results using Template Toolkit

=cut

sub results {
    my %config = (								# provide config info
		RELATIVE		=> 1,
		ABSOLUTE		=> 1,
		INCLUDE_PATH	=> '.',
		INTERPOLATE		=> 0,
		POST_CHOMP		=> 1,
		TRIM			=> 1,
	);

    print $cgi->header;
	my $parser = Template->new(\%config);		# initialise parser
	$parser->process('uploads.html',\%tvars,'../uploads.html')	# parse the template
		or die $parser->error();
}

sub _alarm_handler () { return; }

__END__

=back

=head1 BUGS, PATCHES & FIXES

There are no known bugs at the time of this release. However, if you spot a
bug or are experiencing difficulties, that is not explained within the POD
documentation, please send an email to barbie@cpan.org. However, it would help
greatly if you are able to pinpoint problems or even supply a patch.

Fixes are dependant upon their severity and my availablity. Should a fix not
be forthcoming, please feel free to (politely) remind me.

=head1 SEE ALSO

L<CPAN::Testers::WWW::Statistics>.

F<http://stats.cpantesters.org/>

=head1 AUTHOR

  Barbie, <barbie@cpan.org>
  for Miss Barbell Productions <http://www.missbarbell.co.uk>.

=head1 COPYRIGHT AND LICENSE

  Copyright (C) 2005-2011 Barbie for Miss Barbell Productions.

  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.

=cut