Liren Large Software Subsidy 9/09.iso/l/l041/2.ddi/REFLEX.ARC/BUILDKEY.PAS

Pascal/Delphi Source File | 1987-12-31 | 7.4 KB | 272 lines

(****************************************************************)
(*                     DATABASE TOOLBOX 4.0                     *)
(*     Copyright (c) 1984, 87 by Borland International, Inc.    *)
(*                                                              *)
(*     Purpose:   Builds index files from .DAT files and .FD    *)
(*                file specs                                    *)
(*                                                              *)
(****************************************************************)
program BuildKey;
uses DOS,
     CRT,
     TAccess,
{    If a compiler error occurs here, the Turbo Pascal compiler cannot
     find the TAccess unit.  You can compile and configure the TAccess
     unit for your database project by using the TABuild utility. See
     the manual for detailed instructions. }

     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,
     EditLn,
     FieldDef;
{$V-}
{ $define debug}
const
  ProgName = 'BuildKey';
  Version = '4.00';
  CopyrightMsg = 'Copyright (C)';
  Year = '1987';
  Company = 'Borland International';
  Description = ' creates Turbo Access Index file(s) from a TA data file';

type
  LongIntPtr = ^LongInt;
  IndexFilePtr = ^IndexFile;
  BuildInfoRec = record
                   FD : FieldDirectory;
                   DatF : DataFile;
                   DataRec : Pointer;
                   CurRecNum : LongInt;
                   Indexes : array[0..MaxKeys] of IndexFilePtr;
                 end;
var
  DefFileNm : FileSpec;
  InputFileNm : FileName;
  BuildInfo : BuildInfoRec;

  FD : FieldDirectory;
  DatF : DataFile;

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

const
  FileChars : CharSet = [#32..#127];
  Terminators : CharSet = [CR, Esc];

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,
             FileChars, 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;
  Writeln;
end; { GetFileName }

procedure OpenDataBase(var BuildInfo : BuildInfoRec;
                       FileNm : FileName);
var
  CurIndexF : integer;
begin
  with BuildInfo, FD do
  begin
    Writeln;
    if not GetFileName('Turbo Access data file:', FileNm, true) then
      Abort('User Terminated')
    else
      Writeln;
    OpenFile(DatF, FileNm, GetPascalRecSize(FD));
    if not Ok then
      Abort('Could not open Turbo Access data file: '+ FileNm);
    GetMem(DataRec, RecordSize);
    for CurIndexF := 0 to pred(NumberOfKeys) do
    begin
      new(Indexes[CurIndexF]);
      with KeyEntries[CurIndexF]^ do
      begin
        if IndexFileNm = '' then
          IndexFileNm := Copy(KeyName, 1, 8) + '.IDX';
        if not GetFileName(KeyName + ' index file:', IndexFileNm, false) then
          Abort('User Terminated');
        MakeIndex(Indexes[CurIndexF]^, IndexFileNm, pred(Size), Status);
        if not Ok then
          Abort('Could not create Turbo Access index file: ' + IndexFileNm);
       end;
    end;
  end;
end;  { OpenDatabase }

procedure CloseDatabase(var BuildInfo : BuildInfoRec);
var
  CurIndexF : integer;
begin
  with BuildInfo, FD do
  begin
    CloseFile(DatF);
    for CurIndexF := 0 to pred(NumberOfKeys) do
      CloseIndex(Indexes[CurIndexF]^);
  end;
end; { CloseDatabase }

function Min(x, y : integer) : integer;
begin
  if x < y then
    Min := x
  else
    Min := y;
end; { Min }

procedure RebuildKeys(var BuildInfo : BuildInfoRec);
type
  StringPtr = ^String;
  BytePtr = ^byte;
var
  Key,
  SubKeyStr : String;
  CurSubKey : integer;
  MaxBytes : integer;
  LenPtr : BytePtr;
  StrPtr : StringPtr;
  CurIndexF : integer;
  RecOffset : integer;

begin
  with BuildInfo, FD do
  begin
  {$IFDEF DEBUG}
  Writeln('Current Record : ', CurRecNum);
  {$ENDIF}
    for CurIndexF := 0 to pred(NumberOfKeys) do
    with KeyEntries[CurIndexF]^ do
    begin
      Key := '';
      for CurSubKey := 0 to pred(NumSubKeys) do
      with SubKeys[CurSubKey] do
      begin
        SubKeyStr := '';
        MaxBytes := Min(pred(Size), NumBytes);
        (* Dec(MaxBytes, Length(Key)); *)
        with FieldEntries[FieldNum]^ do
          LenPtr := BytePtr(Ptr(Seg(DataRec^) , Ofs(DataRec^) + RecOffset));
        {$IFDEF DEBUG}
        Write('Length of Str: ', LenPtr^);
        Readln;
        {$ENDIF}
        MaxBytes := Min(MaxBytes, LenPtr^);
        StrPtr := StringPtr(succ(LongInt(LenPtr)));
        {$IFDEF DEBUG}
        Write('Max Bytes: ', MaxBytes);
        Readln;
        {$ENDIF}
        Move(StrPtr^, SubKeyStr[1], MaxBytes);
        Length(SubKeyStr) := MaxBytes;
        SubKeyStr := UpCaseStr(SubKeyStr);
        {$IFDEF DEBUG}
        Write('Current SubKey : ', SubKeyStr);
        Readln;
        {$ENDIF}
        Key := Key + SubKeyStr;
      end;
      {$IFDEF DEBUG}
      Write('Current Key ', Key);
      Readln;
      {$ENDIF}
      AddKey(Indexes[CurIndexF]^, CurRecNum, Key);
      if not Ok then
        Abort('Error adding key ' + Key);
    end;
  end;
end; { RebuildKeys }

procedure Rebuild(var DefFileNm : FileName);
var
  CurRec : LongInt;
  DefFileSpec,
  DataFName : FileSpec;

begin
  GetFileSpec(DefFileSpec, DefFileNm);
  with DefFileSpec do
  begin
    if (Ext = '') and not (Name = '') then
      Ext := FDExt;
     DefFileNm := Path + Name + Ext;
     if not GetFileName('Field definition file:', DefFileNm, true) then
       Abort('Could not open ' + Path + Name + Ext)
     else
       with BuildInfo do
      begin
        LoadFD(FD, DefFileNm);
        GetFileSpec(DefFileSpec, DefFileNm);
        with FD, DataFName do
        begin
          if DataFileNm <> '' then
          begin
            GetFileSpec(DataFName, DataFileNm);
            if Path = '' then
              Path := DefFileSpec.Path;
          end
          else
          begin
            DataFName := DefFileSpec;
            Ext := '';
          end;
          if Ext = '' then
            Ext := FileDefaults[TAccessFile].Ext;
          OpenDatabase(BuildInfo, Path + Name + Ext);
        end;
        Writeln('Building keys: ');
        for CurRecNum := 1 to pred(FileLen(DatF)) do
        begin
          GetRec(DatF, CurRecNum, DataRec^);
          Write(CurRecNum:10, #13);
          if LongIntPtr(DataRec)^ = 0 then
            RebuildKeys(BuildInfo);
        end;
        Writeln;
        CloseDatabase(BuildInfo);
      end;
    end;
end; { Rebuild }

begin
  ProgramInfo;
  if ParamCount = 0 then
    InputFileNm := ''
  else
    InputFileNm := ParamStr(1);
  Rebuild(InputFileNm);
end.