Implement basic check for upgradable packages

Signed-off-by: Florian Pritz <bluewind@xinu.at>

8 files changed, 448 insertions, 8 deletions

diff --git a/META.json b/META.json
index fe4d373..ba80617 100644
--- a/META.json
+++ b/META.json
@@ -42,7 +42,20 @@
       },
       "runtime" : {
          "requires" : {
-            "perl" : "5.008001"
+            "CPAN::DistnameInfo" : "0",
+            "CPANPLUS::Backend" : "0",
+            "Function::Parameters" : "0",
+            "IO::Zlib" : "0",
+            "Log::Any" : "0",
+            "Log::Any::Adapter" : "0",
+            "Log::Log4perl" : "0",
+            "Path::Tiny" : "0",
+            "Syntax::Keyword::Try" : "0",
+            "TOML" : "0",
+            "autodie" : "0",
+            "perl" : "v5.24.0",
+            "strictures" : "0",
+            "version" : "0"
          }
       },
       "test" : {
diff --git a/README.md b/README.md
index f8e267e..78ac186 100644
--- a/README.md
+++ b/README.md
@@ -10,6 +10,16 @@ App::ArchLinux::PackagerTools - It's new $module
 
 App::ArchLinux::PackagerTools is ...
 
+# METHODS
+
+## Constructors
+
+### new
+
+    App::ArchLinux::PackagerTools->new();
+
+Returns a new instance.
+
 # LICENSE
 
 Copyright (C) 2018  Florian Pritz <bluewind@xinu.at>
diff --git a/cpanfile b/cpanfile
index 3f15d5e..c1b1ec1 100644
--- a/cpanfile
+++ b/cpanfile
@@ -1,4 +1,21 @@
-requires 'perl', '5.008001';
+requires 'CPAN::DistnameInfo';
+requires 'CPANPLUS::Backend';
+requires 'Function::Parameters';
+requires 'IO::Zlib';
+requires 'Log::Any';
+requires 'Log::Any::Adapter';
+requires 'Log::Log4perl';
+requires 'Path::Tiny';
+requires 'Syntax::Keyword::Try';
+requires 'TOML';
+requires 'autodie';
+requires 'perl', 'v5.24.0';
+requires 'strictures';
+requires 'version';
+
+on configure => sub {
+    requires 'Module::Build::Tiny', '0.035';
+};
 
 on 'test' => sub {
     requires 'Test::More', '0.98';
diff --git a/lib/App/ArchLinux/PackagerTools.pm b/lib/App/ArchLinux/PackagerTools.pm
index 0e83434..d8cb89d 100644
--- a/lib/App/ArchLinux/PackagerTools.pm
+++ b/lib/App/ArchLinux/PackagerTools.pm
@@ -1,14 +1,15 @@
 package App::ArchLinux::PackagerTools;
-use 5.008001;
-use strict;
-use warnings;
+use v5.24;
+use strictures;
 
 our $VERSION = "0.01";
 
+use autodie;
+use Function::Parameters;
+use Log::Any qw($log);
 
-
-1;
-__END__
+use App::ArchLinux::PackagerTools::Pacman;
+use App::ArchLinux::PackagerTools::CPAN;
 
 =encoding utf-8
 
@@ -24,6 +25,55 @@ App::ArchLinux::PackagerTools - It's new $module
 
 App::ArchLinux::PackagerTools is ...
 
+=head1 METHODS
+
+=head2 Constructors
+
+=head3 new
+
+ App::ArchLinux::PackagerTools->new();
+
+Returns a new instance.
+
+=cut
+method new($class: $deps = {}) {
+	$deps->{cpan} //= App::ArchLinux::PackagerTools::CPAN->new();
+	$deps->{pacman} //= App::ArchLinux::PackagerTools::Pacman->new({$deps->%{cpan}});
+	return $class->new_no_defaults($deps);
+}
+
+method new_no_defaults($class: $deps = {}) {
+	my $self = {};
+	bless $self, $class;
+	$self->{deps} = $deps;
+	return $self;
+}
+
+method get_distributions_in_repo() {
+	return $self->{deps}->{pacman}->get_perl_distributions();
+}
+
+method get_updateable_packages($distribution_names) {
+	my @packages;
+	for my $dist_name ($distribution_names->@*) {
+		my $repo_version = $self->{deps}->{pacman}->get_perl_distribution_version($dist_name);
+		my $dist = $self->{deps}->{cpan}->get_dist($dist_name);
+		if ($self->{deps}->{cpan}->is_newer_version_available($dist_name, $repo_version)) {
+			$log->infof('New version available for dist \'%s\': %s', $dist_name, $dist->{version});
+			push @packages, {
+				dist_name => $dist_name,
+				repo_version => $repo_version,
+				cpan_version => $dist->{version},
+				pkgname => $self->{deps}->{pacman}->get_perl_pkgname($dist_name),
+			};
+		} else {
+			$log->debugf('Dist \'%s\' is already up to date with version %s', $dist_name, $dist->{version});
+		}
+
+	}
+	return \@packages;
+}
+
 =head1 LICENSE
 
 Copyright (C) 2018  Florian Pritz E<lt>bluewind@xinu.atE<gt>
@@ -48,3 +98,6 @@ Florian Pritz E<lt>bluewind@xinu.atE<gt>
 
 =cut
 
+1;
+
+__END__
diff --git a/lib/App/ArchLinux/PackagerTools/CPAN.pm b/lib/App/ArchLinux/PackagerTools/CPAN.pm
new file mode 100644
index 0000000..175e218
--- /dev/null
+++ b/lib/App/ArchLinux/PackagerTools/CPAN.pm
@@ -0,0 +1,154 @@
+package App::ArchLinux::PackagerTools::CPAN;
+use strictures;
+
+use autodie;
+use CPAN::DistnameInfo;
+use CPANPLUS::Backend;
+use Carp;
+use Function::Parameters;
+use IO::Zlib;
+use Log::Any qw($log);
+use Syntax::Keyword::Try;
+use version;
+
+=head1 NAME
+
+App::ArchLinux::PackagerTools::CPAN - Methods to interact with CPAN
+
+=head1 SYNOPSIS
+
+use App::ArchLinux::PackagerTools::CPAN;
+
+# synopsis...
+
+=head1 DESCRIPTION
+
+# longer description...
+
+=head1 METHODS
+
+=head2 new
+
+ App::ArchLinux::PackagerTools::CPAN->new();
+
+Returns a new instance.
+
+=cut
+
+method new($class: $deps = {}) {
+	$deps->{cpanplus_backend} //= CPANPLUS::Backend->new();
+	return $class->new_no_defaults($deps);
+}
+
+method new_no_defaults($class: $deps = {}) {
+	my $self = {};
+	bless $self, $class;
+	$self->{deps} = $deps;
+	$self->{dist_lc_map} = {};
+	$self->{dists} = {};
+	$self->_build_dist_index();
+	return $self;
+}
+
+=head2 Public Methods
+
+=head3 is_newer_version_available
+
+Return 1 if a newer version of the distribution is available, 0 otherwise.
+
+=cut
+
+method is_newer_version_available($dist_name, $version) {
+	my $dist = $self->get_dist($dist_name);
+	# TODO compare versions rather than not-equal check
+	my $dist_version = version->parse($dist->{version});
+	if ($dist_version > version->parse($version)) {
+		return 1;
+	} else {
+		return 0;
+	}
+}
+
+method _build_dist_index() {
+	$self->{deps}->{cpanplus_backend}->reload_indices();
+	# TODO download pacakges list ourselves instead of using cpanplus for it? We may need cpanplus for other features later so keeping it is probably also fine.
+
+	my $packages_file = "$ENV{HOME}/.cpanplus/02packages.details.txt.gz";
+	my $fh = IO::Zlib->new($packages_file, 'r');
+	my %seen;
+	my $line_number = 0;
+	while (<$fh>) {
+		# skip meta info (first 9 lines)
+		next if $line_number++ < 9;
+
+		#$log->tracef("Parsing line: %s", $_);
+		my ($module_name, $module_version, $file) = split /\s+/;
+
+		next if $seen{$file}++ > 0;
+
+		my $dist = CPAN::DistnameInfo->new($file);
+		if (!defined $dist->{dist}) {
+			$log->debugf("Failed to parse file: %s", $file);
+			next;
+		}
+
+		my $dist_name = $dist->{dist};
+		my $dist_name_lc = lc($dist_name);
+
+		my $dist_version;
+		try {
+			$dist_version = version->parse($dist->{version});
+		} catch {
+			$log->debugf("Skipping dist with invalid version: %s", $@);
+			$log->debugf("Skipped dist is: %s", $dist);
+			next;
+		}
+
+		my $index_dist;
+		my $index_version = version->parse($self->{dists}->{$dist_name}->{version});
+		my $index_name = $self->{dist_lc_map}->{$dist_name_lc};
+		$index_dist = $self->{dists}->{$index_name} if defined $index_name;
+
+		if (!defined($index_dist)
+			|| (defined($index_dist) && $index_name eq $dist_name && $dist_version > $index_version)
+		) {
+			$self->{dist_lc_map}->{$dist_name_lc} = $dist_name;
+			$self->{dists}->{$dist_name} = {
+				dist_name => $dist_name,
+				version => $dist->{version},
+			};
+		} else {
+			if ($dist_name ne $index_name && $dist_version < $index_version) {
+				confess $log->errorf("Key '%s' already exists in lc_map. This requires a manual exception to map correctly.\nExisting: %s\nCurrent: %s", $dist_name_lc, $index_dist, {$dist->%{qw(dist version)}});
+			}
+		}
+	}
+}
+
+method search_dist($name) {
+	$name =~ s/::/-/g;
+	$log->tracef("Searching for CPAN distribution matching '%s'", $name);
+
+	my $index_name = $self->{dist_lc_map}->{lc($name)};
+	if (defined $index_name) {
+		return $self->{dists}->{$index_name};
+	}
+
+	return;
+}
+
+method get_dist($dist_name) {
+	$dist_name =~ s/::/-/g;
+	$log->tracef("Getting CPAN data for distribution '%s'", $dist_name);
+
+	my $index_name = $self->{dist_lc_map}->{lc($dist_name)};
+	if (defined $index_name) {
+		return $self->{dists}->{$index_name};
+	}
+
+	croak $log->errorf("Failed to find distribution with name %s", $dist_name);
+}
+
+1;
+
+__END__
diff --git a/lib/App/ArchLinux/PackagerTools/Pacman.pm b/lib/App/ArchLinux/PackagerTools/Pacman.pm
new file mode 100644
index 0000000..765746e
--- /dev/null
+++ b/lib/App/ArchLinux/PackagerTools/Pacman.pm
@@ -0,0 +1,126 @@
+package App::ArchLinux::PackagerTools::Pacman;
+use strictures;
+
+use autodie;
+use Function::Parameters;
+use Log::Any qw($log);
+
+=head1 NAME
+
+App::ArchLinux::PackagerTools::Pacman - Methods to interact with pacman
+
+=head1 SYNOPSIS
+
+  use App::ArchLinux::PackagerTools::Pacman;
+
+  # synopsis...
+
+=head1 DESCRIPTION
+
+This module allows to query pacman for a list of packages in the repository and
+extract a list of perl distributions that are part of the repository.
+
+
+=head1 METHODS
+
+=head2 Constructors
+
+=head3 new
+
+ App::ArchLinux::PackagerTools::Pacman->new();
+
+Returns a new instance.
+
+=cut
+
+
+method new($class: $deps = {}) {
+	$deps->{cpan} //= App::ArchLinux::PackagerTools::CPAN->new();
+	$deps->{pkgname_cpan_name_map} //= {
+		# pkgname => cpan_name
+		'perl-critic' => 'Perl::Critic',
+		'perl-libintl-perl' => 'libintl-perl',
+	};
+	return $class->new_no_defaults($deps);
+}
+
+method new_no_defaults($class: $deps = {}) {
+	my $self = {};
+	bless $self, $class;
+	$self->{deps} = $deps;
+	return $self;
+}
+
+=head2 Public Methods
+
+=head3 get_packages
+
+Returns an arrayref of package hashes. Each package hash contains at least the
+pkgname and pkgver keys.
+
+=cut
+
+method get_packages() {
+	my @packages;
+	open my $fh, '-|', 'expac -S \'%n %v\'';
+	my %seen;
+	while (<$fh>) {
+		if (m/^(?<pkgname>[^\s]+) (?<pkgver>.*)$/) {
+			push @packages, {%+};
+		}
+	}
+	return \@packages;
+}
+
+method get_perl_packages() {
+	my @packages = grep {$_->{pkgname} =~ /^perl-/} $self->get_packages->@*;
+	$log->debugf("Found %d perl packages", scalar(@packages));
+	return \@packages;
+}
+
+method get_perl_distributions() {
+	my @distributions;
+
+	for my $package ($self->get_perl_packages()->@*) {
+		my $cleaned_name = $package->{pkgname} =~ s/^perl-//r;
+		my $dist;
+		if (defined $self->{deps}->{pkgname_cpan_name_map}->{$package->{pkgname}}) {
+			$dist = $self->{deps}->{cpan}->get_dist($self->{deps}->{pkgname_cpan_name_map}->{$package->{pkgname}});
+		} else {
+			$dist = $self->{deps}->{cpan}->search_dist($cleaned_name);
+		}
+		push @distributions, $dist if defined $dist;
+		$log->warningf("Failed to find distribution for package '%s'", $package) if !defined $dist;
+	}
+	return \@distributions;
+}
+
+method get_package_version($pkgname) {
+	# TODO do not fork expac for each package here! works for now, but it's sloooow
+	my $version = `expac -S -1 '%v' -- '$pkgname'`;
+	chomp $version;
+	return $version;
+}
+
+method get_perl_pkgname($dist_name) {
+	my $pkgname = lc($dist_name);
+	$pkgname =~ s/::/-/g;
+	$pkgname = "perl-$pkgname";
+	return $pkgname;
+}
+
+method get_perl_distribution_version($dist_name) {
+	my $pkgname = $self->get_perl_pkgname($dist_name);
+	my $version = $self->get_package_version($pkgname);
+	# remove pkgrel
+	$version =~ s/-\d+(\.\d+)?$//;
+	# remove epoch
+	$version =~ s/^\d+://;
+
+	$log->tracef("Found version '%s' for package '%s'", $version, $pkgname);
+	return $version;
+}
+
+1;
+
+__END__
diff --git a/script/perlpkg.pl b/script/perlpkg.pl
new file mode 100755
index 0000000..7bfff3a
--- /dev/null
+++ b/script/perlpkg.pl
@@ -0,0 +1,65 @@
+#!/usr/bin/env perl
+
+use v5.24;
+
+use warnings;
+use strict;
+
+use Function::Parameters;
+use Log::Any::Adapter;
+use Log::Log4perl qw(:easy);
+use Path::Tiny;
+use TOML qw(from_toml);
+
+use App::ArchLinux::PackagerTools;
+
+=head1 NAME
+
+perlpkg.pl - Script to support perl packaging on Arch Linux
+
+=head1 SYNOPSIS
+
+  perlpkg.pl [options]
+
+  Options:
+    --debug
+
+=head1 DESCRIPTION
+
+TODO
+
+=head1 CONFIGURATION
+
+To configure the script create a file called $XDG_CONFIG_HOME/perlpkg/config.toml.
+
+The configuration file is not yet used/read.
+
+TODO
+
+=head1 SEE ALSO
+
+L<App::ArchLinux::PackagerTools>
+
+=cut
+
+#my $config = from_toml(path(($ENV{XDG_CONFIG_HOME} // $ENV{HOME}."/.config")."/perlpkg/config.toml")->slurp);
+
+Log::Log4perl->easy_init($ERROR);
+if ($ARGV[0] // "" eq "--debug") {
+	Log::Log4perl->easy_init($TRACE);
+} else {
+	Log::Log4perl->easy_init($INFO);
+}
+Log::Any::Adapter->set('Log4perl');
+
+my $app = App::ArchLinux::PackagerTools->new();
+
+use Data::Dumper;
+my $dists = $app->get_distributions_in_repo();
+my $dist_names = [map {$_->{dist_name}} $dists->@*];
+print Dumper($app->get_updateable_packages($dist_names));
+
+# TODO fetch maintainer from archweb
+# TODO generate new pacakge pkgbuild
+# TODO build
+# TODO release
diff --git a/t/compile.t b/t/compile.t
index e8e5f22..b0bdaa5 100644
--- a/t/compile.t
+++ b/t/compile.t
@@ -3,6 +3,8 @@ use Test::More 0.98;
 
 use_ok $_ for qw(
     App::ArchLinux::PackagerTools
+    App::ArchLinux::PackagerTools::CPAN
+    App::ArchLinux::PackagerTools::Pacman
 );
 
 done_testing;