view release on metacpan or  search on metacpan

lib/App/Sys/Info.pm  view on Meta::CPAN

package App::Sys::Info;
$App::Sys::Info::VERSION = '0.26';
use strict;
use warnings;

use constant CP_UTF8      => 65_001;
use constant LAST_ELEMENT =>     -1;

use Carp                 qw( croak    );
use Format::Human::Bytes;
use POSIX                qw( locale_h );
use Text::Table          qw();
use Time::Duration       qw( duration_exact  );
use Sys::Info            qw();
use Sys::Info::Constants qw( NEW_PERL OSID );

my($NEED_CHCP, $OLDCP);

BEGIN {
    no strict qw( refs );
    foreach my $id ( qw( info os cpu fhb meta NA ) ) {
        *{ $id } = sub () { return shift->{$id} };
    }
}

END {
    _chcp( $OLDCP ) if $NEED_CHCP && $OLDCP;
}

sub _chcp {
    my $enc = shift || croak 'No encoding specified';
    system chcp => $enc, '2>nul', '1>nul';
    return;
}

sub new {
    my $class  = shift;
    my $i      = Sys::Info->new;
    my $loc    = do {
        my $rv;
        eval {
            $rv = setlocale( LC_CTYPE );
            1;
        } or do {
            my $error = $@ || 'Unknown error';
            warn "Unable to collect the locale information: $error";
            $rv = '';
        };
        $rv;
    };
    my $self   = {
        LOCALE => $loc,
        NA     => 'N/A',
        info   => $i,
        os     => $i->os,
        cpu    => $i->device('CPU'),
        fhb    => Format::Human::Bytes->new,
    };
    $self->{meta} = { $self->{os}->meta };
    bless $self, $class;
    return $self;
}

sub run {
    my $self   = __PACKAGE__->new;
    $NEED_CHCP = $self->os->is_winnt && $ENV{PROMPT};
    my @probe  = $self->probe;

    $self->_init_encoding;

    my $tb = Text::Table->new( q{}, q{} );
    $tb->load( @probe );

    print "\n", $tb or croak "Unable to orint to STDOUT: $!";
    return;
}

sub probe {
    my $self = shift;
    my @rv   = eval { $self->_probe(); };
    croak "Error fetching information: $@" if $@;
    return @rv;
}

sub _init_encoding {
    my $self = shift;
    if ( $NEED_CHCP ) {
        ## no critic (InputOutput::ProhibitBacktickOperators)
        chomp($OLDCP = (split /:\s?/xms, qx(chcp))[LAST_ELEMENT]);
        # try to change the command line encoding to unicode
        _chcp( CP_UTF8 ) if $OLDCP;
        if ( NEW_PERL ) {
            my $eok = eval q{ binmode STDOUT, ':utf8'; 1; };
        }
    }
    return;
}

sub _probe {
    my $self   = shift;
    my $meta   = $self->meta;
    my $NA     = $self->NA;
    my $i      = $self->info;
    my $os     = $self->os;
    my $pt     = $os->product_type;
    my $proc   = $self->_processors;