File Coverage

blib/lib/Sys/Info.pm

Criterion	Covered	Total	%
statement	51	74	68.9
branch	5	22	22.7
condition	2	7	28.5
subroutine	16	17	94.1
pod	5	5	100.0
total	79	125	63.2

package Sys::Info;
use strict;
use warnings;
use vars qw( $VERSION @EXPORT_OK );
use Carp qw( croak    );
use Sys::Info::Constants qw( OSID );
use base qw( Sys::Info::Base );

$VERSION = '0.78';
@EXPORT_OK = qw( OSID );

__PACKAGE__->_mk_object( $_ ) for qw( OS Device );

sub import {
    my($class, @names) = @_;
    my $caller = caller;
    my %cache  = map { $_ => 1 } @EXPORT_OK;
    no strict qw( refs );
    foreach my $name ( @names ) {
        croak "Bogus import: $name"                 if not $class->can($name);
        croak "Caller already has the $name method" if     $caller->can($name);
        croak "Access denied for $name"             if not exists $cache{$name};
        *{ $caller . q{::} . $name } = *{ $class . q{::} . $name };
    }
    return;
}

sub new {
    my $class = shift;
    my $self  = {};
    bless  $self, $class;
    return $self;
}

sub perl { return defined $^V ? sprintf( '%vd', $^V ) : _legacy_perl( $] ) }

sub perl_build {
    return 0 if OSID ne 'Windows';
    require Win32 if $] >= 5.006;
    return 0 if not defined &Win32::BuildNumber;
    return Win32::BuildNumber();
}

sub perl_long { return join q{.}, perl(), perl_build() }

sub httpd {
    my $self   = shift;
    my $server = $ENV{SERVER_SOFTWARE} || return;

    if ( $server =~ m{\A Microsoft\-IIS/ (.+?) \z}xms ) {
        return 'Microsoft Internet Information Server ' . $1;
    }

    if ( $server   =~ m{\A (Apache)/(.+?) \z}xmsi ) {
        my $apache = $1;
        my @data   = split /\s+/xms, $2;
        my $v      = shift @data;
        my @mods;
        my($mn, $mv);
        foreach my $e (@data) {
            next if $e =~ m{ \A \( .+? \) \z}xms;
            ($mn,$mv) = split m{/}xms, $e;
            $mn =~ s{ \-(.+?) \z }{}xms;
            push @mods, $mn .'(' . $mv . ')';
        }
        return "$apache $v. Modules: " . join q{ }, @mods;
    }

   return $server;
}

# ------------------------[ P R I V A T E ]------------------------ #

sub _mk_object {
    my $self  = shift;
    my $name  = shift || croak '_mk_object() needs a name';
    no strict qw(refs);
    *{ lc $name } = sub {
        shift->load_module( 'Sys::Info::' . $name )->new( @_ );
    };
    return;
}

sub _legacy_perl { # function
    my $v = shift or return;
    my($rev, $patch_sub) = split m{[.]}xms, $v;
    $patch_sub =~ s{[0_]}{}xmsg;
    my @v = split m{}xms, $patch_sub;
    return sprintf '%d.%d.%d', $rev, $v[0], $v[1] || '0';
}

1;

__END__