(* Copyright (c) 1999 Stuart King. All rights reserved. *)
program upgrade(output);
const
   UpgradeFileHeader = 'IU1';
type
   binary = file of char;
   ProgressType = 0..100;
   cardinal = 0..maxint;

var
   OldFile, NewFile, UpgradeFile : binary;

   procedure syntax;
   begin
      writeln('SYNTAX: ivm upgrade upgrade-file');
      writeln('    OR');
      writeln('        ivm -c old-file new-file upgrade-file');
      halt
   end;

   procedure DisplayError(msg : string);
   begin
      writeln('ERROR:', msg);
      halt
   end;

   procedure GenCRC(var crc : integer; c : char);
   const
      poly = $04C11DB7;
   var
      index : integer;
      DataHighBit : integer;
      CRCHighBit : integer;
      data : integer;

      function BitMask(n : integer) : integer;
      begin
	 BitMask := 1 shl n
      end;

   begin (* GenCRC *)
      data := ord(c);
      for index := 1 to 8 do
	 begin
		 if (crc and BitMask(31)) <> 0 then
		    CRCHighBit := 1
	    else
		    CRCHighBit := 0;
	    if (data and BitMask(7)) <> 0 then
		    DataHighBit := 1
	      else
		    DataHighBit := 0;
		 data := data shl 1;
		 crc := crc shl 1;
		 crc := crc or DataHighBit;
		 if CRCHighBit = 1 then
		    crc := crc xor poly
	 end
   end; (* GenCRC *)

   procedure WriteInteger(var f : binary; int : integer);
   var
      c : char;
      i : 1..4;
   begin (* WriteInteger *)
      for i := 1 to 4 do
	 begin
		 c := chr(int and $ff);
		 write(f, c);
		 int := int shr 8;
	 end
   end;  (* WriteInteger *)

   procedure ReadInteger(var f : binary; var int : integer);
   var
      c : char;
      i : 1..4;
   begin (* ReadInteger *)
      int := 0;
      for i := 1 to 4 do
	   begin
		 int := int shr 8;
		 read(f, c);
		 int := int or (ord(c) shl 24);
	      end
   end; (* ReadInteger *)

   procedure ReadFileHeader(var f : binary);
   var
      FileHeader : string;
      c : char;
      i : integer;
   begin (* ReadFileHeader *)
      FileHeader := UpgradeFileHeader;
      for i := 1 to length(FileHeader) do
	 begin
	    read(f, c);
	    if c <> FileHeader[i] then
	       DisplayError('Invalid upgrade file')
	 end
   end; (* ReadFileHeader *)

   procedure ReadFileName(var f : binary; var fn : filename);
   var
      c : char;
      i : integer;
   begin  (* ReadFileName *)
      fn := '';
      read(f, c);
      for i := 1 to ord(c) do
	 begin
	    read(f, c);
	    fn := fn + c
	 end
   end;  (* ReadFileName *)

   procedure WriteFileName(var f : binary; fn : filename);
   var
      i : integer;
   begin  (* WriteFileName *)
      write(f, chr(length(fn)));
      for i := 1 to length(fn) do
	 write(f, fn[i]);
   end;  (* WriteFileName *)

   procedure UpdateProgress(Curr, Last, OnePercent : Cardinal; var progress : ProgressType);
   begin (* UpdateProgress *)
      if ((curr mod OnePercent) = 0) or (curr = last) then
	      begin
		 write('*');
		 inc(progress);
		 if (progress mod 10) = 0 then
		    writeln(Progress:4,'%');
		 flush(output);
	      end
   end;

   procedure CreateUpgrade(var OldFile, NewFile, UpgradeFile : binary);
   const
      CreateOption = '-c';
   var
      crc : integer;
      i, NewSize, OldSize, OnePercent : cardinal;
      progress : ProgressType;
      NewChar, OldChar, UpgradeChar : char;

      procedure WriteFileHeader(var f : binary);
      var
	 FileHeader : string;
	 i : integer;
      begin
	 FileHeader := UpgradeFileHeader;
	 for i := 1 to length(FileHeader) do
	    write(f, FileHeader[i])
      end;

   begin (* CreateUpgrade *)
      if paramstr(1) <> CreateOption then
	 DisplayError('Create Option not specified');
      writeln('Creating Upgrade File ', paramstr(4));
      reset(OldFile, paramstr(2));
      reset(NewFile, paramstr(3));
      rewrite(UpgradeFile, paramstr(4));
      WriteFileHeader(UpgradeFile);
      WriteFileName(UpgradeFile, paramstr(2));
      WriteFileName(UpgradeFile, paramstr(3));

      OldSize := filesize(OldFile);
      NewSize := filesize(NewFile);
      WriteInteger(UpgradeFile, NewSize);

      crc := 0;
      OnePercent := NewSize div 100;
      if ((NewSize mod 100) <> 0) and (NewSize > 1000) then
	   inc(OnePercent);
      progress := 0;
      for i := 1 to NewSize do
	   begin
		 if OnePercent > 0 then
		    UpdateProgress(i, NewSize, OnePercent, progress);
		 read(NewFile, NewChar);
		 if eof(OldFile) then
		    begin
			close(OldFile);
			reset(OldFile)
		    end;
		 read(OldFile, OldChar);
		 if i <= OldSize then
		    GenCRC(crc, OldChar);
		 UpgradeChar := chr(ord(NewChar) xor ord(OldChar));
		 write(UpgradeFile, UpgradeChar);
	   end;
      GenCRC(crc, chr(0));
      GenCRC(crc, chr(0));
      GenCRC(crc, chr(0));
      GenCRC(crc, chr(0));
      writeln('CRC = ', hex(crc));
      WriteInteger(UpgradeFile, crc);
      writeln('Upgrade File Created');
   end; (* CreateUpgrade *)

   procedure CheckCRC(var OldFile, UpgradeFile : binary);
   var
      fn : filename;
      i, NewSize, OldSize, OnePercent : cardinal;
      crc, SavedCRC, iTemp : integer;
      progress : ProgressType;
      UpgradeChar, OldChar : char;
   begin (* CheckCRC *)
      writeln('Checking CRC');
      reset(UpgradeFile, paramstr(1));

      ReadFileHeader(UpgradeFile);

      ReadFileName(UpgradeFile, fn);
      reset(OldFile, fn);
      OldSize := filesize(OldFile);

      ReadFileName(UpgradeFile, fn);   (* Read and ignore name of new file *)

      ReadInteger(UpgradeFile, iTemp);
      if iTemp < 0 then
	 DisplayError('Invalid Upgrade File Size');
      NewSize := iTemp;

      OnePercent := NewSize div 100;
      if ((NewSize mod 100) <> 0) and (NewSize > 1000) then
	 inc(OnePercent);
      progress := 0;

      crc := 0;
      for i := 1 to NewSize do
	 begin
	    if OnePercent > 0 then
	       UpdateProgress(i, NewSize, OnePercent, progress);
	    read(UpgradeFile, UpgradeChar);
	    if i <= OldSize then
	       begin
		  read(OldFile, OldChar);
		  GenCRC(crc, OldChar);
	       end
	 end;
      GenCRC(crc, chr(0));
      GenCRC(crc, chr(0));
      GenCRC(crc, chr(0));
      GenCRC(crc, chr(0));
      (* writeln('CRC = ', hex(crc)); *)
      ReadInteger(UpgradeFile, SavedCRC);
      (* writeln('Saved CRC = ', hex(SavedCRC)); *)
      if crc <> SavedCRC then
	 DisplayError('CRC Mismatch');
   end; (* CheckCRC *)

   procedure ApplyUpgrade(var OldFile, NewFile, UpgradeFile : binary);
   var
      i, NewSize, OldSize, OnePercent : cardinal;
      progress : ProgressType;
      NewChar, OldChar, UpgradeChar : char;
      iTemp : integer;
      fn : filename;

   begin (* ApplyUpgrade *)
      writeln('Opening ', paramstr(1));
      reset(UpgradeFile, paramstr(1));

      ReadFileHeader(UpgradeFile);

      ReadFileName(UpgradeFile, fn);
      writeln('Reading ', fn);
      reset(OldFile, fn);

      OldSize := filesize(OldFile);

      ReadFileName(UpgradeFile, fn);
      writeln('Creating update ', fn);
      rewrite(NewFile, fn);

      ReadInteger(UpgradeFile, iTemp);
      if iTemp < 0 then
	 DisplayError('Invalid Upgrade File Size');
      NewSize := iTemp;

      OnePercent := NewSize div 100;
      if ((NewSize mod 100) <> 0) and (NewSize > 1000) then
	 inc(OnePercent);
      progress := 0;

      for i := 1 to NewSize do
	 begin
	    if OnePercent > 0 then
	       UpdateProgress(i, NewSize, OnePercent, progress);
	    read(UpgradeFile, UpgradeChar);
	    if eof(OldFile) then
	       begin
		   close(OldFile);
		   reset(OldFile)
	       end;
	    read(OldFile, OldChar);
	    NewChar := chr(ord(UpgradeChar) xor ord(OldChar));
	    write(NewFile, NewChar)
	 end;
      writeln('Upgrade done')
   end;

begin
   writeln('Irie Upgrade Utility 1.10');
   writeln('Copyright (c) 1999-2000 Stuart King. All rights reserved.');
   if paramcount = 1 then
      begin
	 CheckCRC(OldFile, UpgradeFile);
	 ApplyUpgrade(OldFile, NewFile, UpgradeFile)
      end
   else if paramcount = 4 then
      CreateUpgrade(OldFile, NewFile, UpgradeFile)
   else
      syntax
end.