view release on metacpan or  search on metacpan

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

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;
    my $tz     = $os->tz;
    my $driver = 'Sys::Info::Driver::' . OSID;
    my @rv;

    push @rv,
        [ 'Sys::Info Version' =>
                sprintf(
                    '%s (%s: %s - Base: %s)',
                        Sys::Info->VERSION,
                        OSID,
                        $driver->VERSION,
                        Sys::Info::Base->VERSION,
                )
        ],
        [ 'Perl Version'      => $i->perl_long      ],
        [ 'Host Name'         => $os->host_name     ],
        [ 'OS Name'           => $self->_os_name    ],
        [ 'OS Version'        => $self->_os_version ],
    ;

    my $manu = $meta->{manufacturer};
    my $bt   = $meta->{build_type};

    push @rv, [ 'OS Manufacturer'  => $manu ] if $manu;
    push @rv, [ 'OS Configuration' => $pt   ] if $pt;
    push @rv, [ 'OS Build Type'    => $bt   ] if $bt;

    $self->_bitness(      \@rv );
    $self->_current_user( \@rv );
    $self->_registered(   \@rv, $meta );

    my $pid  = $meta->{product_id};
    my $tick = $os->tick_count;
    my $st   = $meta->{system_type};

    push @rv, [ 'Product ID'     => $pid           ] if $pid;

    $self->_install_date( \@rv );

    push @rv, [ 'System Up Time' => duration_exact($tick) ] if $tick;

    $self->_manufacturer( \@rv, $meta );

    push @rv, [ 'System Type'    => $st            ] if $st;