Pkgs.pm (5525B)
1 package SBO::Lib::Pkgs; 2 3 use 5.016; 4 use strict; 5 use warnings; 6 7 our $VERSION = '2.9.0'; 8 9 use SBO::Lib::Util qw/ %config script_error open_read version_cmp /; 10 use SBO::Lib::Tree qw/ get_sbo_location get_sbo_locations is_local /; 11 use SBO::Lib::Info qw/ get_orig_version get_sbo_version /; 12 13 use Exporter 'import'; 14 15 our @EXPORT_OK = qw{ 16 get_available_updates 17 get_inst_names 18 get_installed_cpans 19 get_installed_packages 20 get_local_outdated_versions 21 }; 22 23 our %EXPORT_TAGS = ( 24 all => \@EXPORT_OK, 25 ); 26 27 =pod 28 29 =encoding UTF-8 30 31 =head1 NAME 32 33 SBO::Lib::Pkgs - Routines for interacting with the Slackware package database. 34 35 =head1 SYNOPSIS 36 37 use SBO::Lib::Pkgs qw/ get_installed_packages /; 38 39 my @installed_sbos = get_installed_packages('SBO'); 40 41 =head1 SUBROUTINES 42 43 =cut 44 45 my $pkg_db = '/var/log/packages'; 46 47 =head2 get_available_updates 48 49 my @updates = @{ get_available_updates() }; 50 51 C<get_available_updates()> compares the installed versions in 52 C</var/log/packages> that are tagged as SBo with the version available from 53 the SlackBuilds.org or C<LOCAL_OVERRIDES> repository, and returns an array 54 reference to an array of hash references which specify package names, and 55 installed and available versions. 56 57 =cut 58 59 # for each installed sbo, find out whether or not the version in the tree is 60 # newer, and compile an array of hashes containing those which are 61 sub get_available_updates { 62 my @updates; 63 my $pkg_list = get_installed_packages('SBO'); 64 65 for my $pkg (@$pkg_list) { 66 my $location = get_sbo_location($pkg->{name}); 67 next unless $location; 68 69 my $version = get_sbo_version($location); 70 if (version_cmp($version, $pkg->{version}) != 0) { 71 push @updates, { name => $pkg->{name}, installed => $pkg->{version}, update => $version }; 72 } 73 } 74 75 return \@updates; 76 } 77 78 =head2 get_inst_names 79 80 my @names = get_inst_names(get_available_updates()); 81 82 C<get_inst_names()> returns a list of package names from an array reference 83 such as the one returned by C<get_available_updates()>. 84 85 =cut 86 87 # for a ref to an array of hashes of installed packages, return an array ref 88 # consisting of just their names 89 sub get_inst_names { 90 script_error('get_inst_names requires an argument.') unless @_ == 1; 91 my $inst = shift; 92 my @installed; 93 push @installed, $$_{name} for @$inst; 94 return \@installed; 95 } 96 97 =head2 get_installed_cpans 98 99 my @cpans = @{ get_installed_cpans() }; 100 101 C<get_installed_cpans()> returns an array reference to a list of the perl 102 modules installed from the CPAN rather than from packages on SlackBuilds.org. 103 104 =cut 105 106 # return a list of perl modules installed via the CPAN 107 sub get_installed_cpans { 108 my @contents; 109 for my $file (grep { -f $_ } map { "$_/perllocal.pod" } @INC) { 110 my ($fh, $exit) = open_read($file); 111 next if $exit; 112 push @contents, grep {/Module/} <$fh>; 113 close $fh; 114 } 115 my $mod_regex = qr/C<Module>\s+L<([^\|]+)/; 116 my (@mods, @vers); 117 for my $line (@contents) { 118 push @mods, ($line =~ $mod_regex)[0]; 119 } 120 return \@mods; 121 } 122 123 =head2 get_installed_packages 124 125 my @packages = @{ get_installed_packages($type) }; 126 127 C<get_installed_packages()> returns an array reference to a list of packages in 128 C</var/log/packages> that match the specified C<$type>. The available types are 129 C<STD> for non-SBo packages, C<SBO> for SBo packages, and C<ALL> for both. 130 131 The returned array reference will hold a list of hash references representing 132 both names, versions, and full installed package name of the returned packages. 133 134 =cut 135 136 # pull an array of hashes, each hash containing the name and version of a 137 # package currently installed. Gets filtered using STD, SBO or ALL. 138 sub get_installed_packages { 139 script_error('get_installed_packages requires an argument.') unless @_ == 1; 140 my $filter = shift; 141 142 # Valid types: STD, SBO 143 my (@pkgs, %types); 144 foreach my $pkg (glob("$pkg_db/*")) { 145 $pkg =~ s!^\Q$pkg_db/\E!!; 146 my ($name, $version, $build) = $pkg =~ m#^([^/]+)-([^-]+)-[^-]+-([^-]+)$# 147 or next; 148 push @pkgs, { name => $name, version => $version, build => $build, pkg => $pkg }; 149 $types{$name} = 'STD'; 150 } 151 152 # If we want all packages, let's just return them all 153 return [ map { +{ name => $_->{name}, version => $_->{version}, pkg => $_->{pkg} } } @pkgs ] 154 if $filter eq 'ALL'; 155 156 # Otherwise, mark the SBO ones and filter 157 my @sbos = map { $_->{name} } grep { $_->{build} =~ m/_SBo(|compat32)$/ } 158 @pkgs; 159 if (@sbos) { 160 my %locations = get_sbo_locations(map { s/-compat32//gr } @sbos); 161 foreach my $sbo (@sbos) { $types{$sbo} = 'SBO' 162 if $locations{ $sbo =~ s/-compat32//gr }; } 163 } 164 return [ map { +{ name => $_->{name}, version => $_->{version}, pkg => $_->{pkg} } } 165 grep { $types{$_->{name}} eq $filter } @pkgs ]; 166 } 167 168 =head2 get_local_outdated_versions 169 170 my @outdated = get_local_outdated_versions(); 171 172 C<get_local_outdated_versions()> checks the installed SBo packages and returns 173 a list of the ones for which the C<LOCAL_OVERRIDES> version is different to the 174 the version on SlackBuilds.org. 175 176 =cut 177 178 sub get_local_outdated_versions { 179 my @outdated; 180 181 my $local = $config{LOCAL_OVERRIDES}; 182 unless ( $local eq 'FALSE' ) { 183 my $pkglist = get_installed_packages('SBO'); 184 my @local = grep { is_local($_->{name}) } @$pkglist; 185 186 foreach my $sbo (@local) { 187 my $orig = get_orig_version($sbo->{name}); 188 next if not defined $orig; 189 next if not version_cmp($orig, $sbo->{version}); 190 191 push @outdated, { %$sbo, orig => $orig }; 192 } 193 } 194 195 return @outdated; 196 } 197 198 1;