@rem = '--*-Perl-*--
@if exist . if not ""=="%ERRORLEVEL%" for %%I IN (perl.exe miniperl.exe) DO @if not "%%~$PATH:I"=="" "%%~$PATH:I" -Sx "%~f0" %*&goto :EOF
@miniperl -Sx %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
@goto endofperl
@rem ';
#!/usr/bin/perl -w
#line 8

use 5.6.1;
#use strict;

BEGIN { $^H |= 0x1 if 1<<30 < 1<<62; } # включить use integer для случая use64bitint
if (int(1.9) != 1) { die "FATAL! Perl interpreter has int() rounding BUG: $^X\n"; }

sub Updir {
  $_[0] =~ m/\A ((?:\\[\\?]\?\\)? (?:[a-zA-Z]:)?[\\\/]? (?: .+(?<![\\\/])(?=[\\\/]+[^\\\/]) | (?=[\\\/]*[^\\\/]*[\\\/]*\z) ) )/sx ?  # проверять условие необязательно - срабатывает всегда
    (do { $1 =~ m/[\\\/]\z | \A[A-Za-z]:\z | \A\z/x } ? "$1." : $1) : undef;
}

# Optional Localization
unshift @INC, Updir($0);
*win2oem = eval "require plLocale" ? \&plLocale::win2oem : sub {$_[0]};


sub O_RDWR()       { 2 }
sub O_SEQUENTIAL() { 32 }
sub O_BINARY()     { 32768 }

sub FatalError($$) # (UserMessage, ExitCode)
{
  my $err = $^E;
  print "ERROR!";
  print " ", win2oem($_[0]) if defined $_[0];
  printf " -- [%d] %s", $err, win2oem($err) if $err ne "";
  print "\n";
  exit $_[1];
}

sub HexLarge($) {
  my $hs = $_[0];
  return length($hs) <= 8 ? hex($hs) : hex(substr($hs,-8)) + hex(substr($hs,0,-8)) * 2**32;
}


sub Usage {
  print <<EOT;
Patch files according to DOS/Windows fc /b or fcbin output. (c) metafizik, 2007
Syntax: fcpatch _target_file _patch_text_file [_patch_option]
  "<" as _patch_text_file reads from STDIN
  _patch_option:
         none: print data columns, do not modify target file (test mode)
  -p     Apply patch if one of data columns is recognized
  -1 -2  Apply 1st or 2nd column of _patch_text_file, even if unrecognized
  /1 /2  Force 1st or 2nd column of _patch_text_file on _target_file
  ...t   Transfer timestamp from _patch_text_file
EOT

  if (sysopen(my $SELF, __FILE__, O_BINARY | O_SEQUENTIAL)) {
      my $b;
      for($b = 15; $b < (5/2 == 2 ? 66 : do { my $n=0; while(++$n < 66) {last if sin(2**$n-1) == sin(2**$n)} ($n-1)}); $b++)
         { last if not sysseek $SELF, 2**$b, 0; }
      printf "Your Perl %vd supports file sizes up to %s (%d bits)\n", $^V,
             $b < 20 ? (1<<($b-10))." KB" : $b < 30 ? (1<<($b-20))." MB" :
             $b < 40 ? (1<<($b-30))." GB" : (1<<($b-40))." TB", $b;
  }
  # Работа с файлами через sys... функции если и ускоряет fcpatch, то незначительно
  exit 250;
}

#################

if (not defined $ARGV[1]) { Usage(); }
my $dbg = defined $ARGV[3];

my $line;
my @patchData;
my $patchFmt = (1<<30 < 1<<62) ? "QCC" : "dCC";
my $isFirst = 1;
my $isSecond = 1;
my $infomode = 1;
my $forcemode = 0;
my $optCol = 0; # номер колонки, если указан в ком. строке
my $block = "";
my $blockStart = -1; # not read yet
my $CLUSTER_SIZE = 4*1024; # 4KB
sub MAX_BLOCK_SIZE() {4*1024*1024} # 4MB

if (defined $ARGV[2]) {
    if (not ($ARGV[2] =~ m/^([\-\/])?(?:p(?:atch)?|(1|2))t?$/i))
       { FatalError "Illegal option $ARGV[2]", 251; }
    $infomode = 0;
    if (defined($1) and $1 eq '/') { $forcemode = 1; $isFirst = 0; $isSecond = 0; }
    if (defined $2) { $optCol = int $2; }
}

my $PATCHER;
if ($ARGV[1] eq "<") { $PATCHER = "STDIN" }
else {
   sysopen $PATCHER, $ARGV[1], O_BINARY | O_SEQUENTIAL
    or FatalError "Cannot open patch text file \"$ARGV[1]\"", 241;
}

sysopen my $TARGET, $ARGV[0], ($infomode ? 0 : O_RDWR) | O_BINARY
  or FatalError "Cannot open target file \"$ARGV[0]\"".($infomode ? "":" in R/W mode"), 242;

# Узнать размер кластера диска, где расположен изменяемый файл
# Работает только под полноценным PERL, под miniperl.exe размер всегда считается = 4КБ
# Не распознаются символические ссылки
{
# к сожалению, SymLink ссылки не отслеживаются
my $dir = Win32::GetFullPathName($ARGV[0]) . "/..";
my $n;

local $SIG{__WARN__} = sub {};
if (eval('require Win32::API')) {

 Win32::API->Import("KERNEL32", "BOOL GetDiskFreeSpaceA(
   LPCSTR lpRootPathName,
   LPDWORD lpSectorsPerCluster,
   LPDWORD lpBytesPerSector,
   LPDWORD lpNumberOfFreeClusters,
   LPDWORD lpTotalNumberOfClusters
 )");

 if (defined &GetDiskFreeSpaceA) {
  my $SectorsPerCluster = "\0" x 16;
  my $BytesPerSector = "\0" x 16;
  my $r = GetDiskFreeSpaceA($dir, $SectorsPerCluster, $BytesPerSector, \0, \0);
  if ($r != 0) { $n = unpack("V",$SectorsPerCluster) * unpack("V",$BytesPerSector); }
 }
}

if (not defined $n) {
$n = system('winapiexec.exe'.($dbg ? '':' 2>nul').' GetDiskFreeSpaceA $s:"'.$dir.'" $b:4 $b:4 $b:4 $b:4 , MulDiv $$:3@0 $$:4@0 256'); # /256*256
}
if ($n >= 512 and $n <= 1024*1024)  {
   $CLUSTER_SIZE = $n;
   printf("Cluster size: %d\n", $n) if $dbg;
} else {
   print("WARNING! Cluster size: ? / 4096 bytes assumed\n") if $dbg;
}
}

while($line = readline($PATCHER)) {
  # Не ускоряют: модификатор o, атомарные захваты (?>...)
  if (not $line =~ m/^[ \t]*([0-9A-F]{8,16}): *([0-9A-F]{2,2}) +(?:[^ \r\n] +)?([0-9A-F]{2,2})\b/io)
      {next}

  my $addr = HexLarge($1);
  my $c1 = hex($2);
  my $c2 = hex($3);

  if (not $forcemode) {
     my $offset = $addr % $CLUSTER_SIZE;
     if ($addr - $offset != $blockStart) {
         $blockStart = $addr - $offset;
         sysseek $TARGET, $blockStart, 0  or FatalError "Unable to set read position $blockStart", 243;
         sysread $TARGET, $block, $CLUSTER_SIZE  or FatalError "Unable to read at $blockStart", 244;
     }
     my $c = ord(substr($block, $offset, 1));
     if ($c != $c1) { $isFirst = 0 }
     if ($c != $c2) { $isSecond = 0 }

     if ($infomode) {
         printf "%s: %s%02X  %s%02X",
           $addr < 2**32 ? sprintf("%08X", $addr) : sprintf("%X%08X", int($addr / 2**32), $addr % 2**32),
           $c == $c1 ? "=" : "", $c1,
           $c == $c2 ? "=" : "", $c2;
         if ($c != $c1 and $c != $c2) { printf "  =%02X\n", $c; }
         else { print "\n" }
     }
  }
  push @patchData, pack($patchFmt, $addr, $c1, $c2);
}

close $PATCHER;

if ($#patchData < 0) {
    printf "Nothing to do! No patch data in \"%s\"\n", win2oem($ARGV[1]);
    goto Ending;
}

if ($isFirst and $isSecond) {
    printf "Nothing to do! Data columns are identical in \"%s\"\n", win2oem($ARGV[1]);
    goto Ending;
}

if (not $isFirst and not $isSecond) {
    if (not $forcemode) {
        print "Target file is not recognized as patched or unpatched\n";
        if ($infomode) { goto Ending }
    }
    if    ($optCol==1) { $isSecond = 1 }
    elsif ($optCol==2) { $isFirst  = 1 }
    else  { goto Ending }
} else {
    printf "Data column #%d seems to be correct patch in \"%s\"\n", $isSecond ? 1 : 2, win2oem($ARGV[1]);
    if ($optCol==1 and not $isSecond  or  $optCol==2 and not $isFirst)
       { FatalError "Cannot patch to column #$optCol without force mode", 247 }
    if ($infomode) { goto Ending }
}

my $timer = Win32::GetTickCount();

# Оптимизированная запись:
#  Кластеры и последовательности кластеров ещё раз читаются (можно надеяться из кэша; хотя их, конечно, можно было запоминать) и затем пишутся одной блочной операцией
#  Одиночные байты вне последовательностей пишутся как одиночные байты
#  Используются оставшиеся от чтения значения $blockStart и $block
#  ... однако ускорение не такое уж большое в сравнении с побайтовой записью (+WB cache ОС)
my $blockLen= length($block);
my $inBlock = 0;
for(my $i = 0;;) {
    my ($addr, $c1, $c2) = unpack($patchFmt, $patchData[$i]);
    my $offset = $addr % $CLUSTER_SIZE;
    my $gran = $addr - $offset;
    if ($gran != $blockStart and $gran != $blockStart+$CLUSTER_SIZE  or $blockLen >= MAX_BLOCK_SIZE) {
Finalize:
        if ($inBlock > 0) {
            printf("  %08X clusters %u mdf:%u\n", $blockStart, $blockLen, $inBlock) if $dbg;
            sysseek $TARGET, $blockStart, 0  or FatalError "Unable to set write position $blockStart", 245;
            syswrite $TARGET, substr($block, 0, $blockLen)  or FatalError "Write fault at $blockStart {$blockLen}", 246;
        }
        if ($i > $#patchData) {last}
        $inBlock = 0;
        $blockLen = 0;
        $blockStart = $gran;
    }

    my $c = chr($isFirst ? $c2 : $c1);
    if ($inBlock == 0 and
        ($i >= $#patchData or do {
            my $granNext = unpack($patchFmt, $patchData[$i+1]);
            $granNext -= $granNext % $CLUSTER_SIZE;
            $granNext != $gran and $granNext != $gran + $CLUSTER_SIZE;
        })) {
        printf("  %08X byte %02X '%s'\n", $addr, ord($c), $c =~ m/[\0\x07\x09\r\n]/ ? ' ': $c) if $dbg;
        sysseek $TARGET, $addr, 0  or FatalError "Unable to set write position $addr", 245;
        syswrite $TARGET, $c  or FatalError "Write fault at $addr {1}", 246;
    } else {
      if ($addr - $blockStart >= $blockLen) {
          sysseek $TARGET, $gran, 0  or FatalError "Unable to set read position $gran", 243;
          (my $n = sysread $TARGET, substr($block, $blockLen, $CLUSTER_SIZE), $CLUSTER_SIZE)  or FatalError "Unable to read at $gran", 244;
          $blockLen += $n;
      }
      substr($block, $addr - $blockStart, 1) = $c;
      ++$inBlock;
    }
    if (++$i > $#patchData) { local $SIG{__WARN__} = sub {}; goto Finalize; }  # Perl 18.2 пишет Warning: deprecated на goto
}

$timer = Win32::GetTickCount() - $timer;
if ($timer < 0) { $timer += 4294967296 }
printf "Patched! %u bytes written in %u.%03u sec\n", $#patchData+1, $timer/1000, $timer%1000;

Ending:
close $TARGET;

if (defined($ARGV[2]) and $ARGV[2] =~ m/t$/) {
    # Установка даты изменённого файла в дату файла различий
    my $t = (stat $ARGV[1])[9];
    if (defined $t) { utime time(), $t, $ARGV[0]; }
}

exit( ($isFirst ? 1:0) | ($isSecond ? 2:0) );

__END__
:endofperl
@