burak / CPAN-Sys-Info
Fetch information from the host system (Perl)
Clone this repository (size: 40.6 KB): HTTPS / SSH
$ hg clone http://bitbucket.org/burak/cpan-sys-info/
| commit 26: | 9607a0a01a2b |
| parent 25: | 3c3fca7b1d31 |
| branch: | default |
more refactoring
- View burak's profile
-
burak's public repos »
- CPAN-Padre-Plugin-HG
- CPAN-Net-Bitbucket
- CPAN-GD-SecurityImage
- CPAN-Lingua-TR-Numbers
- CPAN-Sys-Info-Driver-Windows
- CPAN-Task-Lingua-Any-Numbers
- CPAN-Time-Elapsed
- CPAN-Win32-ASP-CGI
- CPAN-Scalar-Util-Reftype
- CPAN-Parse-HTTP-UserAgent
- CPAN-Acme-CPANAuthors-Turkish
- CPAN-tools
- CPAN-Device-CableModem-Motorola-SB4200
- CPAN-Text-Template-Simple
- CPAN-CGI-Auth-Basic
- CPAN-GD-Thumbnail
- CPAN-Lingua-Any-Numbers
- CPAN-MP3-M3U-Parser
- CPAN-PHP-Session-DBI
- CPAN-Sys-Info
- CPAN-Sys-Info-Base
- CPAN-Sys-Info-Driver-BSD
- CPAN-Sys-Info-Driver-Linux
- CPAN-Sys-Info-Driver-Unknown
- CPAN-Test-Sys-Info
- Send message
4 months ago
Changed (Δ407 bytes):
raw changeset »
eg/sysinfo.pl (83 lines added, 68 lines removed)
Up to file-list eg/sysinfo.pl:
1 |
1 |
#!/usr/bin/perl -w |
2 |
package |
|
2 |
package Sysinfo; |
|
3 |
3 |
use strict; |
4 |
use warnings; |
|
4 |
5 |
use lib qw(../Sys-Info-Device-BIOS/lib); |
5 |
6 |
use vars qw( $VERSION ); |
6 |
7 |
use POSIX qw(locale_h); |
| … | … | @@ -9,6 +10,10 @@ use Sys::Info::Constants qw(NEW_PERL); |
9 |
10 |
use Time::Elapsed qw( elapsed ); |
10 |
11 |
use Number::Format; |
11 |
12 |
use Text::Table; |
13 |
use Carp qw( croak ); |
|
14 |
use constant CPUTF8 => 65_001; |
|
15 |
use constant KB => 1024; |
|
16 |
use constant LAST_ELEMENT => -1; |
|
12 |
17 |
|
13 |
18 |
$VERSION = '0.10'; |
14 |
19 |
|
| … | … | @@ -22,81 +27,40 @@ my $NA = 'N/A'; |
22 |
27 |
my $NF = Number::Format->new( THOUSANDS_SEP => q{,}, DECIMAL_POINT => q{.} ); |
23 |
28 |
my %meta = $os->meta; |
24 |
29 |
my $need_chcp = $os->is_winnt && $ENV{PROMPT}; |
30 |
my $oldcp; |
|
25 |
31 |
|
26 |
|
|
32 |
run(); |
|
27 |
33 |
|
28 |
my %bit = ( |
|
29 |
cpu => $cpu->bitness, |
|
30 |
os => $os->bitness, |
|
31 |
); |
|
32 |
map { $bit{$_} ||= '??' } keys %bit; |
|
33 |
||
34 |
@probe = eval {( |
|
35 |
[ "Sys::Info Version" => Sys::Info->VERSION ], |
|
36 |
[ "Perl Version" => $i->perl_long ], |
|
37 |
[ "Host Name" => $os->host_name ], |
|
38 |
[ "OS Name" => $os->name( long => 1, edition => 1 ) ], |
|
39 |
[ "OS Version" => $os->version . '.' . $os->build ], |
|
40 |
[ "OS Manufacturer" => $meta{'manufacturer'} || $NA ], |
|
41 |
[ "OS Configuration" => $os->product_type || $NA ], |
|
42 |
[ "OS Build Type" => $meta{'build_type'} || $NA ], |
|
43 |
[ "Running on" => "$bit{cpu}bit CPU & $bit{os}bit OS" ], |
|
44 |
[ "Registered Owner" => $meta{'owner'} || $NA ], |
|
45 |
[ "Registered Organization" => $meta{'organization'} || $NA ], |
|
46 |
[ "Product ID" => $meta{'product_id'} || $NA ], |
|
47 |
[ "Original Install Date" => scalar localtime $meta{'install_date'} ], |
|
48 |
[ "System Up Time" => $up || $NA ], |
|
49 |
[ "System Manufacturer" => $meta{'system_manufacturer'} || $NA ], |
|
50 |
[ "System Model" => $meta{'system_model'} || $NA ], |
|
51 |
[ "System Type" => $meta{'system_type'} || $NA ], |
|
52 |
[ "Processor(s)" => processors() || $NA ], |
|
53 |
[ "BIOS Version" => $i->device('bios')->version || $NA ], |
|
54 |
[ "Windows Directory" => $meta{windows_dir} || $NA ], |
|
55 |
[ "System Directory" => $meta{system_dir} || $NA ], |
|
56 |
[ "Boot Device" => $meta{'boot_device'} || $NA ], |
|
57 |
[ "System Locale" => $LOCALE || $NA ], |
|
58 |
[ "Input Locale" => $LOCALE || $NA ], |
|
59 |
[ "Time Zone" => $os->tz || $NA ], |
|
60 |
[ "Total Physical Memory" => mb($meta{'physical_memory_total'} ) ], |
|
61 |
[ "Available Physical Memory" => mb($meta{'physical_memory_available'}) ], |
|
62 |
[ "Virtual Memory: Max Size" => mb($meta{'page_file_total'} ) ], |
|
63 |
[ "Virtual Memory: Available" => mb($meta{'page_file_available'} ) ], |
|
64 |
[ "Virtual Memory: In Use" => vm() ], |
|
65 |
[ "Page File Location(s)" => $meta{page_file_path} || $NA ], |
|
66 |
[ "Domain" => $os->domain_name || $NA ], |
|
67 |
[ "Logon Server" => $os->logon_server || $NA ], |
|
68 |
||
69 |
[ "Windows CD Key" => $os->cdkey || $NA ], |
|
70 |
[ "Microsoft Office CD Key" => ($os->cdkey( office => 1 ))[0] || $NA ], |
|
71 |
)}; |
|
72 |
||
73 |
die "Error fetching information: $@" if $@; |
|
74 |
||
75 |
my $oldcp; |
|
76 |
if ( $need_chcp ) { |
|
77 |
chomp($oldcp = (split /:\s?/, qx(chcp))[-1]); |
|
78 |
system(chcp => 65001, '2>nul', '1>nul') if $oldcp; # try to change it to unicode |
|
79 |
eval q{ binmode STDOUT, ':utf8' } if NEW_PERL; |
|
34 |
END { |
|
35 |
system chcp => $oldcp, '2>nul', '1>nul' if $need_chcp && $oldcp; |
|
80 |
36 |
} |
81 |
37 |
|
82 |
END { |
|
83 |
system(chcp => $oldcp, '2>nul', '1>nul') if $need_chcp && $oldcp; |
|
38 |
sub run { |
|
39 |
my @probe = probe(); |
|
40 |
||
41 |
if ( $need_chcp ) { |
|
42 |
## no critic (InputOutput::ProhibitBacktickOperators) |
|
43 |
chomp($oldcp = (split /:\s?/xms, qx(chcp))[LAST_ELEMENT]); |
|
44 |
system chcp => CPUTF8, '2>nul', '1>nul' if $oldcp; # try to change it to unicode |
|
45 |
if ( NEW_PERL ) { |
|
46 |
my $eok = eval q{ binmode STDOUT, ':utf8'; 1; }; |
|
47 |
} |
|
48 |
} |
|
49 |
my @titles = ( "FIELD\n=====", "VALUE\n====="); |
|
50 |
@titles = ( q{}, q{}); |
|
51 |
||
52 |
my $tb = Text::Table->new( @titles ); |
|
53 |
$tb->load( @probe ); |
|
54 |
print "\n", $tb or croak "Unable to orint to STDOUT: $!"; |
|
55 |
return; |
|
84 |
56 |
} |
85 |
57 |
|
86 |
my @titles = ( "FIELD\n=====", "VALUE\n====="); |
|
87 |
@titles = ( "", ""); |
|
88 |
||
89 |
my $tb = Text::Table->new( @titles ); |
|
90 |
$tb->load( @probe ); |
|
91 |
print "\n"; |
|
92 |
print $tb; |
|
93 |
||
94 |
58 |
sub processors { |
95 |
my $rv = sprintf |
|
59 |
my $rv = sprintf '%s ~%sMHz', |
|
96 |
60 |
scalar($cpu->identify), |
97 |
61 |
$cpu->speed; |
98 |
$rv =~ s{\s+}{ }sg; |
|
99 |
$rv; |
|
62 |
$rv =~ s{\s+}{ }xmsg; |
|
63 |
return $rv; |
|
100 |
64 |
} |
101 |
65 |
|
102 |
66 |
sub vm { |
| … | … | @@ -107,10 +71,61 @@ sub vm { |
107 |
71 |
|
108 |
72 |
sub mb { |
109 |
73 |
my $kb = shift || return $NA; |
110 |
my $int = sprintf '%.0f', $kb / |
|
74 |
my $int = sprintf '%.0f', $kb / KB; |
|
111 |
75 |
return sprintf '%s MB', $NF->format_number( $int ); |
112 |
76 |
} |
113 |
77 |
|
78 |
sub probe { |
|
79 |
my %bit = ( |
|
80 |
cpu => $cpu->bitness, |
|
81 |
os => $os->bitness, |
|
82 |
); |
|
83 |
$bit{$_} ||= q{??} for keys %bit; |
|
84 |
||
85 |
my @rv = eval {( |
|
86 |
[ 'Sys::Info Version' => Sys::Info->VERSION ], |
|
87 |
[ 'Perl Version' => $i->perl_long ], |
|
88 |
[ 'Host Name' => $os->host_name ], |
|
89 |
[ 'OS Name' => $os->name( long => 1, edition => 1 ) ], |
|
90 |
[ 'OS Version' => $os->version . q{.} . $os->build ], |
|
91 |
[ 'OS Manufacturer' => $meta{'manufacturer'} || $NA ], |
|
92 |
[ 'OS Configuration' => $os->product_type || $NA ], |
|
93 |
[ 'OS Build Type' => $meta{'build_type'} || $NA ], |
|
94 |
[ 'Running on' => "$bit{cpu}bit CPU & $bit{os}bit OS" ], |
|
95 |
[ 'Registered Owner' => $meta{'owner'} || $NA ], |
|
96 |
[ 'Registered Organization' => $meta{'organization'} || $NA ], |
|
97 |
[ 'Product ID' => $meta{'product_id'} || $NA ], |
|
98 |
[ 'Original Install Date' => scalar localtime $meta{'install_date'} ], |
|
99 |
[ 'System Up Time' => $up || $NA ], |
|
100 |
[ 'System Manufacturer' => $meta{'system_manufacturer'} || $NA ], |
|
101 |
[ 'System Model' => $meta{'system_model'} || $NA ], |
|
102 |
[ 'System Type' => $meta{'system_type'} || $NA ], |
|
103 |
[ 'Processor(s)' => processors() || $NA ], |
|
104 |
[ 'BIOS Version' => $i->device('bios')->version || $NA ], |
|
105 |
[ 'Windows Directory' => $meta{windows_dir} || $NA ], |
|
106 |
[ 'System Directory' => $meta{system_dir} || $NA ], |
|
107 |
[ 'Boot Device' => $meta{'boot_device'} || $NA ], |
|
108 |
[ 'System Locale' => $LOCALE || $NA ], |
|
109 |
[ 'Input Locale' => $LOCALE || $NA ], |
|
110 |
[ 'Time Zone' => $os->tz || $NA ], |
|
111 |
[ 'Total Physical Memory' => mb($meta{'physical_memory_total'} ) ], |
|
112 |
[ 'Available Physical Memory' => mb($meta{'physical_memory_available'}) ], |
|
113 |
[ 'Virtual Memory: Max Size' => mb($meta{'page_file_total'} ) ], |
|
114 |
[ 'Virtual Memory: Available' => mb($meta{'page_file_available'} ) ], |
|
115 |
[ 'Virtual Memory: In Use' => vm() ], |
|
116 |
[ 'Page File Location(s)' => $meta{page_file_path} || $NA ], |
|
117 |
[ 'Domain' => $os->domain_name || $NA ], |
|
118 |
[ 'Logon Server' => $os->logon_server || $NA ], |
|
119 |
||
120 |
[ 'Windows CD Key' => $os->cdkey || $NA ], |
|
121 |
[ 'Microsoft Office CD Key' => ($os->cdkey( office => 1 ))[0] || $NA ], |
|
122 |
)}; |
|
123 |
||
124 |
croak "Error fetching information: $@" if $@; |
|
125 |
return @rv; |
|
126 |
} |
|
127 |
||
128 |
1; |
|
114 |
129 |
|
115 |
130 |
__END__ |
116 |
131 |