File Coverage

blib/lib/Sys/Info/Driver/Linux/OS/Distribution.pm

Criterion	Covered	Total	%
statement	128	191	67.0
branch	25	80	31.2
condition	10	47	21.2
subroutine	28	29	96.5
pod	9	9	100.0
total	200	356	56.1

package Sys::Info::Driver::Linux::OS::Distribution;
use strict;
use warnings;
use constant STD_RELEASE     => 'lsb-release';
use constant STD_RELEASE_DIR => 'lsb-release.d';
use constant DEBIAN_RELEASE  => 'os-release';
use constant STD_ETC_DIR     => '/etc';

use base qw( Sys::Info::Base );
use Carp qw( croak );
use Sys::Info::Driver::Linux;
use Sys::Info::Driver::Linux::Constants qw( :all );
use Sys::Info::Driver::Linux::OS::Distribution::Conf;
use File::Spec;

our $VERSION = '0.7903';

# XXX:
my $RELX = sub {
    my $master = shift;
    my $t = sub {
        my($k, $v) = @_;
    return map { $_ => $v} ref $k ? @{$k} : ($k);
    };
    map  { $t->($CONF{$_}->{$master}, $_ ) }
    grep {      $CONF{$_}->{$master}       }
    keys %CONF
};

my %ORIGINAL_RELEASE = $RELX->('release');
my %DERIVED_RELEASE  = $RELX->('release_derived');
#

sub new {
    my $class = shift;
    my %option;
    if ( @_ ) {
        die "Parameters must be in name => value format" if @_ % 2;
        %option = @_;
    }

    my $self  = {
        DISTRIB_ID          => q{},
        DISTRIB_NAME        => q{}, # workround field for new distros
        DISTRIB_RELEASE     => q{},
        DISTRIB_CODENAME    => q{},
        DISTRIB_DESCRIPTION => q{},
        release_file        => q{},
        pattern             => q{},
        PROBE               => undef,
        RESULTS             => undef,
        etc_dir             => STD_ETC_DIR,
        %option,
    };

    $self->{etc_dir} =~ s{[/]+$}{}xms;

    bless $self, $class;
    $self->_initial_probe;
    return $self;
}

sub raw_name     { return shift->{RESULTS}{raw_name} }
sub name         { return shift->{RESULTS}{name}     }
sub version      { return shift->{RESULTS}{version}  }
sub edition      { return shift->{RESULTS}{edition}  }
sub kernel       { return shift->{PROBE}{kernel}     }
sub build        { return shift->{PROBE}{build}      }
sub build_date   { return shift->{PROBE}{build_date} }
sub manufacturer {
    my $self = shift;
    my $slot = $CONF{ lc $self->raw_name } || return;
    return if ! exists $slot->{manufacturer};
    return $slot->{manufacturer};
}

sub _probe {
    my $self = shift;
    return $self->{RESULTS} if $self->{RESULTS};
    $self->{RESULTS}           = {};
    $self->{RESULTS}{name}     = $self->_probe_name;
    $self->{RESULTS}{raw_name} = $self->{RESULTS}{name};
    $self->{RESULTS}{version}  = $self->_probe_version;
    # this has to be last, since this also modifies the two above
    $self->{RESULTS}{edition}  = $self->_probe_edition;
    return $self->{RESULTS};
}

sub _probe_name {
    my $self   = shift;
    my $distro = $self->_get_lsb_info;
    return $distro if $distro;
    return $self->_probe_release( \%DERIVED_RELEASE  )
        || $self->_probe_release( \%ORIGINAL_RELEASE );
}

sub _probe_release {
    my($self, $r) = @_;

    foreach my $id ( keys %{ $r } ) {
        my $file = File::Spec->catfile( $self->{etc_dir}, $id );
        if ( -f $file && ! -l $file ) {
            $self->{DISTRIB_ID}   = $r->{ $id };
            $self->{release_file} = $id;
            return $self->{DISTRIB_ID};
        }
    }

    return;
}

sub _probe_version {
    my $self    = shift;
    my $release = $self->_get_lsb_info('DISTRIB_RELEASE');
    return $release if $release;

    if ( ! $self->{DISTRIB_ID} && ! $self->name ) {
        croak 'No version because no distribution';
    }

    my $slot         = $CONF{ lc $self->{DISTRIB_ID} };
    $self->{pattern} = exists $slot->{version_match} ? $slot->{version_match} : q{};
    $release         = $self->_get_file_info;
    $self->{DISTRIB_RELEASE} = $release;
    return $release;
}

sub _probe_edition {
    my $self = shift;
    my $p    = $self->{PROBE};

    if ( my $dn = $self->name ) {
        my $n = $self->{DISTRIB_NAME} || do {
            my $slot = $CONF{ $dn };
            exists $slot->{name} ? $slot->{name} : ucfirst $dn;
        };
        $dn  = $self->trim( $n );
        $dn .= ' Linux' if $dn !~ m{Linux}xmsi;
        $self->{RESULTS}{name} = $dn;
    }
    else {
        $self->{RESULTS}{name}    = $p->{distro};
        $self->{RESULTS}{version} = $p->{kernel};
    }

    my $name     = $self->name;
    my $raw_name = $self->raw_name;
    my $version  = $self->version;
    my $slot     = $CONF{$raw_name} || return;
    my $edition  = exists $slot->{edition} ? $slot->{edition}{ $version } : undef;

    if ( ! $edition ) {
        if ( $version && $version !~ m{[0-9]}xms ) {
            if ( $name =~ m{debian}xmsi ) {
                my @buf = split m{/}xms, $version;
                if ( my $test = $CONF{debian}->{vfix}{ lc $buf[0] } ) {
                    # Debian version comes as the edition name
                    $edition = $version;
                    $self->{RESULTS}{version} = $test;
                }
            }
        }
        else {
            if (   $slot->{use_codename_for_edition}
                && $self->{DISTRIB_CODENAME}
            ) {
                my $cn = $self->{DISTRIB_CODENAME};
                $edition = $cn if $cn !~ m{[0-9]}xms;
            }
        }
    }

    return $edition;
}

sub _initial_probe {
    my $self    = shift;
    my $version = q{};

    if (  -e proc->{version} && -f _) {
        $version =  $self->trim(
                        $self->slurp(
                            proc->{version},
                            'I can not open linux version file %s for reading: '
                        )
                    );
    }

    my($str, $build_date) = split /\#/xms, $version;
    my($kernel, $distro)  = (q{},q{});

    #$build_date = "1 Fri Jul 23 20:48:29 CDT 2004';";
    #$build_date = "1 SMP Mon Aug 16 09:25:06 EDT 2004";
    $build_date = q{} if not $build_date; # running since blah thingie

    if ( $str =~ RE_LINUX_VERSION || $str =~ RE_LINUX_VERSION2 ) {
        $kernel = $1;
        if ( $distro = $self->trim( $2 ) ) {
            if ( $distro =~ m{ \s\((.+?)\)\) \z }xms ) {
                $distro = $1;
            }
        }
    }

    $distro = 'Linux' if ! $distro || $distro =~ m{\(gcc}xms;

    # kernel build date
    $build_date = $self->date2time($build_date) if $build_date;
    my $build   = $build_date ? localtime $build_date : q{};

    $self->{PROBE} = {
        version    => $version,
        kernel     => $kernel,
        build      => $build,
        build_date => $build_date,
        distro     => $distro,
    };

    $self->_probe;
    return;
}

sub _get_lsb_info {
    my $self  = shift;
    my $field = shift || 'DISTRIB_ID';
    my $tmp   = $self->{release_file};

    my($rfile) = grep { -r $_->[1] }
                map  {
                    [ $_ => File::Spec->catfile( $self->{etc_dir}, $_ ) ]
                }
                STD_RELEASE,
                DEBIAN_RELEASE
                ;

    if ( $rfile ) {
        $self->{release_file} = $rfile->[0];
        $self->{pattern}      = $field . '=(.+)';
        my $info = $self->_get_file_info;
        return $self->{$field} = $info if $info;
    }
    else {
        # CentOS6+? RHEL? Any new distro?
        my $dir = File::Spec->catdir( $self->{etc_dir}, STD_RELEASE_DIR );
        if ( -d $dir ) {
            my $rv = join q{: },
                     map  { m{$dir/(.*)}xms ? $1 : () }
                     grep { $_ !~ m{ \A [.] }xms }
                     glob "$dir/*";
            $self->{LSB_VERSION} = $rv if $rv;
        }
        my($release) = do {
            if ( my @files = glob $self->{etc_dir} . "/*release" ) {
                my($real) = sort grep { ! -l } @files;
                my %uniq  = map { $self->trim( $self->slurp( $_ ) ) => 1 }
                            @files;
                if ( $real ) {
                    my $etc = $self->{etc_dir};
                    ($self->{release_file} = $real) =~ s{$etc/}{}xms;
                    $self->{pattern}       = '(.+)';
                }
                keys %uniq;
            }
        };

        return if ! $release; # huh?

        my($rname) = split m{\-}xms, $self->{release_file};
        my($distrib_id, @rest)  = split m{release}xms, $release, 2;
        my($version, $codename) = split m{ \s+   }xms, $self->trim( join ' ', @rest ), 2;
        $codename   =~ s{[()]}{}xmsg if $codename;
        $distrib_id = $self->trim( $distrib_id );
        $self->{DISTRIB_DESCRIPTION} = $release;
        $self->{DISTRIB_ID}          = $rname || $distrib_id;
        $self->{DISTRIB_NAME}        = $distrib_id;
        $self->{DISTRIB_RELEASE}     = $version;
        $self->{DISTRIB_CODENAME}    = $codename || q{};

        # fix stupidity
        if (   $self->{DISTRIB_ID}
            && $self->{DISTRIB_ID} eq 'redhat'
            && $self->{DISTRIB_NAME}
            && index($self->{DISTRIB_NAME}, 'CentOS') != -1
        ) {
            $self->{DISTRIB_ID} = 'centos';
        }

        return $self->{ $field } if $self->{ $field };
    }

    $self->{release_file} = $tmp;
    $self->{pattern}      = q{};
    return;
}

sub _get_file_info {
    my $self = shift;
    my $file = File::Spec->catfile( $self->{etc_dir}, $self->{release_file} );
    require IO::File;
    my $FH = IO::File->new;
    $FH->open( $file, '<' ) || croak "Can't open $file: $!";
    my @raw = <$FH>;
    $FH->close || croak "Can't close FH($file): $!";
    my $rv;
    foreach my $line ( @raw ){
        chomp $line;
        ## no critic (RequireExtendedFormatting)
        my($info) = $line =~ m/$self->{pattern}/ms;
        if ( $info ) {
            $rv = "\L$info";
            last;
        }
    }
    return $rv;
}

1;

__END__