File Coverage

blib/lib/Win32/SystemInfo.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Win32::SystemInfo;

require 5.8.0;
use strict;
use warnings;
use Win32::API 0.60;
use Win32::TieRegistry qw(:KEY_);

use vars qw($VERSION);

$VERSION = '0.12';

# Not sure how useful these are anymore -
# may get rid of them soon.
use constant PROCESSOR_ARCHITECTURE_INTEL   => 0;
use constant PROCESSOR_ARCHITECTURE_MIPS    => 1;
use constant PROCESSOR_ARCHITECTURE_ALPHA   => 2;
use constant PROCESSOR_ARCHITECTURE_PPC     => 3;
use constant PROCESSOR_ARCHITECTURE_AMD64   => 9;
use constant PROCESSOR_ARCHITECTURE_UNKNOWN => 0xFFFF;

my %Procedures = ();
my %Types      = ();
my %Structs    = ();

#===========================
my $check_OS = sub ()    # Attempt to make this as private as possible
{
	my $dwPlatformId;
	my $osType;

	if ( !defined( $Types{'OSVERSIONINFO'} ) ) {
		# (See GetVersionEx on MSDN)
		Win32::API::Struct->typedef(
			OSVERSIONINFO => qw{
			  DWORD dwOSVersionInfoSize;
			  DWORD dwMajorVersion;
			  DWORD dwMinorVersion;
			  DWORD dwBuildNumber;
			  DWORD dwPlatformID;
			  TCHAR szCSDVersion[128];
			  }
		);
		$Types{'OSVERSIONINFO'} = 1;
	}

	if ( !defined( $Procedures{'GetVersionEx'} ) ) {
		Win32::API->Import( 'kernel32',
			'BOOL GetVersionEx(LPOSVERSIONINFO lpOSVersionInfo)' )
		  or die
		  "Could not locate kernel32.dll - SystemInfo.pm cannot continue\n";
		$Procedures{'GetVersionEx'} = 1;
	}

	my $OSVERSIONINFO;
	if ( !defined( $Structs{'OSVERSIONINFO'} ) ) {
		$OSVERSIONINFO = Win32::API::Struct->new('OSVERSIONINFO');
		$Structs{'OSVERSIONINFO'} = $OSVERSIONINFO;
	}
	else {
		$OSVERSIONINFO = $Structs{'OSVERSIONINFO'};
	}

	{
		# Ignore Win32::API warnings. It's ugly, but what are you gonna do?
		local $SIG{__WARN__} = sub { };
		$OSVERSIONINFO->{'dwMajorVersion'}      = 0;
		$OSVERSIONINFO->{'dwMinorVersion'}      = 0;
		$OSVERSIONINFO->{'dwBuildNumber'}       = 0;
		$OSVERSIONINFO->{'dwPlatformID'}        = 0;
		$OSVERSIONINFO->{'szCSDVersion'}        = "" x 128;
		$OSVERSIONINFO->{'dwOSVersionInfoSize'} =
			$OSVERSIONINFO->sizeof();

		GetVersionEx($OSVERSIONINFO) or return undef;

		$dwPlatformId = $OSVERSIONINFO->{dwPlatformID};
		if ( $dwPlatformId == 2 ) {
			my $majorVersion = $OSVERSIONINFO->{dwMajorVersion};
			if ( $majorVersion == 4 ) {
				$osType = "WinNT";
			}
			else {
				$osType = "Win2K";
			}
		}
		elsif ( $dwPlatformId == 1 ) { $osType = "Win9x"; }

		return ( $osType ne "" ) ? $osType : undef;
	}
};
#==================

#==================
my $canUse64Bit = sub () {    # Another private sub - see if we can do 64 bit
	eval { my $foo = pack( "Q", 1234 ) };
	return ($@) ? 0 : 1;
};
#==================

#==================
sub MemoryStatus (\%;$) {
	my $return = shift;       #hash to return
	my $ret_type ||= shift || "B";    #what format does the user want?
	my %fmt_types =
	  ( B => 1, KB => 1024, MB => 1024 * 1024, GB => 1024 * 1024 * 1024 );
	my @params = qw(MemLoad TotalPhys AvailPhys TotalPage
	  AvailPage TotalVirtual AvailVirtual);
	my %results;                      #results of fn call
	my $MemFormat;                    #divisor for format
	my $dwMSLength;                   #validator from fn call

	$MemFormat =
	  ( $ret_type =~ /^[BKMG]B?$/ ) ? $fmt_types{$ret_type} : $fmt_types{B};

	# Determine operating system
	return undef unless my $OS = &$check_OS;

	my $use64Bit = &$canUse64Bit;

	if ( ( $OS eq "Win2K" ) && ($use64Bit) ) {
		if ( !defined( $Types{'MEMORYSTATUSEX'} ) ) {

			# (See GlobalMemoryStatusEx on MSDN)
			Win32::API::Struct->typedef(
				MEMORYSTATUSEX => qw{
				  DWORD dwLength;
				  DWORD MemLoad;
				  ULONGLONG TotalPhys;
				  ULONGLONG AvailPhys;
				  ULONGLONG TotalPage;
				  ULONGLONG AvailPage;
				  ULONGLONG TotalVirtual;
				  ULONGLONG AvailVirtual;
				  ULONGLONG AvailExtendedVirtual;
				  }
			);
			$Types{'MEMORYSTATUSEX'} = 1;
		}

		if ( !defined( $Procedures{'GlobalMemoryStatusEx'} ) ) {
			Win32::API->Import( 'kernel32',
				'BOOL GlobalMemoryStatusEx(LPMEMORYSTATUSEX lpMemoryStatusEx)' )
			  or die
			  "Could not locate kernel32.dll - SystemInfo.pm cannot continue\n";
			$Procedures{'GlobalMemoryStatusEx'} = 1;
		}

		my $MEMORYSTATUSEX;
		if ( !defined( $Structs{'MEMORYSTATUSEX'} ) ) {
			$MEMORYSTATUSEX = Win32::API::Struct->new('MEMORYSTATUSEX');
		}
		else {
			$MEMORYSTATUSEX = $Structs{'MEMORYSTATUSEX'};
		}
		$MEMORYSTATUSEX->{dwLength} = $MEMORYSTATUSEX->sizeof();
		$MEMORYSTATUSEX->{MemLoad} = 0;
		$MEMORYSTATUSEX->{TotalPhys} = 0;
		$MEMORYSTATUSEX->{AvailPhys} = 0;
		$MEMORYSTATUSEX->{TotalPage} = 0;
		$MEMORYSTATUSEX->{AvailPage} = 0;
		$MEMORYSTATUSEX->{TotalVirtual} = 0;
		$MEMORYSTATUSEX->{AvailVirtual} = 0;
		$MEMORYSTATUSEX->{AvailExtendedVirtual} = 0;

		GlobalMemoryStatusEx($MEMORYSTATUSEX);

		if ( keys(%$return) == 0 ) {
			foreach (@params) {
				$return->{$_} =
				  ( $_ eq "MemLoad" )
				  ? $MEMORYSTATUSEX->{$_}
				  : $MEMORYSTATUSEX->{$_} / $MemFormat;
			}
		}
		else {
			foreach (@params) {
				$return->{$_} = $MEMORYSTATUSEX->{$_} / $MemFormat
				  unless ( !defined( $return->{$_} ) );
			}
		}
	}
	else {

		if ( !defined( $Types{'MEMORYSTATUS'} ) ) {

			# (See GlobalMemoryStatus on MSDN)
			# I had to change some of the types to get the struct to
			# play nicely with Win32::API. The SIZE_T's are actually
			# DWORDS in previous versions of the Win32 API, so this
			# change doesn't hurt anything.
			# The names of the members in the struct are different than
			# in the API to make my life easier, and to keep the same
			# return values this method has always had.
			Win32::API::Struct->typedef(
				MEMORYSTATUS => qw{
				  DWORD dwLength;
				  DWORD MemLoad;
				  DWORD TotalPhys;
				  DWORD AvailPhys;
				  DWORD TotalPage;
				  DWORD AvailPage;
				  DWORD TotalVirtual;
				  DWORD AvailVirtual;
				  }
			);
			$Types{'MEMORYSTATUS'} = 1;
		}

		if ( !defined( $Procedures{'GlobalMemoryStatus'} ) ) {
			Win32::API->Import( 'kernel32',
				'VOID GlobalMemoryStatus(LPMEMORYSTATUS lpMemoryStatus)' )
			  or die
			  "Could not locate kernel32.dll - SystemInfo.pm cannot continue\n";
			$Procedures{'GlobalMemoryStatus'} = 1;
		}

		my $MEMORYSTATUS;
		if ( !defined( $Structs{'MEMORYSTATUS'} ) ) {
			$MEMORYSTATUS = Win32::API::Struct->new('MEMORYSTATUS');
			$Structs{'MEMORYSTATUS'} = $MEMORYSTATUS;
		}
		else {
			$MEMORYSTATUS = $Structs{'MEMORYSTATUS'};
		}
		$MEMORYSTATUS->align('auto');
		$MEMORYSTATUS->{'dwLength'}     = 0;
		$MEMORYSTATUS->{'MemLoad'}      = 0;
		$MEMORYSTATUS->{'TotalPhys'}    = 0;
		$MEMORYSTATUS->{'AvailPhys'}    = 0;
		$MEMORYSTATUS->{'TotalPage'}    = 0;
		$MEMORYSTATUS->{'AvailPage'}    = 0;
		$MEMORYSTATUS->{'TotalVirtual'} = 0;
		$MEMORYSTATUS->{'AvailVirtual'} = 0;

		GlobalMemoryStatus($MEMORYSTATUS);
		return undef if $MEMORYSTATUS->{dwLength} == 0;

		if ( keys(%$return) == 0 ) {
			foreach (@params) {
				$return->{$_} =
				  ( $_ eq "MemLoad" )
				  ? $MEMORYSTATUS->{$_}
				  : $MEMORYSTATUS->{$_} / $MemFormat;
			}
		}
		else {
			foreach (@params) {
				$return->{$_} = $MEMORYSTATUS->{$_} / $MemFormat
				  unless ( !defined( $return->{$_} ) );
			}
		}
	}
	1;
}
#==========================

#==========================
sub ProcessorInfo (;\%) {
	my $allHash = shift;

	# Determine operating system
	return undef unless my $OS = &$check_OS;

	if ( !defined( $Types{'SYSTEM_INFO'} ) ) {

		# (See GetSystemInfo on MSDN)
		Win32::API::Struct->typedef(
			SYSTEM_INFO => qw{
			  WORD wProcessorArchitecture;
			  WORD wReserved;
			  DWORD dwPageSize;
			  UINT_PTR lpMinimumApplicationAddress;
			  UINT_PTR lpMaximumApplicationAddress;
			  DWORD_PTR dwActiveProcessorMask;
			  DWORD dwNumberOfProcessors;
			  DWORD dwProcessorType;
			  DWORD dwAllocationGranularity;
			  WORD wProcessorLevel;
			  WORD wProcessorRevision;
			  }
		);
		$Types{'SYSTEM_INFO'} = 1;
	}

	if ( !defined( $Procedures{'GetSystemInfo'} ) ) {
		Win32::API->Import( 'kernel32',
			'VOID GetSystemInfo(LPSYSTEM_INFO lpSystemInfo)' )
		  or die
		  "Could not locate kernel32.dll - SystemInfo.pm cannot continue\n";
		$Procedures{'GetSystemInfo'} = 1;
	}
	my $SYSTEM_INFO;
	if ( !defined( $Structs{'SYSTEM_INFO'} ) ) {
		$SYSTEM_INFO = Win32::API::Struct->new('SYSTEM_INFO');
		$Structs{'SYSTEM_INFO'} = $SYSTEM_INFO;
	}
	else {
		$SYSTEM_INFO = $Structs{'SYSTEM_INFO'};
	}

	{
		# Ignore Win32::API warnings. It's ugly, but what are you gonna do?
		local $SIG{__WARN__} = sub { };
		$SYSTEM_INFO->{'wProcessorArchitecture'}      = 0;
		$SYSTEM_INFO->{'wReserved'}                   = 0;
		$SYSTEM_INFO->{'dwPageSize'}                  = 0;
		$SYSTEM_INFO->{'lpMinimumApplicationAddress'} = 0;
		$SYSTEM_INFO->{'lpMaximumApplicationAddress'} = 0;
		$SYSTEM_INFO->{'dwActiveProcessorMask'}       = 0;
		$SYSTEM_INFO->{'dwNumberOfProcessors'}        = 0;
		$SYSTEM_INFO->{'dwProcessorType'}             = 0;
		$SYSTEM_INFO->{'dwAllocationGranularity'}     = 0;
		$SYSTEM_INFO->{'wProcessorLevel'}             = 0;
		$SYSTEM_INFO->{'wProcessorRevision'}          = 0;
		GetSystemInfo($SYSTEM_INFO);

		my $proc_type;    # Holds 386,586,PPC, etc
		my $num_proc;     # number of processors

		$num_proc = $SYSTEM_INFO->{dwNumberOfProcessors};
		if ( $OS eq "Win9x" ) {
			$proc_type = $SYSTEM_INFO->{dwProcessorType};
		}
		elsif ( ( $OS eq "WinNT" ) || ( $OS eq "Win2K" ) ) {
			my $proc_level;    # first digit of Intel chip (5,6,etc)
			my $proc_val;
			$proc_val   = $SYSTEM_INFO->{wProcessorArchitecture};
			$proc_level = $SYSTEM_INFO->{wProcessorLevel};

			# $proc_type is the return value of ProcessorInfo
			if ( $proc_val == PROCESSOR_ARCHITECTURE_INTEL ) {
				$proc_type = $proc_level . "86";
			}
			elsif ( $proc_val == PROCESSOR_ARCHITECTURE_AMD64 ) {
				$proc_type = "x64";
			}
			elsif ( $proc_val == PROCESSOR_ARCHITECTURE_MIPS ) {
				$proc_type = "MIPS";
			}
			elsif ( $proc_val == PROCESSOR_ARCHITECTURE_PPC ) {
				$proc_type = "PPC";
			}
			elsif ( $proc_val == PROCESSOR_ARCHITECTURE_ALPHA ) {
				$proc_type = "ALPHA";
			}
			else { $proc_type = "UNKNOWN"; }
		}

		# if a hash was supplied, fill it with all info
		if ( defined($allHash) ) {
			$allHash->{NumProcessors} = $num_proc;
			$Registry->Delimiter("/");
			for ( my $i = 0 ; $i < $num_proc ; $i++ ) {
				my $procinfo = $Registry->Open(
					"LMachine/Hardware/Description/System/CentralProcessor/$i",
					{ Access => KEY_READ() }
				);
				my %prochash;
				$prochash{Identifier}       = $procinfo->{Identifier};
				$prochash{VendorIdentifier} =
				  $procinfo->{VendorIdentifier};
				if ( $OS eq "Win9x" ) {
					$prochash{MHZ} = -1;
				}
				else {
					$prochash{MHZ} = hex $procinfo->{"~MHz"};
				}
				$prochash{ProcessorName} =
				  $procinfo->{ProcessorNameString};
				$allHash->{"Processor$i"} = \%prochash;
			}
		}
		return $proc_type;
	}
}

1;
__END__