Паскаль / do9 / iriepas201 / Irie Pascal / upgrade

(* 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.01');
writeln('Copyright (c) 1999 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.