#!/usr/bin/perl

=encoding utf8

=head1 NAME

check-upstream-versions - Look for new CGI::Application plugins for this package

=head1 SYNOPSIS

    check-upstream-versions [d][h][l][v][?]
    
=head1 VERSION

1.0, 08 Jul 2010

=cut

our $VERSION = '1.0';

use warnings;
use strict;
use 5.010;
use Cache::FileCache;
use Cwd qw( cwd );
use English qw( -no_match_vars );
use Getopt::Std;
use List::Util qw( maxstr );
use LWP::Simple;
use Pod::Usage;
use Text::SimpleTable;

=head1 OPTIONS

With no options the script will query CPAN for the latest versions of the
plugins in this package and make a nice ASCII table comparing them to the
versions currently packages.

=head2 -d

Downloads the latest plugin versionsfrom CPAN and removes obsolete versions.

=head2 -h

Shows help for this script.

=head2 -l

Lists the modules in the package, one per line.

=head2 -v

Shows the version number of this script.

=head2 -?

Same as B<-h>.

=cut

my %opts;

getopts('dhlv?', \%opts) ||
    Pod::Usage::pod2usage(-verbose => 0);

if (exists $opts{h} || exists $opts{'?'}) {
    Pod::Usage::pod2usage(-verbose => 2);
}
elsif (exists $opts{v}) {
    say $VERSION;
    exit 0;
}

my $cache = Cache::FileCache->new();
my $packages = parse();

if (exists $opts{d}) {
    download($packages);
}
elsif (exists $opts{l}) {
    list_modules($packages);
}
else {
    whats_new($packages);
}

0;

my $debcopystart = <<EOF;
This package was debianized by Jaldhar H. Vyas <jaldhar\@debian.org>  on
Fri, 22 Aug 2008 22:01:00 -0400

It contains several upstream packages which may have different licenses.

They are all downloaded from http://search.cpan.org/
EOF

my $debcopyright = <<EOF;
-----------------------------------------------------------------------------
Perl is distributed under licenses:

        a) the GNU General Public License as published by the Free Software
           Foundation; either version 1, or (at your option) any later
           version, or

        b) the "Artistic License" which comes with Perl.

On Debian GNU/Linux systems, the complete text of the GNU General Public
License can be found in /usr/share/common-licenses/GPL and the Artistic
Licence in /usr/share/common-licenses/Artistic.
EOF

my $debcopyinfo = <<EOF;
This program is free software, you can redistribute it and/or modify it under the same terms as Perl itself.
EOF

sub download {
    my ($packages) = @_;
    
    my $curdir = cwd;
    opendir my $updir, "$curdir/.." or die "$OS_ERROR\n";
    my @entries = grep { !/ ^ \. /msx } readdir($updir);
    closedir $updir or die "$OS_ERROR\n";
    my $base = $curdir;
    $base =~ s{ .+ / ( .+ $)}{$1}msx;
    $base =~ s{- ([[:digit:]]+)}{_$1}msx;
    $base .= '.orig';

    foreach my $module (keys %{ $packages }) {
        my $url = $packages->{$module}->{watch};
        chomp ($module, $url);

        my $oldver = get_old_ver($module, \@entries);
        my $newver = get_new_ver($module, $url);

        if ($oldver < $newver) { 
            my @files = grep { /$base-$module/msx } @entries;
            my $oldfile = exists $files[0] ? '../' . $files[0] : q{};
            my $url = $packages->{"$module\n"}->{watch};
            $url =~ s{ \( .+ \) }{$newver}msx;
            $url =~ s{ \\ }{}gmsx;
            my $newfile = $url;
            chomp $newfile;
            $newfile =~ s{ .+ / (.+) \.tar\.gz$ }{$1}msx;
            $newfile =~ s{ \. }{-}gmsx;
            $newfile = "../$base-$newfile.tar.gz"; 
            print "Getting $url to $newfile\n";
            if (is_success(getstore($url, $newfile))) {
                if ( -f $oldfile ) {
                    print "Removing $oldfile\n";
                    unlink $oldfile or die "$OS_ERROR\n";
                }
            }
            else {
                print "Couldn't get $url\n";
            }
        }
    }

    return;
}

sub list_modules {
    my ($packages) = @_;
    
    foreach (keys %{ $packages }) {
        print "$_";
    }

    return;
}

sub parse {
    open my $cfg, '<', './debian/packages.cfg' or die "$OS_ERROR\n";

    local $INPUT_RECORD_SEPARATOR = "\n\n";

    my %packages = ();

    while (my $stanza = <$cfg>) {
        my @lines = split /\n/, $stanza;
        my $field;
        my $current_field;
        my %package;
        foreach my $line (@lines) {
            $line =~ /
                (?<field> ^ [[:alpha:]]+ )?
                ( : \s* )?
                (?<line> .+ $) 
            /msx;

            if (defined $LAST_PAREN_MATCH{field}) {
                $current_field = $LAST_PAREN_MATCH{field};
                $package{$current_field} = "$LAST_PAREN_MATCH{line}\n";
            }
            else {
                $package{$current_field}
                    .= "$LAST_PAREN_MATCH{line}\n";
            }
        }
        $packages{$package{name}} = \%package;
    } 

    close $cfg or die "$OS_ERROR\n";

    return \%packages;
}

sub whats_new {
    my ($packages) = @_;
    
    my $table = Text::SimpleTable->new([37, 'Module'], [10, 'Debian'],
        [10, 'Upstream'], [10, 'Comment']);

    my $curdir = cwd;
    opendir my $updir, "$curdir/.." or die "$OS_ERROR\n";
    my @entries = grep { !/ ^ \. /msx } readdir($updir);
    closedir $updir or die "$OS_ERROR\n";

    foreach my $module (keys %{ $packages }) {
        my $url = $packages->{$module}->{watch};
        chomp ($module, $url);
        my $oldver = get_old_ver($module, \@entries);
        my $newver = get_new_ver($module, $url);
        
        my $comment;
        given ($oldver) {
            when ($_ < $newver) { $comment = 'too old'; }
            when ($_ > $newver) { $comment = 'too new!'; }
            default             { $comment = 'ok'; }
        }
        $table->row($module, $oldver, $newver, $comment);
    }

    print $table->draw;

    return;
}


sub get_new_ver {
    my ($module, $url) = @_;
    
    my ($u_dir, $u_file) = $url =~ m{(.+/)(.+)$}msx;

    my $dir = $cache->get('dir');
    if (! defined $dir) {
        $dir = get($u_dir);
        $cache->set('dir', $dir, '10 minutes');
    }
    my @found = $dir =~ m{$u_file}gmsx;
    my $newver = maxstr(@found);
    
    return $newver // 0;
}

sub get_old_ver {
    my ($module, $entries) = @_;
    
    my $base = cwd;
    $base =~ s{ .+ / ( .+ $)}{$1}msx;
    $base =~ s{- ([[:digit:]]+)}{_$1}msx;
    $base .= '.orig';

    my @files = grep { /$base-$module/msx } @{ $entries };
    if (! exists $files[0] ) {
        return 0;
    }
    $files[0] =~ m{ $module - (?<version> [0-9\-]+) \.tar\.gz $ }msx;
    my $oldver = $LAST_PAREN_MATCH{version};
    if (defined $oldver) {
        $oldver =~ s/-/./gmsx;
    }
    
    return $oldver // 0;
}

=head1 AUTHOR

Jaldhar H. Vyas, C<< <jaldhar at debian.org> >>

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2010 Jaldhar H. Vyas.

"Do what thou wilt shall be the whole of the license."

=cut

__END__
