(****************************************************************)
(*                     DATABASE TOOLBOX 4.0                     *)
(*     Copyright (c) 1984, 87 by Borland International, Inc.    *)
(*                                                              *)
(*                        ImportR                               *)
(*                                                              *)
(*   Purpose: ImportR translates Reflex database files into     *)
(*   Turbo Pascal Access Data files or Turbo Pascal Random      *)
(*   Access files.                                              *)
(*                                                              *)
(****************************************************************)
program ImportR;
uses DOS,
     CRT,
     MiscTool,
{    If a compiler error occurs here, you need to unpack the source
     to the MiscTool unit from the archived file Tools.arc.  See the
     README file on disk 1 for detailed instructions. }

     FileUtil,
     FieldDef,
     EditLn,
     RealConv,
     Reflex;
const
  Version = '4.00';
  CopyrightMsg = 'Copyright (C)';
  Year = '1987';
  Company = 'Borland International';
  ProgName = 'ImportR';
  Description = ' translates Reflex Database files into Turbo Access/Pascal files.';

type
  Line = string[80];
  Options =  (GenPascal, DefOnly, FindLengths);
  OptionRec = record
                OptStr : string[2];
                FlagSet : boolean;
                OptHelp : Line;
              end;
const
  ImportOptions : array[Options] of OptionRec =
    ((OptStr : '/P'; FlagSet : false;
      OptHelp : 'Generate a Turbo Pascal file of records.'),
     (OptStr : '/F'; FlagSet : false;
      OptHelp : 'Create a field definition file without translating any data.'),
     (OptStr : '/L'; FlagSet : false;
      OptHelp : 'Traverse Reflex file to find the maximum length of string fields.')
    );
{$V-}

procedure ProgramInfo;
begin
  Writeln;
  Writeln(ProgName, ' version ', Version);
  Writeln(CopyrightMsg, ' ', Year, ' ', Company);
  Writeln;
  Writeln(ProgName, Description);
  Writeln;
end;

procedure SyntaxHelp;
const
  FlagColumn = 2;
  HelpColumn = 6;
var
  CurOpt : Options;
begin
  Writeln('Syntax: ', ProgName, ' [options] ReflexFile [FieldDefFile]');
  Writeln('Options:');
  for CurOpt := GenPascal to FindLengths do
    with ImportOptions[CurOpt] do
      Writeln('':FlagColumn, OptStr, '':HelpColumn - Length(OptStr), OptHelp);
  Writeln;
end;

procedure CheckParam(CurParamStr : String;
                     var InputFileNm : FileName);
var
  CurOpt : Options;
  found : boolean;
begin
  if CurParamStr[1] <> '/' then
    InputFileNm := CurParamStr
  else
  begin
    CurOpt := GenPascal;
    found := false;
    repeat
      if CurParamStr = ImportOptions[CurOpt].OptStr then
      begin
        ImportOptions[CurOpt].flagSet := not ImportOptions[CurOpt].flagSet;
        found := true;
      end
      else
        if CurOpt < FindLengths then
          CurOpt := succ(CurOpt)
        else
          CurOpt := GenPascal;
    until found or (CurOpt = GenPascal);
  end;
end; { CheckParam }

function GetParams(var ReflexFileNm,
                       FDFileNm : FileName) : boolean;
var
  CurParamNum : integer;
  CurParamStr : string;
begin
  ReflexFileNm := '';
  FDFileNm := '';
  for CurParamNum := 1 to ParamCount do
  begin
    CurParamStr := UpCaseStr(ParamStr(CurParamNum));
    if ReflexFileNm = '' then
      CheckParam(CurParamStr, ReflexFileNm)
    else
      CheckParam(CurParamStr, FDFileNm);
  end;
  GetParams := ReflexFileNm <> '';
end; { GetParams }

function GoodStartUp(var ReflexFileNm,
                         FDFileNm : FileSpec) : boolean;
var
  StartOk : boolean;
  ReflexName,
  FDName : FileName;
begin
  ProgramInfo;
  StartOk := GetParams(ReflexName, FDName);
  if not StartOk then
    SyntaxHelp
  else
  begin
    GetFileSpec(ReflexFileNm, ReflexName);
    with ReflexFileNm do
    begin
      Ext := FileDefaults[ReflexFile].Ext;
      StartOk:= Exist(Path + Name + Ext);
    end;
    if StartOk then
    begin
      if FDName <> '' then
      begin
        GetFileSpec(FDFileNm, FDName);
        with FDFileNm do
          if Ext = '' then
            Ext := FDExt;
      end
      else
        with FDFileNm do
        begin
           Path := ReflexFileNm.Path;
           Name := ReflexFileNm.Name;
           Ext := FDExt;
        end;
    end
    else
    begin
      with ReflexFileNm do
        Writeln('Could not open the Reflex file ', Path , Name, Ext);
      Halt(1);
    end;
  end;
  GoodStartUp := StartOk;
end;


type
  StrFieldInfo = record
                   FieldNum,
                   FieldLen : integer;
                 end;

  StrLenInfo = record
                 NmStrFields : integer;
                 StrFieldNums : array[0..MaxField] of StrFieldInfo;
               end;

procedure GetStrFields(var FDTable : FieldDirectory;
                       var StrFields : StrLenInfo);
var
  CurField : integer;
begin
  with FDTable, StrFields do
  begin
    NmStrFields := 0;
    for CurField := 0 to pred(TotalFields) do
      with FieldEntries[CurField]^ do
        if (TFieldType = StringVal) and
          (XLateStatus <> ReflexFile) then
        begin
          StrFieldNums[NmStrFields].FieldNum := CurField;
          StrFieldNums[NmStrFields].FieldLen := pred(TFieldLength);
          Inc(NmStrFields);
        end;
  end;
end; { GetStrFields }


procedure FindStrLengths(var ReflexF : ReflexRef;
                         var StrFields : StrLenInfo);
type
  BytePtr = ^byte;
var
  DefaultSize : word;
  i, CurField : integer;
  TempRec,
  LenPtr : BytePtr;
begin
  with ReflexF, FDTable, StrFields do
  begin
    DefaultSize := GetPascalRecSize(FDTable);
    GetMem(TempRec, DefaultSize);
    Writeln;
    Writeln('Calculating String Lengths.  Please Wait...');
    Writeln('Reading Record:');
    for i := 0 to pred(ReflexFileLen(ReflexF)) do
    begin
      Write(succ(i):10, #13);
      GetReflexRec(ReflexF, TempRec^, i);
      for CurField := 0 to pred(NmStrFields) do
      with StrFieldNums[CurField] do
      begin
        with FieldEntries[FieldNum]^ do
          LenPtr := BytePtr(Ptr(Seg(TempRec^) , Ofs(TempRec^) + RecOffset));
        if ((LenPtr^ > FieldLen) or (FieldLen = 255)) then
          FieldLen := LenPtr^;
      end;
    end;
    Writeln;
    FreeMem(TempRec, DefaultSize);
  end;
end; { FindStrLengths }

type
  ScreenRecord = record
                   FirstOnScreen,
                   LastOnScreen : integer;
                   CurLine : integer;
                 end;

function Min(i, j : integer) : integer;
begin
  if i <= j then
    Min := i
  else
    Min := j;
end;

procedure ReadNum(var Value : integer;
                  Terminators : CharSet;
                  Min, Max : integer;
                  var TC : char);
var
  NumStr : String;
  Number,
  Code : integer;
  SaveX,
  SaveY : byte;
  OK : boolean;

begin
  Number := Value;
  SaveX := WhereX; SaveY := WhereY;
  repeat
    Str(Number:1, NumStr);
    EditLine(NumStr, 3, SaveX, SaveY, ['0'..'9'],
             Terminators, TC);
    if TC <> CR then
      Exit;
    OK := Length(NumStr) > 0;
    if OK then
    begin
      Val(NumStr, Number, Code);
      OK := Code = 0;
      if OK then
        OK := (Number >= Min) and (Number <= Max);
    end;
    if not OK then
      Beep;
  until OK;
  Value := Number;
end; { ReadNum }

const
  Terminators : CharSet = [Esc, CR, F10];

procedure EditNums(var FDTable : FieldDirectory;
                   var StrFields : StrLenInfo;
                   var    ScreenRec : ScreenRecord);
var
  i, CurLen : integer;
  TC : char;
  done : boolean;
begin
  with FDTable, StrFields, ScreenRec do
  begin
    i := 0;
    done := false;
    while (i < NmStrFields) and not done do
    begin
      with FDTable.FieldEntries[StrFieldNums[i].FieldNum]^ do
      begin
        Write(' ', FieldName, ': ');
        CurLen := StrFieldNums[i].FieldLen;
        ReadNum(CurLen, Terminators, 1, 255, TC);
        case TC of
          Esc : Abort('User terminated');
          CR, F10 : begin
                      TFieldLength := succ(CurLen);
                      if TC = F10 then
                        done := true;
                    end;
        end;
      end;
      inc(i);
      Writeln;
    end;
  end;
end; { EditNums }


function EditStrLengths(var ReflexF : ReflexRef;
                        var StrFields : StrLenInfo) : boolean;
const
  ScreenLines = 22;
var
  ScreenRec : ScreenRecord;

begin
  EditStrLengths := true;
  with ReflexF, FDTable do
  begin
    with StrFields do
      if NmStrFields > 0 then
      begin
        Writeln;
        Writeln('Edit the maximum lengths of the following string fields');
        Writeln;
        FillChar(ScreenRec, SizeOf(ScreenRec), 0);
        ScreenRec.LastOnScreen := Min(ScreenLines, NmStrFields);
        EditNums(FDTable, StrFields, ScreenRec);
      end;
  end;
end; { EditStrLengths }

function GetFileName(prompt : String;
                     var F : FileName;
                     ExistCheck: boolean) : boolean;
var
  SaveX,
  SaveY : byte;
  TC : Char;
  AllDone : boolean;

begin
  GetFileName := false;
  Write(Prompt, ' ');
  SaveX := WhereX; { Save Initial X coordinate }
  SaveY := WhereY;
  repeat
    EditLine(F, SizeOf(FileName) - 1, SaveX, SaveY,
             [#32..#127], Terminators, TC);
    case TC of
      CR : if ExistCheck then
             Alldone := Exist(F)
           else
             Alldone := true;
      Esc : Alldone := true;
    end;
    if not AllDone then
      Beep;
  until Alldone;
  GetFileName := TC <> Esc;
end; { GetFileName }

type
  TAFileHeader = record
                   FirstFree,
                   NumberFree,
                   Int1 : LongInt;
                   ItemSize   : word;
                 end;
  TADataFile = record
                 F : File;
                 TAFileHdr : TAFileHeader;
               end;

var
  PascalF : File;
  TAFile : TADataFile;
  TABuffer : ^byte;

procedure InitTAFile(RecLen : integer);
begin
  FillChar(TAFile, SizeOf(TAFile), 0);
  with TAFile, TAFileHdr do
  begin
    FirstFree := -1;
    ItemSize := RecLen;
    GetMem(TABuffer, ItemSize);
    FillChar(TABuffer^, ItemSize, 0);
    Move(TAFileHdr, TABuffer^, SizeOf(TAFileHdr));
  end;
end;

procedure MakeTADataFile(FName  : FileName;
                         RecLen : word);
var
  BlocksWritten : integer;
begin
  InitTAFile(RecLen);
  with TAFile, TAFileHdr do
  begin
    Assign(F, FName);
    Rewrite(F, 1);
    BlockWrite(F, TABuffer^, ItemSize, BlocksWritten);
    if BlocksWritten <> ItemSize then
      Abort('In MakeTADataFile Disk full error');
  end;
end; { MakeTADataFile }

procedure AddTADataRec(var Buffer);
var
  BlocksWritten : integer;
begin
  with TAFile, TAFileHdr do
  begin
    BlockWrite(TAFile.F, Buffer, ItemSize, BlocksWritten);
    if BlocksWritten <> ItemSize then
      Abort('In procedure AddTADataRec, disk full');
  end;
end;

procedure CloseTADataFile;
var
  BlocksWritten : integer;
begin
  with TAFile, TAFileHdr do
  begin
    FirstFree := -1;
    FillChar(TABuffer^, SizeOf(TABuffer^), 0);
    Move(TAFileHdr, TABuffer^, SizeOf(TAFileHdr));
    Seek(F, 0);
    BlockWrite(F, TABuffer^, ItemSize, BlocksWritten);
    if BlocksWritten = 0 then
      Abort('In CloseTADataFile, disk full');
    Close(F);
  end;
end; { CloseTADataFile }

procedure CreateOutputFile(var OutputFileNm : FileSpec;
                           RecLen : word;
                           TAccessF: boolean);
var
  FN : FileName;
begin
  ClrScr;
  ProgramInfo;
  Writeln;
  with OutputFileNm do
  begin
    if Ext = '' then
    begin
      if TAccessF then
        Ext := FileDefaults[TAccessFile].Ext
      else
        Ext := FileDefaults[PascalFile].Ext;
    end;
    FN := Path + Name + Ext;
    if TAccessF then
    begin
      if GetFileName('Turbo Access Data File:', FN, false) then
        MakeTADataFile(FN, RecLen)
      else
        Abort('User Terminated');
    end
    else
    begin
      if GetFileName('Turbo Pascal Random Access File:', FN, false) then
      begin
        Assign(PascalF, FN);
        Rewrite(PascalF, RecLen);
      end
      else
        Abort('User Terminated');
    end;
  end;
end;

var
  ReflexF : ReflexRef;
  StrFields : StrLenInfo;
  OutputFileNm : FileSpec;

procedure TransToPascal(var ReflexFileNm,
                            FDFileNm : FileSpec);
var
  GenFD,
  TAccessF : boolean;
  temp : FileName;
  PascalRecSize : word;
  PascalRec : ^byte;
  BlocksWritten, i : integer;


begin
  with ReflexFileNm do
    if OpenReflexFile(ReflexF, Path + Name + Ext) then
    begin
      GenFD := ImportOptions[DefOnly].FlagSet;
      TAccessF := not ImportOptions[GenPascal].FlagSet;
      with ReflexF, FDFileNm do
        if SetUpReflexFD(ReflexF, FDFileNm, TAccessF, not GenFD) then
        begin
          GetStrFields(FDTable, StrFields);
          if ImportOptions[FindLengths].FlagSet then
            FindStrLengths(ReflexF, StrFields);
          if EditStrLengths(ReflexF, StrFields) then
          begin
            {$ifdef FlexDebug}
            {$endif}
            PascalRecSize := GetPascalRecSize(FDTable);
            {$ifdef importDebug}
             Writeln;
             Write('After edit string lengths, Pascal record size ', PascalRecSize);
             Readln;
            {$endif}
            StoreFD(FDTable, Path + Name + Ext);
            GenPascalTypeDef(FDTable, Path + Name + TypExt);
            if (PascalRecSize > 0) and not GenFd then
            begin
              GetMem(PascalRec, PascalRecSize);
              with ReflexF.FDTable do
                if DataFileNm <> '' then
                begin
                  temp := DataFileNm;
                  GetFileSpec(OutputFileNm, temp);
                end
                else
                begin
                  OutputFileNm := ReflexFileNm;
                  OutputFileNm.Ext := '';
                end;
                {$ifdef importDebug}
                 Write('Reflex file len before = ', ReflexFileLen(ReflexF));
                 Readln;
                {$endif}
                CreateOutputFile(OutputFileNm, PascalRecSize, TAccessF);
                {$ifdef importDebug}
                 Write('After CreateOutputFile');
                 Readln;
                {$endif}

                Writeln;
                Writeln('Translating record: ');
                {$ifdef importDebug}
                 Write('Reflex file len after = ', ReflexFileLen(ReflexF));
                 Readln;
                {$endif}

                for i := 0 to pred(ReflexFileLen(ReflexF)) do
                begin
                  Write(succ(i):10, #13);
                  FillChar(PascalRec^, PascalRecSize, 0);
                  GetReflexRec(ReflexF, PascalRec^, i);
                    { Get Reflex record and convert it to a Pascal record }
                  if TAccessF then
                    AddTADataRec(PascalRec^)
                  else
                    BlockWrite(PascalF, PascalRec^, 1, BlocksWritten);
                end;
                CloseReflexFile(ReflexF);
                if TAccessF then
                  CloseTADataFile
                else
                  Close(PascalF);
            end;
          end;
        end
        else
          Abort('Field Def. file, ' + Path + Name + Ext + ' does not match the Reflex file');
    end
    else
      with ReflexFileNm do
        Abort('Could not open the Reflex file ' + Path + Name + Ext);
end; { TransToPascal }

var
  ReflexFileNm,
  FDFileNm : FileSpec;

begin
  ClrScr;
  if GoodStartUp(ReflexFileNm, FDFileNm) then
  { Get command line paramaters and check for Reflex file }
    TransToPascal(ReflexFileNm, FDFileNm)
end.
