diff --git a/modules/ksb/OSSupport.pm b/modules/ksb/OSSupport.pm index c6d9693..fb25674 100644 --- a/modules/ksb/OSSupport.pm +++ b/modules/ksb/OSSupport.pm @@ -1,158 +1,158 @@ package ksb::OSSupport 0.10; use 5.014; use strict; use warnings; use ksb::BuildException qw(croak_runtime); use Text::ParseWords qw(nested_quotewords); use List::Util qw(first); =head1 NAME ksb::OSSupport =head1 DESCRIPTION Provides support code for handling distro-specific functionality, such as lists of package dependencies, command lines to update packages in the first place, and so on. See L for the relevant specification. B This module is supposed to be loadable even under minimal Perl environments as fielded in "minimal Docker container" forms of popular distros. =head1 SYNOPSIS my $os = ksb::OSSupport->new; # Autodetects info on running system say "Current OS is: ", $os->vendorID; =cut =head1 METHODS =head2 new $os = ksb::OSSupport->new; # Manually point to os-release $os = ksb::OSSupport->new('/usr/lib/os-release'); Creates a new object. Required for other methods. =cut sub new { my ($class, $file) = @_; my $self = bless { }, $class; # $file might be undef my @kvListRef = $self->_readOSRelease($file); # Result comes in a listref which itself contains 2-elem # lists... flatten list so it can be assigned to the hash %{$self} = map { @{$_}[0,1] } @kvListRef; return $self; } =head2 vendorID my $vendor = $os->vendorID; # 'gentoo', 'debian', etc. Returns the vendor ID from the I specification. =cut sub vendorID { my $self = shift; return $self->{ID} // 'unknown'; } =head2 vendorVersion my $vendor = $os->vendorVersion; # 'xenial', '17', etc. Returns the vendor Version from the I specification. The first available value from C and then C is used, and 'unknown' is returned if neither are set. =cut sub vendorVersion { my $self = shift; return $self->{VERSION_ID} // $self->{VERSION_CODENAME} // 'unknown'; } =head2 bestDistroMatch # Might return 'fedora' if running on Scientific Linux my $distro = $os->bestDistroMatch(qw/ubuntu fedora arch debian/); This uses the ID (and if needed, ID_LIKE) parameter in /etc/os-release to find the best possible match amongst the provided distro IDs. The list of distros should be ordered with most specific distro first. If no match is found, returns 'linux' (B undef, '', or similar) =cut sub bestDistroMatch { my ($self, @distros) = @_; my @ids = $self->vendorID; if (my $likeDistros = $self->{ID_LIKE} // '') { push @ids, split(' ', $likeDistros); } foreach my $id (@ids) { return $id if first { $id eq $_ } @distros; } return 'linux'; } sub _readOSRelease { my ($self, $fileName) = @_; - my @files = $fileName ? $fileName : qw(/etc/os-release /usr/lib/os-release); + my @files = $fileName ? $fileName : qw(/etc/os-release /usr/lib/os-release /usr/local/etc/os-release); my ($fh, $error); while (!$fh && @files) { my $file = shift @files; # Can't use PerlIO UTF-8 encoding on minimal distros, which this module # must be loadable from open ($fh, '<', $file) and last; $error = $!; $fh = undef; } croak_runtime("Can't open os-release! $error") unless $fh; # skip comments and blank lines, and whitespace-only lines my @lines = grep { ! /^\s*(?:#.*)?\s*$/ } map { chomp; $_ } <$fh>; close $fh; # 0 allows discarding the delimiter and any quotes # Return should be one list per line, hopefully each list has # exactly 2 values ([$key, $value]). return nested_quotewords('=', 0, @lines); } 1;