home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
refrecov.zip
/
FLEXREC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-06-20
|
23KB
|
851 lines
{ FLEXREC.PAS
Preliminary version of a program that recovers good records from
a bad reflex file and sends them to a .PRN file. Lots of room
for improvement but it may some people some head.
6/20/86 written by Joe Schrader }
const
NameLength = 66;
MessageLen = 80;
FirstError : boolean = true;
Debug : boolean = false;
type
Message = String[MessageLen];
Address = ^byte;
long = record
LoWord,
HiWord : integer;
end;
SectionDesc = record
SectionType : integer;
SectionAddr,
SectionLen : long;
end; { SectionDesc }
{ Fixed size Reflex file header we are mainly interested in the
DfSection field which has the addresses for the other sections
of the file }
RefHeader = record
HdrSz : integer;
Stamp : array[1..12] of char;
Dirty,
VerViews,
VerModels,
VerData,
fRecalc : integer;
{ If error set fRecalc so that Reflex will recalculate }
ScreenType,
CheckSum : byte;
Reserved : array[1..38] of byte;
SectionCt : integer;
DfSection : array[1..44] of SectionDesc;
buffer : real;
end; { RefHeader }
type
VarLenBuf = record { represents a variable length buffer }
Len : integer; { length of the buffer }
Buf : ^byte; { pointer to the buffer, use GetMem }
end;
FileName = String[66];
Str255 = String[255];
ErrorStr = String[80];
const
DataOk : boolean = true;
DataReals : boolean = true;
var
DataErrorStr : ErrorStr;
InFile : file;
OutFile, ErrorFile : text;
procedure DataError(Error : ErrorStr);
begin
DataOk := false;
DataErrorStr := Error;
end; { DataError }
procedure LongToReal(L : Long; var R : real);
begin
with L do
begin
R := (65536.0 * HiWord);
if LoWord < 0 then
R := R + 65536.0 + LoWord
else
R := R + LoWord;
end;
end; { LongToReal }
procedure QuitProgram(M : Message);
begin
Write(^G, M );
Close(OutFile);
Close(ErrorFile);
Halt;
end; { QuitProgram }
procedure ReadBuffer(var InFile : File;
var B : VarLenBuf);
var
RecsRead : integer;
begin
with B do
begin
BlockRead(InFile, Len, 2, RecsRead);
GetMem(Buf, Len);
BlockRead(InFile, Buf^, Len, RecsRead);
if RecsRead <> Len then
if LongFileSize(InFile) = LongFilePos(InFile) then
QuitProgram('We are prematurely at the the end of the file');
end;
end; { ReadBuffer }
procedure GetText(FieldNameText : VarLenBuf;
Offset : integer;
var T : Str255);
{ Gets a null terminated string of text from the
at the specified offset in a variable length buffer }
var
CurByte : byte;
begin
T := '';
with FieldNameText do
repeat
CurByte := Mem[Seg(Buf^):Ofs(Buf^) + Offset];
if CurByte <> 0 then
T := T + Chr(CurByte);
Offset := Offset + 1;
until (CurByte = 0) or (Offset > Len) or (Length(T) = 255);
end; { GetText }
procedure NameError(StartX, Width : integer);
begin
Write( ^G);
GotoXY(StartX, WhereY);
Write(' ':Width);
GotoXY(StartX, WhereY);
end; { NameError }
procedure StripExt(var F : FileName);
{ Strips of the file extension, including the '.' }
var
Dot : byte;
begin
Dot := Pos('.', F);
if Dot > 0 then
Delete(F, Dot, Length(F) - Dot + 1);
for Dot := 1 to Length(F) do
F[Dot] := UpCase(F[Dot]);
end; { StripExt }
procedure OpenReflexFile(var ReflexFile : file; var OutFile : text);
var
StartX : byte;
Ok : boolean;
RefFileNm : FileName;
begin
Write('Enter the name of the Reflex data file: ');
StartX := WhereX;
repeat
BufLen := NameLength;
Read(RefFileNm);
Ok := Length(RefFileNm) > 0;
if Ok then
begin
Assign(ReflexFile, RefFileNm);
{$I-}
Reset(ReflexFile, 1);
Ok := (IOresult = 0);
end;
if not Ok then
NameError(StartX, Length(RefFileNm));
until Ok;
{$I+}
StripExt(RefFileNm);
Assign(OutFile, RefFileNm + '.PRN');
Writeln;
Writeln('Outputting to file ', RefFileNm + '.PRN');
Rewrite(OutFile);
Writeln('Outputting errors to ', RefFileNm + '.ERR');
Assign(ErrorFile, RefFileNm + '.ERR');
Rewrite(ErrorFile);
Writeln(ErrorFile, 'Diagnostic Summary of ', RefFileNm + '.RXD');
Writeln(ErrorFile);
end; { OpenReflexFile }
type
SectionNames = (FieldDir, MasterRec, DataRecs, GFilter, GMode,
OverVec, ViewState, ViewScale, FormView, ListView,
CrossTab, GraphView);
const
Sections : array[SectionNames] of byte =
(2,9,1,17,11,21,5,24,12,13,14,15);
procedure ReadHeader(var InFile : File;
var Header : RefHeader);
var
BlocksRead : integer;
begin
FillChar(Header,SizeOf(Header),0);
BlockRead(InFile, Header, SizeOf(Header), BlocksRead);
if BlocksRead <> SizeOf(Header) then
QuitProgram('The Reflex File Header is the wrong size');
end; { ReadHeader }
procedure GetSectionAddr(var Header : RefHeader;
CurSection : SectionNames;
var SecAddr,
SecLen : real);
var
i : integer;
SectionFound : boolean;
begin
with Header do
begin
i := 1;
repeat
SectionFound := (DfSection[i].SectionType = Sections[CurSection]);
if SectionFound then
begin
LongToReal(DfSection[i].SectionAddr, SecAddr);
LongToReal(DfSection[i].SectionLen, SecLen);
end;
i := i + 1;
until (i > SectionCt) or SectionFound;
if not SectionFound then
QuitProgram('No section found');
end;
end; { CheckSectionDesc }
var
NumRecs : integer;
Header : RefHeader;
FieldNameIndex,
FieldNameText,
FieldDirectory : VarLenBuf;
DataAddr : real;
procedure SkipSortInfo(var InFile : File);
const
SortSize = 12;
var
SortInfo : array[1..SortSize] of byte;
RecsRead : integer;
begin
BlockRead(InFile, SortInfo, SizeOf(SortInfo), RecsRead);
end; { SkipSortInfo }
procedure BuildFieldNameTbls(var InFile : File);
begin
SkipSortInfo(InFile);
ReadBuffer(InFile, FieldNameIndex);
ReadBuffer(InFile, FieldNameText);
ReadBuffer(InFile, FieldDirectory);
end; { BuildFieldNameTbls }
const
MaxField = 249;
Untyped = 0; { Temporary }
LocalText = 1;
RepText = 2;
Date = 3;
Numeric = 4;
IntVal = 5;
type
ETRec = record
Index,
Pool : long;
end;
DescPtr = ^FieldDesc;
FieldDesc = record
NameOffset : integer;
DataType : byte;
PrecForm : byte;
FieldOffset : integer;
Etr : ETRec;
(* IsDescending, *)
SortPos,
Reserved : byte;
end;
FieldDescTbl = array[0..MaxField] of DescPtr;
RepTPool = ^TextPool;
TextPool = record
FIDNum : byte;
PoolIndex,
Pool : VarLenBuf;
Next : RepTPool;
end;
const
DataFields : array[UnTyped..IntVal] of String[20] =
('Untyped', 'Text', 'Repeating Text',
'Date', 'Numeric', 'Integer');
var
FieldDescriptors : FieldDescTbl;
RepTextPool : RepTPool;
procedure GetFieldDesc(FieldDirectory : VarLenBuf;
FieldNum : integer;
var CurField : FieldDesc);
var
Start, Offset : integer;
begin
Start := FieldNum * SizeOf(CurField);
with FieldDirectory do
for OffSet := 0 to SizeOf(CurField) - 1 do
begin
Mem[Seg(CurField):Ofs(CurField) + Offset] :=
Mem[Seg(Buf^):Ofs(Buf^) + Start + Offset];
end; { for }
end; { GetFieldDesc }
procedure AddPool(var RepTextPool : RepTPool;
var T : TextPool);
var
P : RepTPool;
begin
New(P);
P^ := T;
if RepTextPool <> nil then
P^.next := RepTextPool;
RepTextPool := P;
end; { AddPool }
procedure BuildRepTextPool(var InFile : File;
var FieldDescriptors : FieldDescTbl;
FieldCount : byte);
var
CurPool : TextPool;
begin
for FieldCount := FieldCount downto 0 do
with FieldDescriptors[FieldCount]^, CurPool do
if FieldDescriptors[FieldCount]^.DataType = RepText then
begin
FIDNum := FieldCount;
ReadBuffer(InFile, PoolIndex);
ReadBuffer(InFile, Pool);
Next := nil;
AddPool(RepTextPool, CurPool);
end;
end; { BuildRepTextPool }
procedure BuildFieldDescTbl(var InFile : File;
var FieldDirectory : VarLenBuf;
FieldCount : byte);
const
SkipSize = 6;
var
CurDesc : 0..MaxField;
CurField : FieldDesc;
begin
for CurDesc := 0 to MaxField do
FieldDescriptors[CurDesc] := nil;
for CurDesc := 0 to (FieldCount - 1) do
begin
New(FieldDescriptors[CurDesc]);
GetFieldDesc(FieldDirectory, CurDesc, CurField);
FieldDescriptors[CurDesc]^ := CurField;
end;
LongSeek(InFile, FilePos(InFile) + SkipSize);
BuildRepTextPool(InFile, FieldDescriptors, FieldCount - 1);
end; { BuildFieldDescTbl }
procedure OutputFieldNames(var OutFile : text;
FieldCount : integer;
var FieldNameText : VarLenBuf);
var
NmFields,
StartText : integer;
FieldName : Str255;
begin
if Debug then
begin
Writeln;
Writeln( 'The number of fields is ', FieldCount);
end;
for NmFields := 0 to FieldCount - 1 do
with FieldDescriptors[NmFields]^ do
begin
GetText(FieldNameText, NameOffset, FieldName);
Write(OutFile, '"',FieldName, '",');
end;
Writeln(OutFile);
end; { OutputFieldNames }
procedure OutputFieldTypes(var ErrorFile : text;
FieldCount : integer;
var FieldNameText : VarLenBuf);
var
NmFields,
StartText : integer;
FieldName : Str255;
begin
Writeln(ErrorFile);
Writeln(ErrorFile, 'The number of fields is ', FieldCount);
for NmFields := 0 to FieldCount - 1 do
with FieldDescriptors[NmFields]^ do
begin
GetText(FieldNameText, NameOffset, FieldName);
Writeln(ErrorFile, '"',FieldName, '" : ', DataFields[DataType]);
end;
end; { OutputFieldTypes }
procedure LoadFieldDir(var InFile : File; var OutFile : text;
var Header : RefHeader);
var
FieldDirAddr, FieldDirLen : real;
begin
GetSectionAddr(Header, FieldDir, FieldDirAddr, FieldDirLen);
Writeln(ErrorFile, 'The address of the field directory is ', FieldDirAddr:1:0);
Writeln(ErrorFile, 'Field directory length is ', FieldDirLen:1:0);
LongSeek(InFile, FieldDirAddr);
BuildFieldNameTbls(InFile);
BuildFieldDescTbl(InFile, FieldDirectory, Lo(FieldNameIndex.Len div 2));
OutputFieldNames(OutFile, FieldNameIndex.Len div 2, FieldNameText);
OutputFieldTypes(ErrorFile, FieldNameIndex.Len div 2, FieldNameText);
end;
type
ieee = array[1..8] of byte;
turbo_real = array[1..6] of byte;
mant = array[1..5] of byte;
procedure IEEEtoTurbo(long : ieee; var r : real);
{ Convert from IEEE to Turbo Pascal's 6-byte real format }
var
i : integer;
e : byte;
t : turbo_real absolute r;
sign : byte;
begin
{ initialize variables }
r := 0.0;
for i := 2 to 5 do
t[i] := 0;
i := (long[8] and $7f) shl 4; { get 7 highest bits of exponent }
i := i or ((long[7] and $f0) shr 4);{ get rest of exponent }
(*
if (i < 985) or (i > 1061) then { check to make sure exponent }
begin { is in legal range }
Writeln(ErrorFile);
Writeln(ErrorFile, 'exponent too large');
exit;
end;
*)
i := i - 1023; { take out bias }
t[1] := i + $81; { put in new bias }
sign := long[8] and $80; { get sign bit }
{ build up most significant byte }
t[6] := sign + ((long[7] and $0f) shl 3) or ((long[6] and $e0) shr 5);
{make rest of real number in groups of 5 and 3 }
for i := 5 downto 2 do
t[i] := ((long[i+1] and $1f) shl 3) or ((long[i] and $e0) shr 5);
end; { IEEEtoTurbo }
function floor(x : real): real;
begin
if (x < 0) and (frac(x) <> 0) then
floor := int(X) - 1.0
else
floor := int(X);
end; { floor }
procedure CalDate(date : real; var year, month, day : integer);
var
a,aa,b,c,d,e,z : real;
y : integer;
begin
z := int(date + 2444239.0);
if date < -145078.0 then
a := z
else
begin
aa := floor((z-1867216.25)/36524.25);
a := z + 1 + aa - floor(aa/4.0);
end;
b := a + 1524.0;
c := int((b - 122.1)/365.25);
d := int(365.25*c);
e := int((b-d)/30.6001);
day := trunc(b - d - int(30.6001 * e));
if e > 13.5 then month := trunc(e - 13.0)
else month := trunc(e - 1.0);
if month > 2 then y := trunc(c - 4716.0)
else y := trunc(c - 4715.0);
if y < 1 then year := y - 1
else year := y;
end; { CalDate }
const
MonthNames : array[1..12] of string[20] =
('January', 'Febuary', 'March', 'April', 'May', 'June', 'July',
'August', 'September', 'October', 'November', 'December');
procedure WriteDate(var OutFile : text; Date : real);
var
Year, Month, Day : integer;
begin
CalDate(Date, Year, Month, Day);
Write(OutFile, Month, '/',Day + 1, '/',Year - 80);
end; { WriteDate }
procedure WriteMonthYear(var OutFile : text; Date : real);
var
Year, Month, Day : integer;
begin
Date := Date + 1;
CalDate(Date, Year, Month, Day);
Write(OutFile, Month, '/',Day + 1, '/', Year - 80);
end; { WriteMonthYear }
procedure GetNumRecs(var InFile : File; var NumRecs : integer);
var
MasterRecord : record
Num,
Filter : integer;
end;
MasterAddr, MasterLen : real;
begin
GetSectionAddr(Header, MasterRec, MasterAddr, MasterLen);
Writeln(ErrorFile);
Writeln(ErrorFile, 'Master record address: ', MasterAddr:1:0);
LongSeek(InFile, MasterAddr);
BlockRead(InFile, MasterRecord, SizeOf(MasterRecord), NumRecs);
NumRecs := MasterRecord.Num;
Writeln(ErrorFile);
Writeln(ErrorFile, 'The number of records is ', NumRecs);
end; { GetNumRecs }
type
RecHdr = record
temp : array[1..3] of byte;
CtFlds : byte;
end;
procedure GetFieldCount(var RecBuf : VarLenBuf;
var FieldCount : byte);
var
CurRec : RecHdr;
begin
with RecBuf, CurRec do
begin
Move(Buf^, CurRec, SizeOf(CurRec));
FieldCount := CtFlds;
end;
end; { GetFieldCount }
procedure DisplayLocText(var OutFile : text;
var RecBuf : VarLenBuf;
var Offset : integer);
var
TextPos : integer;
LocalText : Str255;
temp : byte;
begin
with RecBuf do
begin
TextPos := MemW[Seg(Buf^):Ofs(Buf^) + Offset];
Offset := Offset + 2; { Move the offset to the next field }
GetText(RecBuf, TextPos, LocalText);
for temp := 1 to length(LocalText) do (* temporary *)
begin
if not (ord(LocalText[temp]) in [32..127]) then
LocalText[temp] := ' ';
end;
if Length(LocalText) > 0 then
Write(OutFile, '"',LocalText, '"')
else
Write(OutFile, '""');
end;
end; { DisplayLocText }
procedure GetPool(var CurPool : RepTPool;
FieldNum : integer;
var PoolFound : boolean);
begin
PoolFound := false;
while (CurPool <> nil) and not PoolFound do
with CurPool^ do
begin
PoolFound := (FIDNum = FieldNum);
if not PoolFound then
CurPool := CurPool^.Next
end;
end; { GetPool }
procedure GetRepText(FieldNum, TextPos : integer;
var RepText : Str255);
var
CurPool : RepTPool;
PoolFound : boolean;
i : integer;
begin
CurPool := RepTextPool;
GetPool(CurPool, FieldNum, PoolFound);
if PoolFound then
begin
GetText(CurPool^.Pool, TextPos, RepText);
for i := 1 to Length(RepText) do { temporary }
if not (ord(RepText[i]) in [32..127]) then
begin
RepText := '';
Exit;
end;
end
else
RepText := '';
end; { GetRepText }
procedure OutputRepTextpool(var ErrorFile : Text;
var RepTextPool : RepTPool);
var
Traverse : RepTPool;
Offset, i, temp : integer;
RepText : Str255;
begin
Traverse := RepTextPool;
Writeln(ErrorFile);
Writeln(ErrorFile, 'The repeating text pool: ');
Writeln(ErrorFile);
while Traverse <> nil do
with Traverse^ do
begin
Writeln(ErrorFile, 'Field number ', FIDNum);
Offset := 0;
for i := 1 to PoolIndex.Len do
begin
temp := MemW[Seg(PoolIndex.Buf^):Ofs(PoolIndex.Buf^) + Offset];
Write(ErrorFile, 'Text offset: ', temp);
GetRepText(FIDNum, temp, RepText);
Offset := Offset + 2;
Writeln(ErrorFile, ' "',RepText,'"');
end;
Writeln(ErrorFile);
Traverse := next;
end;
end; { OutputRepTextPool }
{$I VERIFY.INC}
procedure DisplayRepText(var OutFile : text;
var RecBuf : VarLenBuf;
FieldNum : byte;
var Offset : integer);
var
TextPos : integer;
RepText : Str255;
begin
with RecBuf do
begin
TextPos := MemW[Seg(Buf^):Ofs(Buf^) + Offset];
Offset := Offset + 2; { Move the offset to the next field }
GetRepText(FieldNum, TextPos, RepText);
if Length(RepText) > 0 then
Write(OutFile, '"',RepText,'"')
else
Write(OutFile, '""');
end;
end; { DisplayRepText }
procedure DisplayInteger(var OutFile : text;
var RecBuf : VarLenBuf;
var Offset : integer);
begin
with RecBuf do
Write(OutFile, MemW[Seg(Buf^):Ofs(Buf^) + Offset]);
Offset := Offset + 2;
end; { DisplayInteger }
procedure DisplayDate(var OutFile : text;
var RecBuf : VarLenBuf;
var Offset : integer;
form : byte);
var
r : real;
i : integer;
begin
with RecBuf do
begin
i := MemW[Seg(Buf^):Ofs(Buf^) + Offset];
r := abs(i);
if Form = 4 then
WriteMonthYear(OutFile, r)
else
WriteDate(OutFile, r);
end;
Offset := Offset + 2;
end; { DisplayDate }
procedure DisplayReal(var OutFile : text;
var RecBuf : VarLenBuf;
var Offset : integer);
const
Prec = 4;
var
TempReal : real; { temporary representation of real number }
TempIEEE : IEEE;
begin
with RecBuf do
begin
Move(Mem[Seg(Buf^) : Ofs(Buf^) + Offset], TempIEEE, SizeOf(TempIEEE));
IEEEtoTurbo(TempIEEE, TempReal);
Write(OutFile,TempReal:1:Prec);
Offset := Offset + 8;
end;
end; { DisplayReal }
procedure DisplayField(var OutFile : text;
var RecBuf : VarLenBuf;
FieldCount : byte;
var Offset : integer);
var
Form : byte;
FieldName : Str255;
begin
with RecBuf, FieldDescriptors[FieldCount]^ do
begin
GetText(FieldNameText, NameOffset, FieldName);
case DataType of
UnTyped : Writeln(OutFile, '""'); { Add change of offset }
LocalText : DisplayLocText(OutFile, RecBuf, Offset);
RepText : DisplayRepText(OutFile, RecBuf, FieldCount, Offset);
Date : begin
Form := lo(PrecForm) and $07;
DisplayDate(OutFile, RecBuf, Offset, Form);
end;
IntVal : DisplayInteger(OutFile, RecBuf, Offset);
Numeric : DisplayReal(OutFile, RecBuf, Offset);
end;
end;
end; { DisplayField }
procedure DisplayDataRecord(var OutFile : text;
var RecBuf : VarLenBuf);
var
FieldCount : byte;
Offset : integer;
begin
GetFieldCount(RecBuf, FieldCount);
Offset := 4;
for FieldCount := 0 to (FieldCount - 1) do
begin
DisplayField(OutFile, RecBuf, FieldCount, Offset);
Write(OutFile, ',');
end;
Writeln(OutFile);
end; { DisplayDataRecord }
procedure ReadDataRec(var InFile : File; var OutFile : text;
CurRec : integer);
var
RecBuf : VarLenBuf;
Verified : TestRec;
Abort : boolean;
begin
ReadBuffer(InFile, RecBuf);
with RecBuf, Verified do
begin
failed := false;
VerifyDataRecord(RecBuf, Verified);
if Failed then
begin
Writeln(ErrorFile, 'Recovery ERROR in record ',CurRec, ' : ', Reason);
Write(ErrorFile, 'Portion recoverd...');
DisplayDataRecord(ErrorFile, RecBuf);
if FirstError then
begin
FirstError := false;
ErrorPrompt(CurRec, Abort);
if Abort then
QuitProgram('User interrupt');
end;
end
else
DisplayDataRecord(OutFile, RecBuf);
FreeMem(Buf, Len);
end;
end; { ReadDataRec }
procedure SeekFirstRec(var InFile : File; var DataAddr : real);
var
First : integer;
DataLen : real;
begin
GetSectionAddr(Header, DataRecs, DataAddr, DataLen);
Writeln(ErrorFile, 'The address of the data records section is: ', DataAddr:1:0);
Writeln(ErrorFile, 'The length of the section is: ', DataLen:1:0);
Writeln(ErrorFile);
Writeln(ErrorFile, 'ERRORS to follow');
Writeln(ErrorFile);
LongSeek(InFile, DataAddr);
BlockRead(InFile, First, SizeOf(First));
end; { SeekFirstRec }
procedure ReadDataRecords(var InFile : File;
var OutFile : text;
var DataAddr : real;
NumRecs : integer);
var
RecsRead,
CurRec : integer;
begin
GetNumRecs(InFile, NumRecs);
Writeln;
Writeln;
Writeln('The number of records is ', NumRecs);
Writeln;
SeekFirstRec(InFile, DataAddr);
for CurRec := 1 to NumRecs do
begin
Write('Current record ', CurRec , #13);
ReadDataRec(InFile, OutFile, CurRec);
end;
end; { ReadDataRecords }
procedure SetUp(var InFile : File; var OutFile : text);
begin
RepTextPool := nil;
OpenReflexFile(InFile, OutFile);
ReadHeader(InFile, Header);
LoadFieldDir(InFile, OutFile, Header);
end; { SetUp }
begin
SetUp(InFile, OutFile);
ReadDataRecords(InFile, OutFile, DataAddr, NumRecs);
Close(OutFile);
Close(ErrorFile);
if FirstError then { if no errors occurred we can delete the error file }
begin
Writeln;
Writeln('No errors detected');
end
end.