=head1 NAME

  CFX5::Win32::SysInfo - System information on Win32 machines

=head1 SYNOPSIS

This file provides functions for the use of L<cfx5info> to get
information about Windows NT machines.  It may be useful in other
scripts which need human-readable information about the current setup,
but it is not currently useful for providing information in a
machine-readable format.

=cut

package CFX5::Win32::SysInfo;

use strict;

use CFX5::Win32::Registry qw(:ALL);

use CFX5::Config qw(%Config query_conf);

use CFX5::Commands qw(get_cmd_output);

use CFX5::PathManip qw(findbin_by_path join_file);

use CFX5::Win32::Output;

# we need to expand these at compile time, as the compiler doesn't
# like them.
BEGIN {
  for my $v (qw(HKEY_CURRENT_USER HKEY_LOCAL_MACHINE KEY_READ 
		REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ)) {
    import vars ("\$$v");
    eval "\$$v = \&$v();";
  }
}

=head1 DESCRIPTION

=head2 get_info_string

  print CFX5::Win32::SysInfo::get_info_string();

Returns a (possibly large) string describing the current system, in as
much detail is is thought useful for support purposes.

=cut

sub get_info_string {
  my $s="";
  my $r;

  my $hostname=$Config{CFX_HOST} || $Config{HOSTNAME} || $ENV{HOSTNAME};

  $s = "System Information for $hostname\n";
  $r=get_osname() ; $s .= "Operating System: $r\n" if defined $r;
  $r=get_flex_hostid(); $s .= "FlexLM Host ID: $r\n" if defined $r;
  $s.="\n";
  $r=get_cpu() ;    $s .= "CPU: $r\n" if defined $r;
  $s.="\n";
  $r=get_mem_info();    $s .= "Memory: $r\n" if defined $r;
  $s.="\n";
  $s .= join("\n",get_dir_info(),'');
  $s.="\n";
  $s .= join("\n",get_disk_info(),'');
  $s.="\n";
  $s.="\n";
  $s .= join("\n",get_update_info(),'');

  return $s;
}

=head1 OTHER FUNCTIONS

=head2 get_cpu

Returns a (multi-line) string describing the CPU type in the machine.

=cut

sub get_cpu {
  # we prefer to use x86info, as the GetSystemInfo call doesn't give
  # us enough to easily get the exact chip type, and anyway it's best
  # to have the info all in one place.
  my $execdir=$Config{CFX5EXECDIR};
  $execdir=join_file($Config{CFX5BINDIR}, "winnt") if $Config{windows_64};
  my $cmd=join_file($execdir, 'x86info.exe');
  my $cpuinfo;

  if (-f $cmd) {
    $cpuinfo=CFX5::Commands::get_cmd_output($cmd, '-long') || '';
    # remove any whitespace (including newlines)
    $cpuinfo=~s/\s*$//;
    # compress multiple spaces, to look better with the rest of
    # the output.
    $cpuinfo =~ s! +! !g;
  }

  my $nofprocs=scalar(registry_list_subkeys('hardware\description\system\centralprocessor'));
 
  my $cpu="$nofprocs x $cpuinfo";

  my $cpuspeed = registry_get('hardware\description\system\centralprocessor\0',
			    "~MHz");
  if($cpuspeed) {
    $cpu  .= "\nRunning at $cpuspeed MHz";
  }

  $cpu;
}

=head2 get_osname

Returns a string describing the operating system installed on the
local machine.

=cut

sub get_osname {
  my $regprefix = 'Software/Microsoft/Windows NT/CurrentVersion';

  my @osname;
  my $id = registry_get("$regprefix/ProductName");
  if (defined $id) {
    push @osname, $id;

    my $verstr = $Config{windows_nt_version};
    push @osname, "NT Version $verstr" if defined $verstr;

    my $buildnum = registry_get("$regprefix/CurrentBuildNumber");
    push @osname, "Build $buildnum" if defined $buildnum;
  } else {
    push @osname, 'Windows (unable to determine version from registry)';
  }

  push @osname, $Config{windows_64} ? '64-bit' : '32-bit';

  return join ', ', @osname;
}

=head3 get_update_info

  @info=get_update_info();

Returns a list of all installed Windows updates

=cut

sub get_update_info {
  my @info;

  push @info, split("\n", <<'EOF');
The following Microsoft Windows Updates are installed on this computer:
EOF
  push @info, '';

  my $reg_path = "SOFTWARE/Wow6432Node/Microsoft/Updates";
  for my $os (registry_list_subkeys($reg_path)) {
    for my $sp (registry_list_subkeys("$reg_path/$os")) {
      for my $up (registry_list_subkeys("$reg_path/$os/$sp")) {
        my $name=registry_get("$reg_path/$os/$sp/$up/Description");
        if ($name) {
          push @info, "  $name";
        } else {
          push @info, "  $os/$sp/$up";
        }
      }
    }
  }

  @info;
}

=head2 get_flex_hostid

Returns a string containing the FLEXlm host ID by running lmutil if
available.

=cut

sub get_flex_hostid {
  my $hostid;
  if (query_conf('CFX5ROOT') and -x $Config{CFX5ROOT}."/license/lmutil.exe") {
    $hostid=get_cmd_output("$Config{CFX5ROOT}\\license\\lmutil.exe","lmhostid");
  } else {
    # no CFX5ROOT, have a look for it on the path
    my $path=findbin_by_path('lmutil.exe');
    if ($path ne '.') {
      $hostid=get_cmd_output("$path\\lmutil.exe","lmhostid");
    } else {
      # no, not there either, but is it in the same directory as this
      # executable?
      $path=findbin_by_path($0);
      if ($path ne '.' and -f "$path\\lmutil.exe") {
	$hostid=get_cmd_output("$path\\lmutil.exe","lmhostid");
      }
    }
  }

  return undef unless defined $hostid;

  chomp $hostid;
  $hostid =~ s/.*The FlexLM host ID of this machine is\s*\"([^\"]*)\".*/$1/si;
  return $hostid;
}

=head2 WINDOWS DIRECTORY FUNCTIONS

=head3 get_dir_info

  @info=get_dir_info();

Reads the locations of some common directories, and returns a list of
the useful stuff.

=cut

sub get_dir_info {
  my @info;
  my $r;
  $r=get_windows_dir(0); push @info, "Windows directory: $r" if defined $r;
  $r=get_windows_dir(1); push @info, "Windows system directory: $r" if defined $r;
  @info;
}

=head3 get_windows_dir

  my $windir=get_windows_dir(0);

Parameter is 0 for Windows directory, or 1 for system directory.

=cut

sub get_windows_dir {
  # err guess
  my $sysdir=shift;
 
  if($Config{windows_nt}){
    return join_file($ENV{SystemRoot}, "system32") if $sysdir;
    return $ENV{SystemRoot};
  }

  my $GetWindowsDirectory = new Win32::API
    ("kernel32", 
     ($sysdir ? 'GetSystemDirectory' : 'GetWindowsDirectory',),
     [qw(P I)], 'I');
  return undef unless (defined $GetWindowsDirectory);

  my $buffer=" "x1024;
  my $result = $GetWindowsDirectory->Call($buffer, 1024);

  return undef unless $result;

  return substr($buffer,0,$result);
}

=head2 get_disk_info

Returns a list of lines giving information about disks in the system.

=cut

sub get_disk_info {
  # Can't do this on Windows x64
  return "" if $Config{windows_nt};
  require Win32::DriveInfo;
  my @drives = Win32::DriveInfo::DrivesInUse();
  my @info;
  for my $d (@drives) {
    push @info, "  " . get_drive_info($d);
  }
  @info;
}

sub get_drive_info {
  my $d=shift;
  my $type = Win32::DriveInfo::DriveType($d);
  if ($type == 2) {
    return "$d: is a removable disk drive (not probed)";
  }
  my $s;
  my %typestr = (
                 0 => 'unknown',
                 1 => 'non-existant',
                 2 => 'removable',
                 3 => 'fixed',
                 4 => 'network',
                 5 => 'cd',
                 6 => 'ram'
                );
  my ($VolumeName,
      $VolumeSerialNumber,
      $MaximumComponentLength,
      $FileSystemName, @attr) = Win32::DriveInfo::VolumeInfo($d);
  if( defined $VolumeSerialNumber ){
    my ($SectorsPerCluster,
        $BytesPerSector,
        $NumberOfFreeClusters,
        $TotalNumberOfClusters,
        $FreeBytesAvailableToCaller,
        $TotalNumberOfBytes,
        $TotalNumberOfFreeBytes) = Win32::DriveInfo::DriveSpace($d);
    my $mbfree=sprintf("%0.1f",$TotalNumberOfFreeBytes/(1024*1024));
    my $mb=sprintf("%0.1f",$TotalNumberOfBytes/(1024*1024));
    $s="$d: ($VolumeName) is a $typestr{$type} drive, $mbfree/${mb}MB free, $FileSystemName";
  }
  else {
    $s="$d: is a $typestr{$type} drive (currently unavailable)";
  }

  $s;
}

=head2 get_mem_info

Returns a string describing the memory configuration of the machine.

=cut

sub get_mem_info {
  return undef if $Config{windows_nt};

  require Win32::API;
  # GlobalMemoryStatusEx is supported in w2k Pro and XP only, but can
  # successfully report >2Gb of RAM.
  my $GlobalMemoryStatusEx = new Win32::API("kernel32", "GlobalMemoryStatusEx", [qw(P)], 'V');
  if (defined $GlobalMemoryStatusEx) {
    # assemble in two steps so we can fill in the dwLength field
    my $buffer = pack("L16",0 x 9);
    $buffer=pack("L16", length($buffer), 0 x 8);

    $GlobalMemoryStatusEx->Call($buffer);

    # we can't rely on quad-word support in Perl, so DIO
    my (undef,
        $memload,
        $totalphyslo,
        $totalphyshi,
        $availphyslo,
        $availphyshi,
        $totalpagelo,
        $totalpagehi,
        $availpagelo,
        $availpagehi,
        $totalvirtlo,
        $totalvirthi,
        $availvirtlo,
        $availvirthi,
        $availextvirtlo,
        $availextvirthi
       ) = unpack("L16",$buffer);

    # 2^32 / 1024 / 1024 = 4096
    my $phys=int($totalphyslo/(1024*1024)) + $totalphyshi * 4096;
    my $page=int($totalpagelo/(1024*1024)) + $totalpagehi * 4096;
    return "Total memory ${phys}M physical, ${page}M including page file";
  }

  my $GlobalMemoryStatus = new Win32::API("kernel32", "GlobalMemoryStatus", [qw(P)], 'V');
  return undef unless (defined $GlobalMemoryStatus);

  my $buffer = pack("L8",0 x 8);
  $buffer=pack("L8", length($buffer), 0 x 7);

  $GlobalMemoryStatus->Call($buffer);

  my (undef,
      $memload,
      $totalphys,
      $availphys,
      $totalpage,
      $availpage,
      $totalvirt,
      $availvirt
     ) = unpack("L8",$buffer);

  my $phys=int($totalphys/1024);
  my $page=int($totalpage/1024);

  return "Total memory ${phys}K physical, ${page}K including page file";
}

=head2 FILE VERSIONS

=head3 get_file_version_info

I<internal function>

  my $info=get_file_version_info('C:\\winnt\\system32\\msvcrt.dll');

Returns the file info block from a file for later use.  Stupid way of
doing things if you ask me ... return value is undef if something
fails.

=cut

sub get_file_version_info {
  my $file=shift;
  return undef unless defined $file and -f $file;
  return undef if $Config{windows_nt};

  require Win32::API;
  my $GetFileVersionInfoSize = new Win32::API
    ('version', 
     'GetFileVersionInfoSize',
     [qw(P P)], 'N');
  return undef unless (defined $GetFileVersionInfoSize);
  
  my $GetFileVersionInfo = new Win32::API
    ('version', 
     'GetFileVersionInfo',
     [qw(P N N P)], 'I');
  return undef unless (defined $GetFileVersionInfo);
  
  my ($dummy)=" "x32;
  my $result=$GetFileVersionInfoSize->Call($file,$dummy);
  return undef unless $result;

  # pad it a little, just in case
  my $buffer=" "x($result+32);

  my $result2=$GetFileVersionInfo->Call($file, 0, $result, $buffer);
  return undef unless $result2;

  substr($buffer,0,$result);
}

=head3 read_file_version_info

  %VersionInfo = read_file_version_info('file.dll');
  $Version = read_file_version_info('file.dll','FileVersion');

Returns a hash containing the extended file version information for
the named file or, if a second argument is present, reads just that
entry.

=cut

sub read_file_version_info {
  return undef if $Config{windows_nt};
  require Win32::API;
  my $file=shift;
  my $versinfo = get_file_version_info($file);
  return () unless defined $versinfo;

  my $VerQueryValue=new Win32::API
    ('version', 
     'VerQueryValue',
     [qw(P P P P)], 'I');
  return undef unless (defined $VerQueryValue);

  #
  # read the translation table info
  #
  my ($transtable, $tablesize)=(pack("L",0),pack("L",0));
  my $result=$VerQueryValue->Call($versinfo, '\\VarFileInfo\\Translation',
				  $transtable, $tablesize);
  
  my $length=unpack("L",$tablesize);
  my $info=unpack("P$length",$transtable);
  my ($charset,$codepage)=(1252,0);
  if ($length >= 4) {
    ($charset,$codepage)=unpack("SS",$info);
  }
  my $lang_charset=sprintf("%04X%04X",$charset,$codepage);

  my %Info;

  my @list=@_;
  @list=qw(CompanyName FileDescription FileVersion InternalName
	   LegalCopyright OriginalFilename ProductName ProductVersion)
    unless @list;

  for my $entry (@list) {
    ($transtable, $tablesize)=(pack("L",0),pack("L",0));
    $result=$VerQueryValue->Call($versinfo,
				 "\\StringFileInfo\\$lang_charset\\$entry",
				 $transtable, $tablesize);
  
    if ($length=unpack("L",$tablesize)) {
      $info=unpack("P$length",$transtable);
      $info =~ s/\0.*//;		# find the NULL-terminator
      $Info{$entry}=$info;
    }
  }

  return @_ ? $Info{$_[0]} : %Info;
}

1;
