lib/Test/Smoke/SysInfo/Linux.pm

package Test::Smoke::SysInfo::Linux;
use warnings;
use strict;

use base 'Test::Smoke::SysInfo::Base';

=head1 NAME

Test::Smoke::SysInfo::Linux - Object for specific Linux info.

=head1 DESCRIPTION

=head2 $si->prepare_sysinfo()

Use os-specific tools to find out more about the system.

=cut

sub prepare_sysinfo {
    my $self = shift;
    $self->SUPER::prepare_sysinfo();
    $self->prepare_os();
    return if !$self->prepare_proc_cpuinfo();

    for ($self->get_cpu_type()) {
        /arm/   && do {$self->linux_arm(); last};
        /ppc/   && do {$self->linux_ppc(); last};
        /sparc/ && do {$self->linux_sparc(); last};
        # default
        $self->linux_generic();
    }
    return $self;
}

=head2 $si->prepare_os()

Use os-specific tools to find out more about the operating system.

=cut

sub _file_info {
    my ($file, $os) = @_;
    open(my $fh, "< $file") or return;
    while (<$fh>) {
        m/^\s*[;#]/ and next;
        chomp;
        m/\S/ or next;
        s/^\s+//;
        s/\s+$//;
        if (my ($k, $v) = (m/^(.*\S)\s*=\s*(\S.*)$/)) {
            # Having a value prevails over being defined
            defined $os->{$k} and next;
            $v =~ s/^"\s*(.*?)\s*"$/$1/;
            $os->{$k} = $v;
            next;
        }
        exists $os->{$_} or $os->{$_} = undef;
    }
    close $fh;
}

sub prepare_os {
    my $self = shift;

    my $etc = $ENV{SMOKE_USE_ETC} || "/etc";
    my @dist_file = grep { -f $_ && -s _ } map {
        -d $_ ? glob("$_/*") : ($_)
    } glob("$etc/*[-_][rRvV][eE][lLrR]*"), "$etc/issue",
           "$etc.defaults/VERSION", "$etc/VERSION", "$etc/release";
    return unless @dist_file;

    my $os = $self->_os();
    my %os;
    my $distro;
    foreach my $df (@dist_file) {
        # use "debian" out of /etc/debian-release
        unless (defined $distro or $df =~ m/\blsb-/) {
            ($distro = $df) =~ s{^$etc(?:\.defaults)?/}{}i;
            $distro =~ s{[-_]?(?:release|version)\b}{}i;
        }
        _file_info ($df, \%os);
    }
    foreach my $key (keys %os) {
        my $KEY = uc $key;
        defined $os{$key} or next;
        exists $os{$KEY} or $os{$KEY} = $os{$key};
    }

    if ( $os{DISTRIB_DESCRIPTION} ) {
        $distro = $os{DISTRIB_DESCRIPTION};
        $os{DISTRIB_CODENAME} && $distro !~ m{\b$os{DISTRIB_CODENAME}\b} and
            $distro .= " ($os{DISTRIB_CODENAME})";
    }
    elsif ( $os{PRETTY_NAME} ) {
        $distro = $os{PRETTY_NAME};          # "openSUSE 12.1 (Asparagus) (x86_64)"
        if (my $vid = $os{VERSION_ID}) {     # wheezy 7 => 7.2
            my @rv;
            if (@rv = grep m{^$vid\.} => sort keys %os) {
                # from /etc/debian_version
                $rv[0] =~ m/^[0-9]+\.\w+$/ and
                    $distro =~ s/\b$vid\b/$rv[0]/;
            }
            if (!@rv && defined $os{NAME} and # CentOS Linux 7 = CentOS Linux 7.1.1503
		 @rv = grep m{^$os{NAME} (?:(?:release|version)\s+)?$vid\.} => sort keys %os) {
		if ($rv[0] =~ m/\s($vid\.[-.\w]+)/) {
		    my $vr = $1;
		    $distro =~ s/\s$vid\b/ $vr/;
		}
	    }
        }
        $distro =~ s/\)\s+\(\w+\)\s*$/)/;    # remove architectural part
        $distro =~ s/\s+\(?(?:i\d86|x86_64)\)?\s*$//; # i386 i486 i586 x86_64
    }
    elsif ( $os{VERSION} && $os{NAME} ) {
        $distro = qq{$os{NAME} $os{VERSION}};
    }
    elsif ( $os{VERSION} && $os{CODENAME} ) {
        if ( my @welcome = grep s{^\s*Welcome\s+to\s+(\S*$distro\S*)\b.*}{$1}i => keys %os ) {
            $distro = $welcome[0];
        }
	$distro .= qq{ $os{VERSION}};
        $distro =~ m/\b$os{CODENAME}\b/ or
	    $distro .= qq{ ($os{CODENAME})};
    }
    elsif ( $os{MAJORVERSION} && defined $os{MINORVERSION} ) {
        -d "/usr/syno" || "@dist_file" =~ m{^\S*/VERSION$} and $distro .= "DSM";
        $distro .= qq{ $os{MAJORVERSION}.$os{MINORVERSION}};
        $os{BUILDNUMBER}    and $distro .= qq{-$os{BUILDNUMBER}};
        $os{SMALLFIXNUMBER} and $distro .= qq{-$os{SMALLFIXNUMBER}};
    }
    elsif ( $os{DISTRIBVER} && exists $os{NETBSDSRCDIR} ) {
        (my $dv = $os{DISTRIBVER}) =~ tr{ ''"";}{}d;
        $distro .= qq{ NetBSD $dv};
    }
    else {
        # /etc/issue:
        #  Welcome to SUSE LINUX 10.0 (i586) - Kernel \r (\l).
        #  Welcome to openSUSE 10.2 (i586) - Kernel \r (\l).
        #  Welcome to openSUSE 10.2 (X86-64) - Kernel \r (\l).
        #  Welcome to openSUSE 10.3 (i586) - Kernel \r (\l).
        #  Welcome to openSUSE 10.3 (X86-64) - Kernel \r (\l).
        #  Welcome to openSUSE 11.1 - Kernel \r (\l).
        #  Welcome to openSUSE 11.2 "Emerald" - Kernel \r (\l).
        #  Welcome to openSUSE 11.3 "Teal" - Kernel \r (\l).
        #  Welcome to openSUSE 11.4 "Celadon" - Kernel \r (\l).
        #  Welcome to openSUSE 12.1 "Asparagus" - Kernel \r (\l).
        #  Welcome to openSUSE 12.2 "Mantis" - Kernel \r (\l).
        #  Welcome to openSUSE 12.3 "Dartmouth" - Kernel \r (\l).
        #  Welcome to openSUSE 13.1 "Bottle" - Kernel \r (\l).
        #  Welcome to openSUSE 13.2 "Harlequin" - Kernel \r (\l).
        #  Welcome to openSUSE Leap 42.1 - Kernel \r (\l).
        #  Welcome to openSUSE 20151218 "Tumbleweed" - Kernel \r (\l).
        #  Welcome to SUSE Linux Enterprise Server 11 SP1 for VMware  (x86_64) - Kernel \r (\l).
        #  Ubuntu 10.04.4 LTS \n \l
        #  Debian GNU/Linux wheezy/sid \n \l
        #  Debian GNU/Linux 6.0 \n \l
        #  CentOS release 6.4 (Final)
        # /etc/redhat-release:
        #  CentOS release 5.7 (Final)
        #  CentOS release 6.4 (Final)
        #  Red Hat Enterprise Linux ES release 4 (Nahant Update 2)
        # /etc/debian_version:
        #  6.0.4
        #  wheezy/sid
        #  squeeze/sid

        my @key = sort keys %os;
        s/\s*\\[rln].*// for @key;

        my @vsn = grep m/^[0-9.]+$/ => @key;
        #$self->{__X__} = { os => \%os, key => \@key, vsn => \@vsn };

        if ( my @welcome = grep s{^\s*Welcome\s+to\s+}{}i => @key ) {
            ($distro = $welcome[0]) =~ s/"([^"]+)"/($1)/;
        }
        elsif ( my @rel  = grep m{\brelease\b}i => @key ) {
            @rel > 1 && $rel[0] =~ m/^Enterprise Linux Enterprise/
                     && $rel[1] =~ m/^Oracle Linux/ and shift @rel;
            $distro = $rel[0];
            $distro =~ s/ *release//;
            $distro =~ s/Red Hat Enterprise Linux/RHEL/; # Too long for subject
            # RHEL ES 4 (Nahant Update 2) => RHEL Server 4.2 (Nahant)
            $distro =~ s/^RHEL ES (\d+)\s+(.*)\s+Update\s+(\d+)/RHEL Server $1.$3 $2/;
        }
        elsif ( my @lnx  = grep m{\bLinux\b}i => @key ) {
            $distro = $lnx[0];
        }
        elsif ( $distro && @vsn ) {
            $distro .= "-$vsn[0]";
        }
        else {
            $distro = $key[0];
        }
        $distro =~ s/\s+-\s+Kernel.*//i;
    }
    if ($distro =~ s/^\s*(.*\S)\s*$/$1/) {
        $self->{__distro} = $distro;
        $os .= " [$distro]";
    }
    $self->{__os} = $os;
}

=head2 $si->linux_generic

Check C</proc/cpuinfo> for these keys:

=over

=item 'processor'  (count occurrence for __cpu_count)

=item 'model name' (part of __cpu)

=item 'vendor_id'  (part of __cpu)

=item 'cpu mhz'    (part of __cpu)

=item 'cpu cores'  (add values to add to __cpu_count)

=back

=cut

sub linux_generic {
    my $self = shift;

    $self->{__cpu_count} = $self->count_in_cpuinfo(qr/^processor\s+:\s+/);

    my @parts = ( 'model name', 'vendor_id', 'cpu mhz' );
    my %info = map {
        ( $_ => $self->from_cpuinfo($_) );
    } @parts;
    $self->{__cpu} = sprintf "%s (%s %.0fMHz)", map $info{$_} => @parts;

    my $ncores = 0;
    for my $cores ( grep /cpu cores\s*:\s*\d+/ => $self->_proc_cpuinfo ) {
        $ncores += $cores =~ /(\d+)/ ? $1 : 0;
    }
    $self->{__cpu_count} .= " [$ncores cores]" if $ncores;

}

=head2 $si->linux_arm

Check C</proc/cpuinfo> for these keys:

=over

=item 'processor'  (count occurrence for __cpu_count)

=item 'Processor' (part of __cpu)

=item 'BogoMIPS'  (part of __cpu)

=back

=cut

sub linux_arm {
    my $self = shift;

    $self->{__cpu_count} = $self->count_in_cpuinfo(qr/^processor\s+:\s+/i);

    my $cpu = $self->from_cpuinfo('Processor');
    my $bogo = $self->from_cpuinfo('BogoMIPS');
    my $mhz  = 100 * int(($bogo + 50)/100);
    $cpu =~ s/\s+/ /g;
    $cpu .= " ($mhz MHz)" if $mhz;
    $self->{__cpu} = $cpu;
}

=head2 $si->linux_ppc

Check C</proc/cpuinfo> for these keys:

=over

=item 'processor'  (count occurrence for __cpu_count)

=item 'cpu'     (part of __cpu)

=item 'machine' (part of __cpu)

=item 'clock'   (part of __cpu)

=item 'detected' (alters machine if present)

=back

=cut

sub linux_ppc {
    my $self = shift;

    $self->{__cpu_count} = $self->count_in_cpuinfo(qr/^processor\s+:\s+/);

    my @parts = qw( cpu machine clock );
    my %info = map {
        ( $_ => $self->from_cpuinfo($_) );
    } @parts;
    if ($info{detected} = $self->from_cpuinfo('detected as')){
        $info{detected} =~ s/.*(\b.+Mac G\d).*/$1/;
        $info{machine} = $info{detected};
    }

    $self->{__cpu} = sprintf "%s %s (%s)", map $info{ $_ } => @parts;
}

=head2 $si->linux_sparc

Check C</proc/cpuinfo> for these keys:

=over

=item 'processor'  (count occurrence for __cpu_count)

=item 'cpu'        (part of __cpu)

=item 'Cpu0ClkTck' (part of __cpu)

=back

=cut

sub linux_sparc {
    my $self = shift;

    $self->{__cpu_count} = $self->from_cpuinfo('ncpus active');

    my @parts = qw( cpu Cpu0ClkTck );
    my %info = map {
        ( $_ => $self->from_cpuinfo($_) );
    } @parts;
    my $cpu = $info{cpu};
    if ($info{Cpu0ClkTck}) {
        $cpu .=  sprintf " (%.0fMHz)", hex( $info{Cpu0ClkTck} )/1_000_000;
    }
    $self->{__cpu} = $cpu;
}

=head2 $si->prepare_proc_cpuinfo

Read the complete C<< /proc/cpuinfo >>.

=cut

sub prepare_proc_cpuinfo {
    my $self = shift;

    if (open my $pci, "< /proc/cpuinfo") {
        chomp($self->{__proc_cpuinfo} = [<$pci>]);
        close $pci;
        return 1;
    }
}

=head2 $si->count_in_cpuinfo($regex)

Returns the number of lines $regex matches for.

=cut

sub count_in_cpuinfo {
    my $self = shift;
    my ($regex) = @_;

    return scalar grep /$regex/, $self->_proc_cpuinfo();
}

=head2 $si->from_cpuinfo($key)

Returns the first value of that key in C<< /proc/cpuinfo >>.

=cut

sub from_cpuinfo {
    my $self = shift;
    my ($key) = @_;

    my ($first) = grep /^\s*$key\s*[:=]\s*/i => $self->_proc_cpuinfo();
    defined $first or $first = "";
    $first =~ s/^\s*$key\s*[:=]\s*//i;
    $first =~ s/\s+/ /g;
    $first =~ s/\s+$//;
    return $first;
}

1;

=head1 COPYRIGHT

(c) 2002-2013, Abe Timmerman <abeltje@cpan.org> All rights reserved.

With contributions from Jarkko Hietaniemi, Merijn Brand, Campo
Weijerman, Alan Burlison, Allen Smith, Alain Barbet, Dominic Dunlop,
Rich Rauenzahn, David Cantrell.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

See:

=over 4

=item * L<http://www.perl.com/perl/misc/Artistic.html>

=item * L<http://www.gnu.org/copyleft/gpl.html>

=back

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)