SBO::Lib::Pkgs: separate out package utils from SBO::Lib

Also adds documentation for the utils.

1 files changed, 207 insertions, 0 deletions

diff --git a/SBO-Lib/lib/SBO/Lib/Pkgs.pm b/SBO-Lib/lib/SBO/Lib/Pkgs.pm
new file mode 100644
index 0000000..ec1f182
--- /dev/null
+++ b/SBO-Lib/lib/SBO/Lib/Pkgs.pm
@@ -0,0 +1,207 @@
+package SBO::Lib::Pkgs;
+
+use 5.016;
+use strict;
+use warnings;
+
+our $VERSION = '2.0';
+
+use SBO::Lib::Util qw/ %config script_error open_read version_cmp /;
+use SBO::Lib::Tree qw/ get_orig_version get_sbo_location get_sbo_locations is_local /;
+use SBO::Lib::Info qw/ get_sbo_version /;
+
+use Exporter 'import';
+
+our @EXPORT_OK = qw{
+  get_available_updates
+  get_inst_names
+  get_installed_cpans
+  get_installed_packages
+  get_local_outdated_versions
+};
+
+our %EXPORT_TAGS = (
+  all => \@EXPORT_OK,
+);
+
+=head1 NAME
+
+SBO::Lib::Pkgs - Routines for interacting with the Slackware package database.
+
+=head1 SYNOPSIS
+
+  use SBO::Lib::Pkgs qw/ get_installed_packages /;
+
+  my @installed_sbos = get_installed_packages('SBO');
+
+=head1 SUBROUTINES
+
+=cut
+
+my $pkg_db = '/var/log/packages';
+
+=head2 get_available_updates
+
+  my @updates = @{ get_available_updates() };
+
+C<get_available_updates()> compares the installed versions in
+C</var/log/packages> that are tagged as SBo with the version available from
+the SlackBuilds.org or C<LOCAL_OVERRIDES> repository, and returns an array
+reference to an array of hash references which specify package names, and
+installed and available versions.
+
+=cut
+
+# for each installed sbo, find out whether or not the version in the tree is
+# newer, and compile an array of hashes containing those which are
+sub get_available_updates {
+    my @updates;
+    my $pkg_list = get_installed_packages('SBO');
+
+    for my $pkg (@$pkg_list) {
+        my $location = get_sbo_location($pkg->{name});
+        next unless $location;
+
+        my $version = get_sbo_version($location);
+        if (version_cmp($version, $pkg->{version}) != 0) {
+            push @updates, { name => $pkg->{name}, installed => $pkg->{version}, update => $version };
+        }
+    }
+
+    return \@updates;
+}
+
+=head2 get_inst_names
+
+  my @names = get_inst_names(get_available_updates());
+
+C<get_inst_names()> returns a list of package names from an array reference
+such as the one returned by C<get_available_updates()>.
+
+=cut
+
+# for a ref to an array of hashes of installed packages, return an array ref
+# consisting of just their names
+sub get_inst_names {
+    script_error('get_inst_names requires an argument.') unless @_ == 1;
+    my $inst = shift;
+    my @installed;
+    push @installed, $$_{name} for @$inst;
+    return \@installed;
+}
+
+=head2 get_installed_cpans
+
+  my @cpans = @{ get_installed_cpans() };
+
+C<get_installed_cpans()> returns an array reference to a list of the perl
+modules installed from the CPAN rather than from packages on SlackBuilds.org.
+
+=cut
+
+# return a list of perl modules installed via the CPAN
+sub get_installed_cpans {
+  my @contents;
+  for my $file (grep { -f $_ } map { "$_/perllocal.pod" } @INC) {
+    my ($fh, $exit) = open_read($file);
+    next if $exit;
+    push @contents, grep {/Module/} <$fh>;
+    close $fh;
+  }
+  my $mod_regex = qr/C<Module>\s+L<([^\|]+)/;
+  my (@mods, @vers);
+  for my $line (@contents) {
+    push @mods, ($line =~ $mod_regex)[0];
+  }
+  return \@mods;
+}
+
+=head2 get_installed_packages
+
+  my @packages = @{ get_installed_packages($type) };
+
+C<get_installed_packages()> returns an array reference to a list of packages in
+C</var/log/packages> that match the specified C<$type>. The available types are
+C<STD> for non-SBo packages, C<SBO> for SBo packages, and C<ALL> for both.
+
+The returned array reference will hold a list of hashes representing both names
+and versions of the returned packages.
+
+=cut
+
+# pull an array of hashes, each hash containing the name and version of a
+# package currently installed. Gets filtered using STD, SBO or ALL.
+sub get_installed_packages {
+  script_error('get_installed_packages requires an argument.') unless @_ == 1;
+  my $filter = shift;
+
+  # Valid types: STD, SBO
+  my (@pkgs, %types);
+  foreach my $pkg (glob("$pkg_db/*")) {
+    my ($name, $version, $build) = $pkg =~ m#/([^/]+)-([^-]+)-[^-]+-([^-]+)$#
+      or next;
+    push @pkgs, { name => $name, version => $version, build => $build };
+    $types{$name} = 'STD';
+  }
+
+  # If we want all packages, let's just return them all
+  return [ map { +{ name => $_->{name}, version => $_->{version} } } @pkgs ]
+    if $filter eq 'ALL';
+
+  # Otherwise, mark the SBO ones and filter
+  my @sbos = map { $_->{name} } grep { $_->{build} =~ m/_SBo(|compat32)$/ }
+    @pkgs;
+  if (@sbos) {
+    my %locations = get_sbo_locations(map { s/-compat32//gr } @sbos);
+    foreach my $sbo (@sbos) { $types{$sbo} = 'SBO'
+      if $locations{ $sbo =~ s/-compat32//gr }; }
+  }
+  return [ map { +{ name => $_->{name}, version => $_->{version} } }
+    grep { $types{$_->{name}} eq $filter } @pkgs ];
+}
+
+=head2 get_local_outdated_versions
+
+  my @outdated = get_local_outdated_versions();
+
+C<get_local_outdated_versions()> checks the installed SBo packages and returns
+a list of the ones for which the C<LOCAL_OVERRIDES> version is different to the
+the version on SlackBuilds.org.
+
+=cut
+
+sub get_local_outdated_versions {
+  my @outdated;
+
+  my $local = $config{LOCAL_OVERRIDES};
+  unless ( $local eq 'FALSE' ) {
+    my $pkglist = get_installed_packages('SBO');
+    my @local = grep { is_local($_->{name}) } @$pkglist;
+
+    foreach my $sbo (@local) {
+      my $orig = get_orig_version($sbo->{name});
+      next if not defined $orig;
+      next if not version_cmp($orig, $sbo->{version});
+
+      push @outdated, { %$sbo, orig => $orig };
+    }
+  }
+
+  return @outdated;
+}
+
+=head1 AUTHORS
+
+SBO::Lib was originally written by Jacob Pipkin <j@dawnrazor.net> with
+contributions from Luke Williams <xocel@iquidus.org> and Andreas
+Guldstrand <andreas.guldstrand@gmail.com>.
+
+=head1 LICENSE
+
+The sbotools are licensed under the WTFPL <http://sam.zoy.org/wtfpl/COPYING>.
+
+Copyright (C) 2012-2016, Jacob Pipkin, Luke Williams, Andreas Guldstrand.
+
+=cut
+
+1;