Unit GS_dB3Wk;
interface

Function GS_dB3_Create(fName : string) : boolean;

implementation
uses
   CRT,
   DOS,
   GS_FileH,
   GS_KeyI,
   GS_Wind,
   GS_Strng,
   GS_dBase;

CONST
   EofMark     : Byte = $1A;          {Byte to indicate end of file}
   EohMark     : Byte = $0D;          {Byte stored at end of the header}
   dB3File     : Byte = $03;
   dB3WithMemo : Byte = $83;

type
   FldRecPtr   = ^FldRecTyp;
   FldRecTyp   = array[1..GS_dBase_MaxRecField] of GS_dBase_Field;

var
   FileWin,
   StatWin  : GS_Wind_Objt;
   InputStr       : GS_KeyI_Objt;
   FCnt,
   LCnt,
   PCnt,
   BeginFPos      : integer;
   EndFPos        : integer;
   FldRec         : FldRecPtr;
   dFile          : file;
   HeadRec        : GS_dBase_Head;
   FileName       : string;
   rsl,
   yy, mm, dd, wd : word;             {Variables to hold GetDate values}
   rl, i          : integer;          {Working variables}

function Quit_Keys : boolean;
begin
   if (GS_KeyI_Esc) or (GS_KeyI_Chr = Kbd_CEnd) then Quit_Keys := true
      else Quit_Keys := false;
end;

procedure WriteXYString(x,y,l : integer; s : string);
begin
   GoToXY(x,y);
   write(s,'':l-length(s));
end;

procedure WriteXYInteger(x,y,l,v : integer);
begin
   GoToXY(x,y);
   write(v:l);
end;


procedure ShowFields;
var
   i,j : integer;
   y : integer;
   s : string;
   c : char;
   v : byte;
begin
   if PCnt > FCnt then
   begin
      FillChar(FldRec^[PCnt],32,#0);
      FldRec^[PCnt].FieldType := 'C';
   end;
   if FCnt = 0 then exit;
   ClrScr;
   if FCnt < EndFPos then j := FCnt else j := EndFPos;
   j := pred(BeginFPos+j);
   y := 0;
   for i := BeginFPos to j do
   begin
      inc(y);
      WriteXYInteger(2,y,3,i);
      CnvAscToStr(FldRec^[i].FieldName,s,11);
      WriteXYString(8,y,10,s);
      move(FldRec^[i].FieldType,c,1);
      case c of
         'C' : s := 'Character';
         'D' : s := 'Date';
         'L' : s := 'Logical';
         'N' : s := 'Numeric';
         'M' : s := 'Memo';
      end;
      WriteXYString(20,y,12,s);
      move(FldRec^[i].FieldLen,v,1);
      WriteXYInteger(33,y,6,v);
      if c = 'N' then
      begin
         move(FldRec^[i].FieldDec,v,1);
         WriteXYInteger(43,y,8,v);
      end;
   end;
end;


function UpDateFields : boolean;
var
   i,
   x,
   y  : integer;
   t  : string;
   c  : char;
   v  : byte;

   procedure Get_Name;
   var
      i : integer;
      s : string;
      b : boolean;
   begin
      GS_Wind_SetIvMode;
      CnvAscToStr(FldRec^[PCnt].FieldName,t,11);
      t := TrimR(t);
      repeat
         b := true;
         t := InputStr.EditString(t,8,y,10);
         if (Quit_Keys) then exit;
         t := AllCaps(t);
         s := TrimR(t);
         if s = '' then b := false
         else
         begin
            for i := 1 to FCnt do
            begin
               CnvAscToStr(FldRec^[i].FieldName,s,11);
               if (s = t) and (PCnt <> i) then b := false;
            end;
         end;
         if (GS_KeyI_Chr in [Kbd_UpAr,Kbd_DnAr]) and (t = '') then b := true;
         if not b then SoundBell(BeepTime, BeepFreq);
      until (b) or ((PCnt = FCnt) and (GS_KeyI_Chr = Kbd_UpAr));
      GS_Wind_SetNmMode;
      WriteXYString(8,y,10,t);
      CnvStrToAsc(t,FldRec^[PCnt].FieldName,11);
   end;

   procedure Get_Type;
   begin
      WriteXYString(20,y,11,'C,D,L,M,N:');
      GS_Wind_SetIvMode;
      c := '?';
      repeat
         if c <> '?' then SoundBell(BeepTime, BeepFreq);
         if PCnt <= FCnt then
            move(FldRec^[PCnt].FieldType,c,1)
         else c := 'C';
         t := c;
         t := InputStr.EditString(t,31,y,1);
         if Quit_Keys then exit;
         if length(t) > 0 then c := t[1] else c := ' ';
         c := upcase(c);
      until c in ['C','D','L','M','N'];
      GS_Wind_SetNmMode;
      case c of
         'C' : t := 'Character';
         'D' : t := 'Date';
         'L' : t := 'Logical';
         'N' : t := 'Numeric';
         'M' : t := 'Memo';
      end;
      WriteXYString(20,y,12,t);
      if c <> 'N' then ClrEol;
      move(c,FldRec^[PCnt].FieldType,1);
   end;

   procedure Get_Length;
   begin
      if c in ['D','L','M'] then
      begin
         if c = 'D' then v := 8
            else if c = 'L' then v := 1
               else v := 10;
      end
      else
      begin
         GS_Wind_SetIvMode;
         x := 0;
         v := 0;
         repeat
            if x <> 0 then SoundBell(BeepTime, BeepFreq);
            move(FldRec^[PCnt].FieldLen,v,1);
            str(v:6,t);
            t := InputStr.EditString(t,33,y,6);
            if Quit_Keys then exit;
            val(t,v,x);
            if v <= 0 then x := 1;
            if v > 255 then x := 1;
         until x = 0;
         GS_Wind_SetNmMode;
      end;
      WriteXYInteger(33,y,6,v);
      move(v,FldRec^[PCnt].FieldLen,1);
   end;

   procedure Get_Decimal;
   begin
      v := 0;
      GS_KeyI_Chr := Kbd_Ret;
      if c = 'N' then
      begin
         GS_Wind_SetIvMode;
         x := 0;
         repeat
            if x <> 0 then SoundBell(BeepTime, BeepFreq);
            move(FldRec^[PCnt].FieldDec,v,1);
            str(v:8,t);
            t := InputStr.EditString(t,43,y,8);
            if Quit_Keys then exit;
            val(t,v,x);
            if v < 0 then x := 1;
            if v > pred(FldRec^[PCnt].FieldLen) then x := 1;
         until x = 0;
         GS_Wind_SetNmMode;
         WriteXYInteger(43,y,8,v);
      end;
      move(v,FldRec^[PCnt].FieldDec,1);
   end;

begin
   PCnt :=succ(FCnt);
   ShowFields;
   repeat
      LCnt := 0;
      repeat
         y := succ(PCnt-BeginFPos);
         case LCnt of
           0 : begin
                  gotoxy(2,y);
                  write(PCnt:3);
                  GS_KeyI_Chr := ' ';
                  if PCnt > FCnt then
                  begin
                     FillChar(FldRec^[PCnt],32,#0);
                     FldRec^[PCnt].FieldType := 'C';
                  end;
               end;
           1 : Get_Name;
           2 : Get_Type;
           3 : Get_Length;
           4 : Get_Decimal;
         end;
         inc(LCnt);
         case GS_KeyI_Chr of
            Kbd_RTb   : begin
                           dec(LCnt,2);
                           if LCnt < 1 then LCnt := 1;
                        end;
            Kbd_UpAr  : LCnt := 5;
            Kbd_DnAr  : LCnt := 5;
         end;
      until (LCnt > 4) or (Quit_Keys);
      case GS_KeyI_Chr of
         Kbd_Tab,
         Kbd_Ret   : begin
                        inc(PCnt);
                        if PCnt > succ(FCnt) then inc(FCnt);
                     end;
         Kbd_UpAr  : dec(PCnt);
         Kbd_DnAr  : inc(PCnt);
      end;
      if PCnt < 1 then PCnt := 1;
      if PCnt > succ(FCnt) then PCnt := succ(FCnt);
      if PCnt < BeginFPos then
      begin
         BeginFPos := PCnt;
         ShowFields;
      end;
      if PCnt >= BeginFPos+EndFPos then
      begin
         inc(BeginFPos);
         ShowFields;
      end;
   until Quit_Keys;
   if (GS_KeyI_Chr = Kbd_Esc) or (FCnt = 0) then UpdateFields := false
      else UpdateFields := true;
end;


procedure BuildFile(FName : string);

{
            ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
            ³  The MakeHeader routine formats a dBase III header, ³
            ³  writes it to the new file, writes the field array  ³
            ³  to the file, and then writes an End of Header and  ³
            ³  End of File byte.                                  ³
            ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
}
   procedure MakeHeader;
   var
      i, j : integer;                    {Local working variables}
   BEGIN
      HeadRec.DBType := DB3File;   {Set file type to dBase III w/o Memo}
{
             ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
             ³  Using the Turbo Pascal GetDate routine, set     ³
             ³  the header year, month, and date header bytes.  ³
             ³  Since the year is given in 19xx format, 1900    ³
             ³  must be subtracted to give just the last two    ³
             ³  digits of the year.                             ³
             ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
}
      GetDate (yy,mm,dd,wd);
      HeadRec.year := yy-1900; {Year}
      HeadRec.month := mm; {Month}
      HeadRec.day := dd; {Day}
      HeadRec.RecCount := 0;       {Set record count in file to zero }
      HeadRec.Location := (FCnt*32) + 33;
                                      {Compute total header size as length of}
                                      {header file information (32 bytes),}
                                      {End of Header mark (1 byte), and the}
                                      {field descriptors (32 bytes each)}
      rl := 1;
      for i := 1 to FCnt do
      begin
         rl := rl + FldRec^[i].FieldLen;
                                      {Compute total record size as delete/}
                                      {undeleted flag (1 byte) plus total of}
                                      {all field lengths. }
         for j := 0 to 10 do
            FldRec^[i].FieldName[j] := UpCase(FldRec^[i].FieldName[j]);
         FldRec^[i].FieldType := UpCase(FldRec^[i].FieldType);
         if FldRec^[i].FieldType = 'M' then
            HeadRec.DBType := DB3WithMemo;
                                      {Set file type to dBase III with Memo}
      end;
      HeadRec.RecordLen := rl;     {Store record length in header}
      FillChar(HeadRec.Reserved,20,#0);
                                      {Store all zeros in reserved portion }
      GS_FileWrite(dFile, 0, HeadRec, 32, rsl);
      GS_FileWrite(dFile, -1, FldRec^, FCnt*32, rsl);
      GS_FileWrite(dFile, -1, EohMark, 1, rsl); {Put EOH marker }
      GS_FileWrite(dFile, -1, EofMark, 1, rsl); {Put EOF marker }
   END;

{
            ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
            ³  Beginning of CREATE Procedure.                    ³
            ³      1.  Assign file with .DBF extension           ³
            ³      2.  Create and write the dBase III header     ³
            ³      3.  Store information in objectname object    ³
            ³      4.  Close the file                            ³
            ³      5.  Initialize the dBase file.                ³
            ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
}

    procedure MakeMemo;
    begin
       HeadRec.DBType := 1;        {Make a longint value of 1}
       HeadRec.Year := 0;
       HeadRec.Month := 0;
       HeadRec.Day := 0;
       Filename := FName+'.DBT';      {Assign .DBT file extension}
       GS_FileAssign(dFile, FileName, 2048);
       GS_FileRewrite(dFile, 1);      {Create file}
       GS_FileWrite(dFile, 0, HeadRec, 512, rsl);
       GS_FileWrite(dFile, -1, EofMark, 1, rsl);  {Put EOF marker }
       GS_FileClose(dFile);            {Close the file}
    end;

begin
   Filename := FName+'.DBF';          {Assign .DBF file extension}
   GS_FileAssign(dFile, FileName,4096);
   GS_FileRewrite(dFile, 1);          {Create file}
   MakeHeader;
   GS_FileClose(dFile);              {Close the file}
   if HeadRec.DBType = DB3WithMemo then MakeMemo;
end;

Function GS_dB3_Create(FName : string) : boolean;
begin
   New(FldRec);
   BeginFPos := 1;
   FCnt := 0;
   StatWin.boxname := '[ CREATE FILE ]';
   StatWin.SetWin;
   gotoxy(56,1);
   write('Ctrl-End to Save');
   gotoxy(56,2);
   write('ESC to Abort');
   gotoxy(2,1);
   write('FLD   NAME        TYPE         LENGTH    DECIMALS');
   gotoxy(2,2);
   write('ÄÄÄ   ÄÄÄÄ        ÄÄÄÄ         ÄÄÄÄÄÄ    ÄÄÄÄÄÄÄÄ');
   FileWin.SetWin;
   EndFPos := succ(hi(WindMax)-hi(WindMin));
   if UpdateFields then
   begin
      BuildFile(FName);
      GS_dB3_Create := true;
   end
      else GS_dB3_Create := false;
   FileWin.RelWin;
   StatWin.RelWin;
   Dispose(FldRec);
END;                        { GS_dB3Wk_Create }

begin
   FileWin.InitWin(2,4,55,24,Yellow,Blue,Yellow,Blue,Yellow,false,'',false);
   StatWin.InitWin(1,1,80,25,LightGray,Blue,Yellow,Blue,Yellow,true,'',true);
   InputStr.Init;
   InputStr.Wait_CR := false;
end.