use strict;
use Win32;
use Win32::Registry;
use Encode; my ($acp,$ocp) = ('cp1251', 'cp866');

my %KnownGUIDS =
( '3.00'     => '{093DE8B4-48DB-45DC-92F7-E468ABEF2129}'
, '3.10'     => '{156CCB3A-83E7-4bc1-B340-AF37F5C8BB0B}'
, '3.20'     => '{B7348B5D-B65D-4bf5-AF63-A3135249ACA7}'
, '3.30'     => '{94F49596-05D6-428b-A6DA-600B21051F89}'
, '3,31'     => '{6F8793A7-3266-4b51-98C1-476A0D1A7AFC}'
, '3.32'     => '{D3C51B26-1D12-41dE-AA95-CDEA26A7E56F}'
, '3.40'     => '{48C6296A-4F4C-4238-A9E1-60E9A544A863}'
, '3.50'     => '{888247F5-C659-4770-BB8A-975EAD87A817}'
, '3.51'     => '{B2DD5486-4922-42cc-A68E-C9069FFC3205}'
, '3.60'     => '{7FC8EFD9-88F1-4B46-A09D-17EBCA3EFBA7}'
, '3.61',    => '{E1ECD77B-4AD7-4E38-A451-005EDFE7373C}'
, '4.0',     => '{23DE9F4B-25F9-4163-BF69-01639BB2B8BA}'
, '4.5',     => '{52DEECFD-57ED-4ec1-8FEC-879F1F877F80}'
, '4.51',    => '{AB20FDB4-88E0-4B12-BDAC-0EA2F0DB7DE8}'
, '4.52',    => '{AB20FDB4-88E0-4B12-BDAC-0EA2F0DB7DE8}'
, '4.61',    => '{DEA909B8-6AAB-4F0A-BEEB-8011683B5EF5}'
, '4.62',    => '{ABE5FDDA-E209-4E92-ACFE-A222621C5A58}'
);

sub get_key($)
{
   my ($o) = @_;
   return $1 if $o =~ m!^(\{[a-f\d]{8}-[a-f\d]{4}-[a-f\d]{4}-[a-f\d]{4}-[a-f\d]{12}\})$!io;
   for my $v (keys %KnownGUIDS)
   {
      return $KnownGUIDS{$v} if (lc($v) eq lc($o));
   }
   die "\nUnknown version: $o\n";
}

my $usage = '
usage:
  incredi_trial.pl [-exe|-delete|-patch|-create] [-debug|-quiet] [N|guid|known_version]

samples:
  incredi_trial.pl

  incredi_trial.pl -del 1
  incredi_trial.pl -del

  incredi_trial.pl -patch 2 3
  incredi_trial.pl -create {527750C4-E5A7-404C-AE2B-749D9718EA0B}
  incredi_trial.pl -patch 3.40 3.50 {527750C4-E5A7-404C-AE2B-749D9718EA0B}
';

sub execute($);
sub readfile($);
sub g2str($);
sub g2date($);
sub get_days_1900();
sub double_to_guid($);
##########################################################################################

my $arch  = Win32::GetChipName();
my $SOFTWARE  = $arch eq '8664' ? "SOFTWARE\\Wow6432Node"  : "SOFTWARE";
my $Interface = $arch eq '8664' ? "Wow6432Node\\Interface" : "Interface";
my (@Keys, @FoundKeys, @foundKeys, %Values, %Modules, %Folders, %Nums);

my ( $opt_patch,$opt_create, $opt_del, $opt_exe, $opt_debug ) = ( 0,0, 0, 1, 0 );

while ( scalar(@ARGV) > 0 )
{
   my $o = shift @ARGV;
   if    ( $o =~ m!^-del(ete)?$!io )  { $opt_del=-1; $opt_exe=$opt_patch=$opt_create=0; }
   elsif ( $o =~ m!^-(p|patch)$!io )  { $opt_del=$opt_exe=$opt_create=0; $opt_patch=-1; }
   elsif ( $o =~ m!^-(c|create)$!io ) { $opt_del=$opt_exe=0; $opt_patch=$opt_create=-1; }
   elsif ( $o =~ m!^(\d+)$!o )           { $Nums{$1}++; }
   elsif ( $o =~ m!^-(exe|files)$!io )   { $opt_exe = 1 - $opt_exe; }
   elsif ( $o =~ m!^-(d|dbg|debug)$!io ) { ++$opt_debug; }
   elsif ( $o =~ m!^-(q|quiet)$!io )     { --$opt_debug; }
   elsif ( $o =~ m!^--?h(elp)?$!io )     { print $usage; exit 0; }

   else { $o = get_key($o); push @FoundKeys, $o; push @foundKeys, g2str($o); }
}
my $quiet = $opt_debug; --$quiet if ($opt_del || $opt_patch); $quiet = $quiet < 0;

my ($m, $v, $SW);
for $m ('Builder', 'Coordinator')
{
   print "\nIncrediBuild $m:\n" unless( $quiet );
   if ($::HKEY_LOCAL_MACHINE->Open("$SOFTWARE\\Xoreax\\IncrediBuild\\$m", $SW))
   {
      $Modules{$m}++;
      $SW->GetValues(\%Values);
      $Folders{$Values{'Folder'}->[2]}++;
      unless ( $quiet ) {
         for $v ('Version', 'VersionText', 'Folder') {
            next unless exists( $Values{$v} );
            print sprintf("  %-11s = \"%s\"\n", $Values{$v}->[0], $Values{$v}->[2]);
         }
      }
      $SW->Close();
   }
   else { print "  Version data weren't found\n" unless( $quiet ); }
}

my ($i, $k, $IF, $I) = ( 0 );
unless ( @FoundKeys )
{
   $::HKEY_CLASSES_ROOT->Open($Interface,$IF) || die "Can't open 'HKCR->$Interface' -- $^E";
   print "\nTrial Date Record(s):\n" unless( $quiet );
   $IF->GetKeys(\@Keys);
   for $k (@Keys)
   {
      next unless ( $k =~ m!^\{\w{8}-\w{4}-\w{4}-\w{4}-\w{12}\}$!io );

      my ($def, $r_stop, $r_del, $r_start, @unused) = (undef, -1, -1, -1);
      $IF->QueryValue($k, $def);
      next unless defined($def);
      next unless $def eq 'Field';

      next unless $IF->Open($k, $I);
      my ($n, $p, $t) = (undef, undef, undef);
      $I->QueryValue('NumMethods',       $n);
      $I->QueryValue('ProxyStubClsid32', $p);
      $I->QueryValue('TypeLib',          $t);
      $I->Close();
      next unless ( defined($n) && defined($p) && !defined($t) );

      print sprintf("  [%d] %s=%s / %s\n", ++$i, $k, $p, g2date($p)) unless( $quiet );
      push @FoundKeys, $k;
      push @foundKeys, g2str($k);
   }
   $IF->Close();
}

# scans Incredibuild Program Directory and looks for found Interface GUID(s) -------------
#
if ( $opt_exe && scalar(@FoundKeys) > 0 )
{
   my ($xpath, $i, $file, $data, $r, $p, $k);
   for $xpath (sort keys %Folders)
   {
      $xpath =~ s!\\$!!o;
      $xpath =~ s!\\!/!og;
      next unless -d $xpath;

      print "\nInterface GUID(s) file references:\n" unless( $quiet );
      if ( opendir(XDIR, $xpath) )
      {
         while ( $file = readdir(XDIR) )
         {
            next unless -f "$xpath/$file";
            $data = readfile("$xpath/$file");
            next unless $data;

            for ( $i=0; $i < scalar(@FoundKeys); ++$i ) {
               ($k, $p) = ($foundKeys[$i], -1);
               do {
                  $p = index($data, $k, $p+1);
                  if ( $p >= 0 ) {
                     print sprintf("  %-18s : %s -- 0x%08X\n", $file, $FoundKeys[$i], $p);
                  }
               } while ( $p >= 0 );
            }
         }
         closedir(XDIR);
      }
   }
}

if ( $opt_del || $opt_patch )
{
   if (scalar(keys %Nums) > 0) { $opt_del *= $opt_del; $opt_patch *= $opt_patch; }
   print "\n" unless( $quiet );
   execute("net stop IncrediBuild_Agent")        if ($Modules{'Builder'});
   execute("net stop IncrediBuild_Coordinator")  if ($Modules{'Coordinator'});
   my $patch_guid = double_to_guid(get_days_1900() + 45+0*(365-45));
   for ($i = 0; $i < scalar(@FoundKeys); ++$i)
   {
      my $k = $FoundKeys[$i];
      if ( $opt_del < 0 || ($opt_del > 0 && $Nums{$i+1}) ) {
         execute("reg delete HKCR\\$Interface\\$k /f");
      }
      if ( $opt_patch < 0 || ($opt_patch > 0 && $Nums{$i+1}) ) {
         if ( $opt_create ) {
            execute("reg add HKCR\\$Interface\\$k /ve /d Field /f");
            execute("reg add HKCR\\$Interface\\$k\\NumMethods /ve /d 4 /f");
         }
         execute("reg add HKCR\\$Interface\\$k\\ProxyStubClsid32 /ve /d $patch_guid /f");
      }
   }
   execute("net start IncrediBuild_Coordinator") if ($Modules{'Coordinator'});
   execute("net start IncrediBuild_Agent")       if ($Modules{'Builder'});
}

exit 0;
##########################################################################################

sub is_oem($)
{
   my ($t) = @_;
   for (my $ii = 0; $ii < length($t); ++$ii)
   { my $c = ord(substr($t, $ii, 1)); return 1 if ( $c >= 0x80 && $c <= 0xAF ); }
   return 0;
}

sub execute($)
{
   my ($cmd) = @_;
   print $cmd, " " unless( $opt_debug < 0);

   my $t = `$cmd 2>&1`;
   my $r = $?;

   print "-- ", $r==0 ? "ok" : sprintf("FAILED [%d]",$r),"\n" if ($opt_debug >= 0);
   if ( $opt_debug > 0 || ($opt_debug == 0 && $r) ) {
      Encode::from_to($t, $acp, $ocp) if ($acp && !is_oem($t));
      print $t;
   }
}

sub readfile($)
{
   my ($file) = @_;
   my $data;
   local $/; # undefined record separator -- read whole file as one string
   return undef unless( open(IN, "<:raw", $file) );
   $data = <IN>;
   close(IN);
   return $data
}

sub g2str($)
{
   my ($k) = @_;
   my ($k1, $k2, $k3, $k4, $k5, $k6, $p, $r);
   # 0         1         2         3        # ^
   # 01234567890123456789012345678901234567 # pos
   # {04030201-0201-0201-0102-010203040506} # GUID
   #  11111111 2222 3333 4444 555555556666  # $kN
   $k1 = hex(substr($k,  1, 8));
   $k2 = hex(substr($k, 10, 4));
   $k3 = hex(substr($k, 15, 4));
   $k4 = hex(substr($k, 20, 4));
   $k5 = hex(substr($k, 25, 8));
   $k6 = hex(substr($k, 33, 4));
   $k = pack "VvvnNn", $k1, $k2, $k3, $k4, $k5, $k6;
   return $k;
}

sub get_days_1900()
{
   my $days_1970_1900 = 365*70 + 17;
   my $t = time();
   return $days_1970_1900 + ($t / (24*3600));
}

sub double_to_guid($)
{
   my ($days) = @_;
   my $raw_double = pack("d", $days);
   my ($b0,$b1,$b2,$b3,$b4,$b5,$b6,$b7) = unpack("CCCCCCCC", $raw_double);
   my $guid = sprintf("{%08X-%04X-%04x-%02X%02X-%02X%02X%02X%02X%02X%02X}",
      $b0*$b1*$b2*$b3, $b4*$b5, $b6*$b7, $b0,$b1,$b2,$b3,$b4,$b5,$b6,$b7
   );
   return $guid;
}

sub g2date($)
{
   my ($guid) = @_;
   my $days = unpack("d", substr(g2str($guid),8));
   my $d = int($days);
   my $s = int(($days - $d) * 24 * 3600 + 0.5);
   my $t = $s + ($d - 70*365 - 17) * 24 * 3600;
   my ($sec,$min,$hour, $day,$month,$year) = localtime($t);
   $d = sprintf("%d-%02d-%02d %02d:%02d:%02d", $year+1900,$month+1,$day, $hour,$min,$sec);
   return $d;
}
