#!/usr/bin/perl

use strict;
use warnings;
use Dpkg::Changelog::Debian;
use Dpkg::Control::Info;
use Dpkg::Version;
use File::Spec;
use Getopt::Long;
use HTTP::Tiny;
use List::Util qw ( uniq );
use JSON::XS;
use Pod::Usage qw( pod2usage );
use YAML::XS qw( LoadFile );
use Debian::PkgPerl::Util;
use 5.010;

my %opt;
GetOptions(
    \%opt,
    'help|h',
    'man|m',
    'limit|l=s',
) || pod2usage(2);
pod2usage(1) if $opt{help};
pod2usage( -exitval => 0, -verbose => 2 ) if $opt{man};

my $dpt_packages = $ENV{'DPT_PACKAGES'};
die "Required configuration variable DPT_PACKAGES is not set
in ~/.dpt.conf or ~/.config/dpt.conf or in your environment.\n" unless $dpt_packages;
$dpt_packages =~ s/~/$ENV{'HOME'}/;
die "No directory called '$dpt_packages' found: $!" unless -d $dpt_packages;

if ( $opt{limit} ) {
    die "$opt{limit} does not exist" unless -e $opt{limit};
}

my $uddfile = Debian::PkgPerl::Util->download_and_cache_file(
    'https://udd.debian.org/dmd/?email1=pkg-perl-maintainers%40lists.alioth.debian.org&format=json',
    'udd.debian.org-dmd-pkg-perl.json',
    6 * 60 * 60
);

my $todos;
open( my $fh, '<', $uddfile ) or die("open $uddfile: $!");
{
    local $/;
    $todos = decode_json(<$fh>);
}
close $fh;

my @newupstream = sort { $a->{':source'} cmp $b->{':source'} }
    grep { $_->{':shortname'} =~ /^newupstream_/ } @{$todos};

my $new_categorized = {};
foreach (@newupstream) {
    my $source   = $_->{':source'};
    my $uversion = $_->{':details'};

    # $uversion changed to '3.3.3 (currently in unstable: 3.3.1-1)'
    $uversion =~ s/^(\S+).*$/$1/;

    # libimage-base-bundle-perl: "empty+~1.17+~1.13+~1.11 (currently in unstable: 2+~1.17+~1.13+~1.11-1)"
    warn("Invalid upstream version '$uversion' in UDD data for package '$source'.\n"), next
        unless version_check($uversion);

    # HACK, part 1
    # Dpkg::Version's version_compare_relation chokes on invalid versions,
    # like 1.22_90, so let's mangle our $uversion.
    # Either '.' or '~' could make sense, or even '-' or '+'.
    # The only character found in the wild currently is one '-'.
    # Let's take a 'plus' (easy to revert later).
    $uversion =~ s/_/+/g;

    if ( $opt{limit} ) {
        my $packages = (LoadFile( $opt{limit} ))[0]->{packages};
        next unless grep { $_ eq $source } uniq map {
            $_->{package}
        } ( @{$packages->{binary}}, @{$packages->{source}} );
    }

    my $changelogfile
        = File::Spec->catfile( $dpt_packages, $source, 'debian', 'changelog' );
    warn("Can't find changelog '$changelogfile' for package '$source'.\n"), next
        unless -f $changelogfile;
    my $changelog = Dpkg::Changelog::Debian->new( range => { "count" => 1 } );
    $changelog->load($changelogfile);
    my $entry = @{$changelog}[0];    # Dpkg::Changelog::Entry::Debian object
    my $dversion       = $entry->get_version();
    my $dist           = $entry->get_distributions();

    next if version_compare_relation($dversion, REL_GE, $uversion)
        && $dist ne 'UNRELEASED';

    my @items          = $entry->get_change_items();
    my $ignore_version = grep {
        my ($ignored_version) = ( /^\s+IGNORE-VERSION:\s+(\S*)/ );
        if ( defined $ignored_version ) {
            warn("Invalid version '$ignored_version' in IGNORE-VERSION entry for package '$source'.\n"), next
                unless version_check($ignored_version);
            version_compare_relation( $ignored_version, REL_GE, $uversion );
        }
    } @items;
    my $waits_for      = grep {
        my ( $wf_pkg, $wf_version ) = ( /^\s+WAITS-FOR:\s+(\S*)\s?(\S*)/ );
        $wf_version ||= '0';
        defined $wf_pkg && !madison( $wf_pkg, $wf_version );
    } @items;
    my $problem        = grep /^\s+(PROBLEM|TODO|NOTE|WARNING|FIXME|QUESTION):/, @items
        if version_compare_relation($dversion, REL_GE, $uversion);

    # HACK, part 2
    # Mangle $uversion back, now that we don't need any more comparisons.
    $uversion =~ s/\+/_/g;

    my $controlfile
        = File::Spec->catfile( $dpt_packages, $source, 'debian', 'control' );
    warn("Can't find control '$controlfile' for package '$source'.\n"), next
        unless -f $controlfile;
    my $control       = Dpkg::Control::Info->new($controlfile);      # Dpkg::Control object
    my $build_depends = $control->get_source()->{'Build-Depends'};   # string!

    # categorize new upstream releases
    my $pkg = {
        source   => $source,
        dist     => $dist,
        dversion => "$dversion",    # stringify Dpkg::Version
        uversion => $uversion,
    };
    push @{ $new_categorized->{'ignore-version'} }, $pkg if $ignore_version;
    push @{ $new_categorized->{'waits-for'} },      $pkg if $waits_for;
    push @{ $new_categorized->{'problem'} },        $pkg if $problem;
    push @{ $new_categorized->{'default'} },        $pkg
        unless ( $ignore_version or $waits_for or $problem );

}

my @categories = (qw/default problem ignore-version waits-for/);
foreach (@categories) {
    my $category = $_;
    next unless defined( $new_categorized->{$category} );
    my @categoryentries = @{ $new_categorized->{$category} };
    my $title
        = "New upstream releases ($category): " . scalar(@categoryentries);

    say "\n$title";
    say '=' x 101;
    my $format = "%-55s %-30s %-15s\n";
    printf $format, 'Source package', 'Status git', 'Upstream (DMD)';
    say '-' x 101;

    foreach (@categoryentries) {
        printf $format, $_->{'source'},
            $_->{'dist'} . '/' . $_->{'dversion'},
            $_->{'uversion'};
    }
}

exit;

sub madison {
    # returns 1 if the requested package (at the requested version)
    # is found by madison, undef otherwise

    my ( $pkg, $version ) = @_;
    $version //= 0;

    my $url
        = "https://api.ftp-master.debian.org/madison?f=1&b=deb&s=unstable&S=true&package=$pkg";
    my $response = HTTP::Tiny->new->get($url);
    warn "Querying madison failed.\n", return unless $response->{success};
    my $content = $response->{content};
    warn "Querying madison returned empty content.\n", return
        unless length $content;

    my $json    = JSON::XS->new->utf8;
    my $madison = $json->decode($content)->[0];
    return unless $madison;                 # empty resultset, aka $pkg not found
    return unless exists $madison->{$pkg};  # $pkg not in resultset
    my ($madison_version) = keys %{ $madison->{$pkg}->{'unstable'} };
    return
        unless version_compare_relation( $madison_version, REL_GE, $version )
        ;                                   # found version not enough
    return 1;
}

__END__

=head1 NAME

dpt-new-upstream - list packages with newer upstream versions

=head1 SYNOPSIS

B<dpt new-upstream> I<[--help|-h]> I<[--man|-m]> I<[--limit|-l PACKAGES_LIST_FILE]>

=head1 DESCRIPTION

B<dpt new-upstream> queries UDD's DMD for newer upstream versions, compares
the results to the local git clones, categorizes the found packages, and
outputs tables by category. If this reminds you of PET -- you're not wrong
to assume that there was some inspiration taken from there.

/*

=over

=item UDD: Ultimate Debian Database

=item DMD: Debian Maintainer Dashboard

=item PET: Package Entropy Tracker

=back

*/

=head1 OPTIONS

=over

=item B<--help|-h>

Show this help.

=item B<--man|-m>

Show full manpage.

=item B<--limit|-l PACKAGES_LIST_FILE>

Output the intersection of the full result set and of the set of
packages found in C<PACKAGES_LIST_FILE>.

C<PACKAGES_LIST_FILE> must be in YAML format used by Tails build manifests,
for example:

L<https://nightly.tails.boum.org/build_Tails_ISO_stable/lastSuccessful/archive/latest.build-manifest>

Known issue: the current implementation assumes that every binary
package on this list is built from an identically named source package.

=back

=head1 CONFIGURATION

B<dpt new-upstream> uses the C<DPT_PACKAGES> environment variable.

See L<dpt-config(5)> for details.

=head1 COPYRIGHT AND LICENSE

Copyright 2018-2025, gregor herrmann E<lt>gregoa@debian.orgE<gt>

Copyright 2019, intrigeri E<lt>intrigeri@boum.orgE<gt>

Released under the same terms as Perl itself, i.e. Artistic or GPL-1+.