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


line stmt bran cond sub pod time code
1             package Sys::Info;
2 1     1   679 use strict;
  1         2  
  1         35  
3 1     1   6 use warnings;
  1         1  
  1         118  
4 1     1   6 use vars qw( $VERSION @EXPORT_OK );
  1         6  
  1         83  
5 1     1   6 use Carp qw( croak );
  1         2  
  1         71  
6 1     1   1124 use Sys::Info::Constants qw( OSID );
  1         2020  
  1         75  
7 1     1   7 use base qw( Sys::Info::Base );
  1         1  
  1         987  
8              
9             $VERSION = '0.78';
10             @EXPORT_OK = qw( OSID );
11              
12             __PACKAGE__->_mk_object( $_ ) for qw( OS Device );
13              
14             sub import {
15 1     1   7 my($class, @names) = @_;
16 1         4 my $caller = caller;
17 1         3 my %cache = map { $_ => 1 } @EXPORT_OK;
  1         5  
18 1     1   18883 no strict qw( refs );
  1         3  
  1         701  
19 1         2 foreach my $name ( @names ) {
20 1 50       14 croak "Bogus import: $name" if not $class->can($name);
21 1 50       20 croak "Caller already has the $name method" if $caller->can($name);
22 1 50       4 croak "Access denied for $name" if not exists $cache{$name};
23 1         2 *{ $caller . q{::} . $name } = *{ $class . q{::} . $name };
  1         4  
  1         3  
24             }
25 1         25 return;
26             }
27              
28             sub new {
29 1     1 1 655 my $class = shift;
30 1         3 my $self = {};
31 1         3 bless $self, $class;
32 1         5 return $self;
33             }
34              
35 2 50   2 1 70821 sub perl { return defined $^V ? sprintf( '%vd', $^V ) : _legacy_perl( $] ) }
36              
37             sub perl_build {
38 2 50   2 1 11 return 0 if OSID ne 'Windows';
39 0 0       0 require Win32 if $] >= 5.006;
40 0 0       0 return 0 if not defined &Win32::BuildNumber;
41 0         0 return Win32::BuildNumber();
42             }
43              
44 1     1 1 5 sub perl_long { return join q{.}, perl(), perl_build() }
45              
46             sub httpd {
47 1     1 1 3 my $self = shift;
48 1   50     7 my $server = $ENV{SERVER_SOFTWARE} || return;
49              
50 0 0       0 if ( $server =~ m{\A Microsoft\-IIS/ (.+?) \z}xms ) {
51 0         0 return 'Microsoft Internet Information Server ' . $1;
52             }
53              
54 0 0       0 if ( $server =~ m{\A (Apache)/(.+?) \z}xmsi ) {
55 0         0 my $apache = $1;
56 0         0 my @data = split /\s+/xms, $2;
57 0         0 my $v = shift @data;
58 0         0 my @mods;
59 0         0 my($mn, $mv);
60 0         0 foreach my $e (@data) {
61 0 0       0 next if $e =~ m{ \A \( .+? \) \z}xms;
62 0         0 ($mn,$mv) = split m{/}xms, $e;
63 0         0 $mn =~ s{ \-(.+?) \z }{}xms;
64 0         0 push @mods, $mn .'(' . $mv . ')';
65             }
66 0         0 return "$apache $v. Modules: " . join q{ }, @mods;
67             }
68              
69 0         0 return $server;
70             }
71              
72             # ------------------------[ P R I V A T E ]------------------------ #
73              
74             sub _mk_object {
75 2     2   4 my $self = shift;
76 2   33     8 my $name = shift || croak '_mk_object() needs a name';
77 1     1   8 no strict qw(refs);
  1         2  
  1         226  
78 2         16 *{ lc $name } = sub {
79 2     2   31430 shift->load_module( 'Sys::Info::' . $name )->new( @_ );
80 2         8 };
81 2         7 return;
82             }
83              
84             sub _legacy_perl { # function
85 0 0   0     my $v = shift or return;
86 0           my($rev, $patch_sub) = split m{[.]}xms, $v;
87 0           $patch_sub =~ s{[0_]}{}xmsg;
88 0           my @v = split m{}xms, $patch_sub;
89 0   0       return sprintf '%d.%d.%d', $rev, $v[0], $v[1] || '0';
90             }
91              
92             1;
93              
94             __END__