Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/GSDB21.ZIP/GS_DBFLD.PAS

Pascal/Delphi Source File | 1990-12-23 | 46.3 KB | 1,403 lines

{                      dBase III Field Handler

       GS_DBFLD Copyright (c)  Richard F. Griffin

       15 November 1990

       102 Molded Stone Pl
       Warner Robins, GA  31088

       -------------------------------------------------------------
       This unit handles field processing for all dBase III file (.DBF)
       operations.

                   SHAREWARE  -- COMMERCIAL USE RESTRICTED



       Changes:




}
{
                           ┌──────────────────────┐
                           │  INTERFACE SECTION:  │
                           └──────────────────────┘
}
unit GS_dBFld;

interface

uses
   CRT,
   GS_Edit,
   GS_FileH,
   GS_Error,
   GS_KeyI,
   GS_Strng,
   GS_Wind,
   GS_dBase;

type
   GS_dBFld_Objt   = object(GS_dBase_dB)
      LastFldTyp   : char;            {Last FieldGet type field}
      LastFldDec   : integer;         {Last FieldGet Decimals}
      LastFldLth   : integer;         {Last FieldGet Length}
      LastFldNam   : string[11];      {Last FieldGet Name}
      LastFldNum   : integer;         {Last FieldGet Number}
      EditOn       : boolean;         {Edit allowed}
      RecChanged   : boolean;         {Flag for record changed}
      Memo_Loc     : longint;         {Starting memo block for field}
      Memo_Bloks   : integer;         {Number of blocks used for the field}
      Memo_Store   : GS_Edit_Objt;    {Object to store/edit memos}
      DeleteOnF9   : boolean;         {Flag to permit F9 to delete/undelete}

      Procedure Check_Func_Keys; virtual;
      Function  Create(FName : string) : boolean;
      function  DateGet(st : string) : string;
      function  DateGetN(n : integer) : string;
      Procedure DatePut(st, data : string);
      Procedure DatePutN(n : integer; data : string);
      Function  FieldAccept(st,Titl : string; x,y : integer) : string;
      Procedure FieldDisplay(st,Titl : string; x,y : integer);
      Function  FieldDisplayScreen : boolean;
      Function  FieldGet(st : string) : string;
      Function  FieldGetN(n : integer) : string;
      Procedure FieldPut(st1, st2 : string);
      Procedure FieldPutN(n : integer; st1 : string);
      Function  FieldUpdateScreen : boolean;
      Function  FieldAppendScreen(empty : boolean) : boolean;
      Function  Formula(st : string) : string; virtual;
      Function  HuntFieldName(st : string; var fs : integer) : boolean;
      Procedure IndexTo(filname, formla : string);
      Constructor Init(FName : string);
      function  LogicGet(st : string) : boolean;
      function  LogicGetN(n : integer) : boolean;
      Procedure LogicPut(st : string; b : boolean);
      Procedure LogicPutN(n : integer; b : boolean);
      Procedure MemoEdit;
      function  MemoGetLine(linenum : integer) : string;
      procedure MemoGet(rpt : string);
      Procedure MemoWidth(l : integer);
      function  MemoLines : integer;
      function  MemoPut : string;
      function  NumberGet(st : string) : real;
      function  NumberGetN(n : integer) : real;
      Procedure NumberPut(st : string; r : real);
      Procedure NumberPutN(n : integer; r : real);
      Procedure Pack;
      function  StringGet(st : string) : string;
      function  StringGetN(n : integer) : string;
      Procedure StringPut(st1, st2 : string);
      Procedure StringPutN(n : integer; st1 : string);
   end;

implementation

procedure GS_dBFld_Objt.Check_Func_Keys;
begin
   case ch of
     Kbd_F9   : begin
                   if DeleteOnF9 then
                   begin
                      if RecNumber < 0 then
                      begin
                         if DelFlag then CurRecord^[0] :=  32
                            else CurRecord^[0] := 42;
                         DelFlag := not DelFlag;
                      end
                         else if DelFlag then UnDelete else Delete;
                      GS_KeyI_Ret := true;
                      Ch := Kbd_Ret;
                   end else GS_dBase_DB.Check_Func_Keys;
                end;
     Kbd_F10  : begin
                   GS_KeyI_Ret := true;
                   Ch := Kbd_Ret;
                end;
     else GS_dBase_DB.Check_Func_Keys;
  end;
end;


function  GS_dBFld_Objt.DateGet(st : string) : string;
var
   t     : string;
begin
   t := FieldGet(st);
   DateGet := StrDate(t);
end;

function  GS_dBFld_Objt.DateGetN(n : integer) : string;
var
   data,
   t     : string;
begin
   t := FieldGetN(n);
   DateGetN := StrDate(t);
end;

Procedure GS_dBFld_Objt.DatePut(st, data : string);
var
   f    : integer;
   valu : string[2];
   t    : string;
begin
   if not HuntFieldName(st,f) then
   begin
      ShowError(625,st);
      exit;
   end;
   move(data[1], t[5], 2);
   move(data[4], t[7], 2);
   move(data[7], t[3], 2);
   valu := '19';                {Use 19 for first two digits - this will}
                                {have to be changed in the year 2000}
   move(valu[1], t[1], 2);      {Move the first two year digits to record}
   t[0] := #8;
   FieldPutN(f,t);
end;

Procedure GS_dBFld_Objt.DatePutN(n : integer; data : string);
var
   valu : string[2];
   t    : string;
begin
   if n > NumFields then
   begin
      ShowError(627,'Field number out of range');
      exit;
   end;
   move(data[1], t[5], 2);
   move(data[4], t[7], 2);
   move(data[7], t[3], 2);
   valu := '19';                {Use 19 for first two digits - this will}
                                {have to be changed in the year 2000}
   move(valu[1], t[1], 2);      {Move the first two year digits to record}
   t[0] := #8;
   FieldPutN(n,t);
end;

function  GS_dBFld_Objt.LogicGet(st : string) : boolean;
begin
   LogicGet := ValLogic(FieldGet(st));
end;

function  GS_dBFld_Objt.LogicGetN(n : integer) : boolean;
begin
   LogicGetN := ValLogic(FieldGetN(n));
end;

Procedure GS_dBFld_Objt.LogicPut(st : string; b : boolean);
begin
   FieldPut(st,StrLogic(b));
end;

Procedure GS_dBFld_Objt.LogicPutN(n : integer; b : boolean);
begin
   FieldPutN(n,StrLogic(b));
end;

function  GS_dBFld_Objt.NumberGet(st : string) : real;
var
   r : integer;
   v : real;
   s : string;
begin
   s := TrimR(FieldGet(st));
   r := 0;
   if s = '' then v := 0 else val(s,v,r);
   if r <> 0 then
   begin
      ShowError(620,'Not a valid numeric field in NumberGet'+s);
      v := 0;
   end;
   NumberGet := v;
end;

function  GS_dBFld_Objt.NumberGetN(n : integer) : real;
var
   r : integer;
   v : real;
   s : string;
begin
   s := TrimR(FieldGetN(n));
   r := 0;
   if s = '' then v := 0 else val(s,v,r);
   if r <> 0 then
   begin
      ShowError(620,'Not a valid numeric field in NumberGetN - '+s);
      v := 0;
   end;
   NumberGetN := v;
end;

Procedure GS_dBFld_Objt.NumberPut(st : string; r : real);
var
   f : integer;
   s : string;
begin
   if not HuntFieldName(st,f) then
   begin
      ShowError(625,st);
      exit;
   end;
   Str(r:LastFldLth:LastFldDec,s);
   FieldPutN(f,s);
end;

Procedure GS_dBFld_Objt.NumberPutN(n : integer; r : real);
var
   s : string;
begin
   if n > NumFields then
   begin
      ShowError(627,'Field number out of range');
      exit;
   end;
   Str(r:Fields^[n].FieldLen:Fields^[n].FieldDec,s);
   FieldPutN(n,s);
end;

function  GS_dBFld_Objt.StringGet(st : string) : string;
begin
   StringGet := TrimR(FieldGet(st));
end;

function  GS_dBFld_Objt.StringGetN(n : integer) : string;
begin
   StringGetN := TrimR(FieldGetN(n));
end;

Procedure GS_dBFld_Objt.StringPut(st1,st2 : string);
begin
   FieldPut(st1,st2);
end;

Procedure GS_dBFld_Objt.StringPutN(n : integer; st1 : string);
begin
   FieldPutN(n,st1);
end;

function GS_dBFld_Objt.HuntFieldName(st : string; var fs : integer) : boolean;
var
   FSt : string;
   mtch : boolean;
begin
   FSt := AllCaps(st);             {Capitalize the workstring}
   FSt := TrimR(FSt);              {Remove trailing spaces}
   fs := 1;                        {Initialize field count}
   mtch := false;                  {Set match found to false}
   while (not mtch) and (fs <= NumFields) DO
      if FieldsN^[fs] = FSt then mtch := true else inc(fs);
   if mtch then
   begin
      LastFldTyp := Fields^[fs].FieldType;
      LastFldDec := Fields^[fs].FieldDec;
      LastFldLth := Fields^[fs].FieldLen;
   end;
   HuntFieldName := mtch;
end;

Function GS_dBFld_Objt.Create(FName : string) : boolean;
begin
   if GS_dBase_DB.Create(FName) then
   begin
      Init(FName);
      Create := true;
   end else Create := false;
end;

Procedure GS_dBFld_Objt.Pack;
const
   EOFMark : Byte = $1A;
var
   df   : file;                       {Local file variable for memo work file}
   mbuf : array[0..GS_dBase_MaxMemoRec] of byte;
   rsl  : word;
   i, j : longint;                    {Local variables   }
   mcnt,
   tcnt : longint;
   done : boolean;
   rl   : real;
   FNam : string[64];

   procedure UpdateMemo;
   var
      fp : integer;
   begin
      for fp := 1 to NumFields do
      begin
         if Fields^[fp].FieldType = 'M' then
         begin
            Memo_Loc := Trunc(NumberGetN(fp));
            Memo_Bloks := 0;          {Initialize blocks read}
            if (Memo_Loc <> 0) then
            begin
               tcnt := GS_FileSize(df);
               rl := tcnt;
               NumberPutN(fp,rl);
                done := false;         {Reset done flag to false}
               while (not done) do    {loop until done (EOF mark)}
               begin
                  GS_FileRead(mFile, Memo_Loc+Memo_Bloks, mbuf, 1, rsl);
                  inc(Memo_Bloks);
                  mCnt := 0;          {Counter into disk read buffer}
                  while (mCnt < GS_dBase_MaxMemoRec) and (done = false) do
                  begin
                     if mbuf[mcnt] = $1A then done := true;
                     inc (mcnt);
                  end;
                  if not done then GS_FileWrite(df,-1,mbuf,1, rsl);
               end;
               FillChar(mbuf[mcnt],GS_dBase_MaxMemoRec - mcnt,#0);
               GS_FileWrite(df,-1,mbuf,1, rsl);
                                      {Write the last block to the .DBT}
            end;
         end;
      end;
   end;

begin      {Pack}
   i := 1;
   while dbfNdxTbl[i] <> nil do
   begin
      dbfNdxTbl[i]^.Ndx_Close;
      Dispose(dbfNdxTbl[i]);
      dbfNdxTbl[i] := nil;
      inc(i);
   end;
   dbfNdxActv := false;               {Set index active flag to false}
   j := 0;
   if WithMemo then
   begin
      GS_FileAssign(df,'DB3$$$.D$$',2048);
      GS_FileRewrite(df,GS_dBase_MaxMemoRec);
      FillChar(mbuf,GS_dBase_MaxMemoRec,#0);
      mbuf[0] := 1;
      GS_FileWrite(df,0,mbuf,1,rsl);
   end;
   for i := 1 to NumRecs do           {Read .DBF sequentially}
   begin
      GetRec(i);
      if not DelFlag then             {Write to work file if not deleted}
      begin
         inc(j);                      {Increment record count for packed file }
         if WithMemo then UpdateMemo;
         PutRec(j);
      end;
   end;
   if i > j then                      {If records were deleted then...}
   begin
      NumRecs := j;                   {Store new record count in objectname}
      GS_FileWrite(dfile, HeadLen+(j*RecLen)+1, EOFMark, 1, rsl);
                                      {Write End of File byte at file end}
      GS_FileTruncate(dfile,HeadLen+(j*RecLen)+1);
                                      {Set new file size for dBase file};
   end;
   if WithMemo then
   begin
      tcnt := GS_FileSize(df);
      FillChar(mbuf,GS_dBase_MaxMemoRec,#0);
      Move(tcnt,mbuf[0],4);
      GS_FileWrite(df,0,mbuf,1, rsl);
                                      {Write the block to the .DBT.  It will}
                                      {point to the next available block};
      FNam := FileName;
      FNam[length(FNam)] := 'T';
      GS_FileClose(mFile);
      GS_FileClose(df);
      GS_FileErase(mFile);            {Erase original file}
      GS_FileRename(df, FNam);        {Rename work file to original file name}
      GS_FileAssign(mFile, FNam, 2048); {Set file type to new file}
      GS_FileReset(mFile, GS_dBase_MaxMemoRec);
   end;
END;                        { Pack }

Function GS_dBFld_Objt.FieldAccept(st,Titl : string; x,y : integer) : string;
var
   txtatrb,
   i,
   v         :  integer;              {Counter variables}
   t         :  string[255];          {Work string to hold default (old) value}
   f         : string[2];

   Procedure AcceptC;
   var
      r_c : string;
   begin
      GS_Wind_SetIVMode;
      if EditOn then        {If edit permitted, then go edit string}
      begin
         r_c := t;
         t := EditString(t, v, y, LastFldLth);
         if t <> r_c then RecChanged := true;
      end
      else
      begin
         gotoxy(v,y);       {Go to start of field screen position}
         write(t,'':LastFldLth-length(t));
                            {Rewrite the string on screen inverted}
         WaitForKey;
      end;
      GS_Wind_SetNmMode;
      gotoxy(v,y);          {Go to start of field screen position}
      write(t,'':LastFldLth-length(t));
                            {Rewrite the string on screen in the original color}
   end;

   Procedure AcceptD;
   var
      data   : string[10];
      valu,
      yy,
      mm,
      dd     : string[2];
      mmn,
      ddn,
      yyn,
      rsl    : integer;
      cc     : char;
      okDate : boolean;
   begin
      t := StrDate(t);
      okDate := false;
      repeat
         AcceptC;
         if not EditOn then exit;
         if TrimR(t) = '  /  /' then exit;
         data := t;
         cc := t[3];
         if cc in ['0'..'9'] then
         begin
            mm := copy(data,5,2);
            dd := copy(data,7,2);
            yy := copy(data,3,2);
         end
         else
         begin
            mm := copy(data,1,2);
            dd := copy(data,4,2);
            yy := copy(data,7,2);
         end;
         val(mm,mmn,rsl);
         if rsl = 0 then
         begin
            val(dd,ddn,rsl);
            if rsl = 0 then
            begin
               val(yy,yyn,rsl);
               if rsl = 0 then
               begin
                  if mmn in [1..12] then
                     if ddn in [1..31] then
                        okDate := true;
               end;
            end;
         end;
         if not okDate then SoundBell(BeepTime,BeepFreq);
      until okDate;
      if cc in ['0'..'9'] then begin end
      else
      begin
         move(data[1], t[5], 2);
         move(data[4], t[7], 2);
         move(data[7], t[3], 2);
         valu := '19';                {Use 19 for first two digits - this will}
                                      {have to be changed in the year 2000}
         move(valu[1], t[1], 2);      {Move the first two year digits to record}
         t[0] := #8;
      end;
   end;

   Procedure AcceptL;
   var
      data : string[1];
   begin
{
                    ┌─────────────────────────────────────┐
                    │  Accept keyboard entry.  Loop until │
                    │  value is T,t,Y,y,F,f,N,n.          │
                    └─────────────────────────────────────┘
}
      repeat
         if t = '' then t := 'F';
         AcceptC;
         if not EditOn then exit;
         if t[1] in ['T','t','Y','y','F','f','N','n'] then
         begin end else SoundBell(BeepTime,BeepFreq);
      until t[1] in ['T','t','Y','y','F','f','N','n'];
      if t[1] in ['T','t','Y','y'] then t[1] := 'T' else t[1] := 'F';
   end;

   procedure AcceptM;
   var
      ans       :  string[10];        {Work string to hold edit value}
      r_c       :  string[10];        {Work string for memo block number}
   begin
      GS_Wind_SetIvMode;
      ans := 'N';                     {Initialize ans to false}
      if EditOn then write('  Edit ? ') else write('  View ? ');
      repeat
         ans := EditString(ans,v+9,y,1);
                                      {Go edit string t for 1 character}
                                      {at cursor position v,y}
         if ans[1] in ['T','t','Y','y','F','f','N','n'] then
            begin end else SoundBell(BeepTime,BeepFreq);
      until ans[1] in ['T','t','Y','y','F','f','N','n'];
      GS_Wind_SetNmMode;              {Restore original text attribute}
      gotoxy(v,y);                    {Now reset to 'memo' for field name}
      write('---memo---');
      if ans[1] in ['T','t','Y','y'] then
      begin
         r_c := t;
         MemoGet(t);
         If EditOn then Memo_Store.Edit else Memo_Store.View;
         if (EditOn) and (GS_KeyI_Esc) then
         begin
            GS_KeyI_Esc := false;     {Reset Escape flag so its not used}
                                      {elsewhere}
            GS_KeyI_Chr := ' ';
            MemoGet(t);
         end
         else
         begin
            GS_KeyI_Chr := ' ';       {Clear character last entered}
            if EditOn then t := MemoPut;
            if t <> r_c then RecChanged := true;
         end;
      end;
   end;

   Procedure AcceptN;
   var
      data : string;
      i   : integer;
      r   : real;
   begin
{
                    ┌─────────────────────────────────────┐
                    │  Accept keyboard entry.  Loop until │
                    │  value is Numeric.                  │
                    └─────────────────────────────────────┘
}
      repeat
         if t = '' then Str(0.0:LastFldLth:LastFldDec,t);
         AcceptC;
         if not EditOn then exit;
         val(t, r, i);
         if i = 0 then
         begin
            Str(r:LastFldLth:LastFldDec,t);
            if length(t) > LastFldLth then i := 999;
         end;
         if i <> 0 then
         begin
            SoundBell(BeepTime,BeepFreq);
            t := '';
         end;
      until i = 0;                    {i will be 0 when data is a valid number}
      gotoxy(v,y);          {Go to start of field screen position}
      write(t,'':LastFldLth-length(t));
                            {Rewrite the string on screen in the original color}
   end;

begin
   GotoXY(x,y);                       {Go to position on screen}
   write(Titl);                       {Write the title of field}
   v := WhereX;                       {Save the position after writing title}
   t := TrimR(FieldGet(st));          {Get the field in the work string}
   case LastFldTyp of
      'C'  : begin
                AcceptC;
                FieldAccept := t;     {Return the string to calling routine}
             end;
      'D'  : begin
                AcceptD;
                FieldAccept := t;
             end;
      'L'  : begin
                AcceptL;
                FieldAccept := t;
             end;
      'M'  : begin
                AcceptM;
                FieldAccept := t;
             end;
      'N'  : begin
                AcceptN;
                FieldAccept := t;
             end;
   end;
end;

Procedure GS_dBFld_Objt.FieldDisplay(st,Titl : string; x,y : integer);
var
   i,
   v         :  integer;              {Counter variables}
   t         :  string[255];          {Work string to hold default (old) value}
   data      :  string[10];
begin
   GotoXY(x,y);                       {Go to position on screen}
   write(Titl);                       {Write the title of field}
   v := WhereX;                       {Save the position after writing title}
   t := TrimR(FieldGet(st));          {Get the field in the work string}

   case LastFldTyp of
      'C',
      'L'  : begin
                gotoxy(v,y);          {Go to start of field screen position}
                write(t,'':LastFldLth-length(t));
                                      {Write the string on screen }
             end;
      'D'  : begin
                t := StrDate(t);
                write(t);
             end;
      'N'  : begin
                if t = '' then t := '0';
                gotoxy(v,y);          {Go to start of field screen position}
                write(t:LastFldLth);
             end;
      'M'  : begin
                gotoxy(v,y);          {Go to start of field screen position}
                write('---memo---');  {Write the '---memo--- on screen }
             end;
   end;
end;

Function GS_dBFld_Objt.FieldDisplayScreen : boolean;
var
   f,
   h     : boolean;
begin
   h := EditOn;
   EditOn := false;
   f := FieldUpdateScreen;
   EditOn := h;
   FieldDisplayScreen := f;
end;

function GS_dBFld_Objt.FieldGetN(n : integer) : String;
var
   os,
   fs  : longint;
   i,
   k   : integer;
   FSt,
   WSt : string[255];
   NSt : string[10];
begin
   fs := n;                        {Initialize field count}
   if (fs <= NumFields) then
   BEGIN
      os := 1;
      WITH Fields^[fs] DO
      BEGIN
         CnvAscToStr(FieldName,FSt,11);
         FSt := TrimR(FSt);           {Remove trailing spaces}
         move(CurRecord^[FieldAddress], WSt[1], FieldLen);
         WSt[0] := char(FieldLen);    {Set string length to field length}
         FieldGetN := WSt;
         LastFldTyp := FieldType;
         LastFldDec := FieldDec;
         LastFldLth := FieldLen;
         LastFldNum := fs;
         LastFldNam := FSt;
      end;
   end else
   begin
      str(n,NSt);
      ShowError(603,NSt);
      FieldGetN := '';
      LastFldTyp := ' ';
      LastFldDec := 0;
      LastFldLth := 0;
      LastFldNum := 0;
      LastFldNam := '';
   end;
end;

function GS_dBFld_Objt.FieldGet(st : string) : String;
var
   fs : integer;
begin
   if HuntFieldName(st,fs) then FieldGet := FieldGetN(fs)
   else
   begin
      ShowError(602,st);
      FieldGet := '';
      LastFldTyp := ' ';
      LastFldDec := 0;
      LastFldLth := 0;
      LastFldNum := 0;
      LastFldNam := '';
   end;
end;


Procedure GS_dBFld_Objt.FieldPutN(n : integer; st1 : string);
var
   os,
   fs  : longint;
   i,
   k   : integer;
   FSt,
   WSt : string[255];
   NSt : string[10];
begin
   fs := n;                        {Initialize field count}
   if (fs <= NumFields) then
   BEGIN
      WITH Fields^[fs] DO
      BEGIN
         move(FieldName,FSt[1],11);
         FSt[0] := #11;
         FSt[0] := char(pred(pos(#0,FSt)));
         FSt := TrimR(FSt);        {Remove trailing spaces}
         FillChar(CurRecord^[FieldAddress], FieldLen, ' ');
         k := length(st1);         {Get length of input string}
         if k > FieldLen then k := FieldLen;
         Move(st1[1], CurRecord^[FieldAddress], k);
         LastFldTyp := FieldType;
         LastFldDec := FieldDec;
         LastFldLth := FieldLen;
         LastFldNum := fs;
         LastFldNam := FSt;
      end;
   end else
   begin
      str(n,NSt);
      ShowError(605,NSt);
      LastFldTyp := ' ';
      LastFldDec := 0;
      LastFldLth := 0;
      LastFldNum := 0;
      LastFldNam := '';
   end;
end;

Procedure GS_dBFld_Objt.FieldPut(st1, st2 : string);
var
   fs : integer;
begin
   if HuntFieldName(st1,fs) then FieldPutN(fs,st2)
   else
   begin
      ShowError(604,st1);
      LastFldTyp := ' ';
      LastFldDec := 0;
      LastFldLth := 0;
      LastFldNum := 0;
      LastFldNam := '';
   end;
end;

Function GS_dBFld_Objt.FieldUpdateScreen : boolean;
var
   b,
   i,
   v,
   x,
   y,
   ll    : integer;
   st,
   s     : string[12];
   t     : string;
   activlin,
   activfld : integer;


   Procedure UpdatePage;
   var
      validcmd : boolean;
   begin
      validcmd := false;
      if activfld < b then activfld := b;
      if activfld >= b+v then activfld := pred(b+v);
      activlin := succ(activfld - b);
      if (activlin < 1) or (activlin > v) then activlin := 1;
      repeat
         t := FieldAccept(FieldsN^[activfld],'',13,activlin);
         if (EditOn) and (not GS_KeyI_Esc) then FieldPutN(activfld,t);
         if (not GS_KeyI_Fuc) and (GS_KeyI_Chr >= #32) then
            GS_KeyI_Chr := Kbd_Ret;

            case GS_KeyI_Chr of
               Kbd_F9 :   begin
                             gotoxy(3,ll);
                             GS_Wind_SetIvMode;
                             if DelFlag then write('Deleted')
                                else write('':8);
                             GS_Wind_SetNmMode;
                          end;
               Kbd_PgUp : begin
                             if activfld = b then
                             begin
                                b := b-v;
                                if b < 1 then b := 1;
                                validcmd := true;
                             end
                             else activfld := b;
                          end;
               Kbd_PgDn : begin
                             if activfld = pred(b+v) then
                             begin
                                b := b+v;
                                if b > NumFields-v then b := succ(NumFields-v);
                                if b < 1 then b := 1;
                                validcmd := true;
                             end
                             else activfld := pred(b+v);
                          end;
               Kbd_UpAr : begin
                             dec(activfld);
                             if activfld < b then
                             begin
                                dec(b);
                                if b < 1 then b := 1;
                                validcmd := true;
                             end;
                          end;
               Kbd_RtAr,
               Kbd_Tab,
               Kbd_Ret,
               Kbd_DnAr : begin
                             inc(activfld);
                             if activfld > pred(b+v) then
                             begin
                                if activfld > NumFields then
                                   activfld := NumFields
                                else
                                begin
                                   inc(b);
                                   if b > NumFields then
                                      b := succ(NumFields-v);
                                   validcmd := true;
                                end;
                             end;
                          end;
               Kbd_Esc,
               Kbd_F10  : validcmd := true;
            end;

         if activfld < b then activfld := b;
         if activfld >= b+v then activfld := pred(b+v);
         activlin := succ(activfld - b);
         if (activlin < 1) or (activlin > v) then activlin := 1;
      until validcmd;
   end;

begin
   ClrScr;
   DeleteOnF9 := true;
   RecChanged := false;
   b := 1;
   activfld := b;
   ll := succ(hi(WindMax)-hi(WindMin));
   v := pred(ll);
   GS_Wind_SetIvMode;
   gotoxy(2,ll);
   write('':pred(lo(WindMax)-lo(WindMin)));
   if EditOn then
   begin
      if RecNumber < 0 then           {If Append, do the following}
      begin
         gotoxy(12,ll);
         write('Append ');
         write('EOF/',NumRecs);
      end
      else
      begin                           {If Update do the following}
         gotoxy(12,ll);
         write('Update ');
         write(RecNumber,'/',NumRecs);
      end;
   end else
   begin                              {If Display then do this}
      gotoxy(12,ll);
      write('Display ');
      write(RecNumber,'/',NumRecs);
   end;
   if DelFlag then
   begin
      gotoxy(3,ll);
      write('Deleted');
   end;
   GS_Wind_SetNmMode;
   if NumFields < v then v := NumFields;
   x := 1;
   y := 1;
   Ch := ' ';
   repeat
      for i := b to pred(b+v) do
      begin
         s := FieldsN^[i];
         FillChar(st[1],12,' ');
         move(s[1],st[11-length(s)],length(s));
         st[11] := ':';
         st[0] := #12;
         FieldDisplay(s,st,x,y);
         case LastFldTyp of
           'M' : begin
                    gotoxy(x+12,y);
                    write('---memo---');
                    if RecNumber < 0 then FieldPutN(LastFldNum,' ');
                                      {If Append, make sure memo field is not}
                                      {pointing to a memo block              }
                 end;
         end;
         ClrEol;
         inc(y);
      end;
      UpdatePage;
      y := 1;
   until (GS_KeyI_Chr in [Kbd_Esc,Kbd_F10]) or
         ((GS_KeyI_Chr = Kbd_PgUp) and (activfld = 1)) or
         ((GS_KeyI_Chr = Kbd_PgDn) and (activfld = NumFields));
   DeleteOnF9 := false;
   if GS_KeyI_Chr in [Kbd_F10, Kbd_PgUp, Kbd_PgDn] then
      FieldUpdateScreen := true
   else FieldUpdateScreen := false;
end;

Function GS_dBFld_Objt.FieldAppendScreen(empty : boolean) : boolean;
begin
   if empty then Blank;
   CurRecord^[0] := 32;                   {Ensure delete flag is off}
   DelFlag := false;
   RecNumber := -1;
   FieldAppendScreen := FieldUpdateScreen;
end;

Function GS_dBFld_Objt.Formula(st : string) : string;
var
   FldVal,
   FldWrk : string;
   FldPos : integer;

   function HuntField(fldst : string) : String;
   var
      fs   : integer;
      ss   : string;
      FSt  : string;
      mtch : boolean;
   begin
      FSt := AllCaps(fldst);          {Capitalize the workstring}
      FSt := TrimR(FSt);              {Remove trailing spaces}
      fs := 1;                        {Initialize field count}
      mtch := false;                  {Set match found to false}
      while (not mtch) and (fs <= NumFields) DO
         if FieldsN^[fs] = FSt then mtch := true else inc(fs);
      if mtch then
      begin
         WITH Fields^[fs] DO
         BEGIN
            move(CurRecord^[FieldAddress], FSt[1], FieldLen);
            FSt[0] := char(FieldLen);    {Set string length to field length}
            HuntField := FSt;
         end;
      end
      else
      begin
         ss := TrimL(fldst);
         if ss = '' then
         begin
            HuntField := '';
            exit;
         end;
         if ss[1] = '"' then
         begin
            ss := TrimR(ss);
            system.delete(ss,1,1);
            if ss[length(ss)] = '"' then ss[0] := chr(pred(length(ss)));
            HuntField := ss;
            exit;
         end;
         ShowError(601,st+' ('+fldst+')');
         HuntField  := '';
      end;
   end;

begin
   FldVal := '';                      {Initialize the return string value}
   FldWrk := st;                      {Move the input string to a work field}
   while FldWrk <> '' do              {Repeat while there is still something}
                                      {in the work field.}
   begin
      FldPos := pos('+', FldWrk);     {Search for a '+' delimiter}
      if FldPos = 0 then FldPos := length(FldWrk)+1;
                                      {If no '+' then simulate for this pass}
                                      {by setting position to one beyond the}
                                      {end of the target field string.}
      FldVal := FldVal + HuntField(SubStr(FldWrk,1,FldPos-1));
                                      {Go find the field using the substring}
                                      {from the string's beginning to one }
                                      {position before the '+' character.}
      system.delete(FldWrk,1,FldPos); {Delete the string up through the '+'};
      FldWrk := TrimL(FldWrk);        {Remove leading spaces}
   end;
   Formula := FldVal;                 {Return value to calling routine}
end;

Procedure GS_dBFld_Objt.IndexTo(filname, formla : string);
var
   i,
   j,
   fl : integer;                      {Local working variable}
   ft : char;


{
             ┌──────────────────────────────────────────────────┐
             │  This routine will accumulate the field length   │
             │  of all fields passes in the calling argument.   │
             │  This is needed to pass the formula length to    │
             │  create the index header.                        │
             └──────────────────────────────────────────────────┘
}


   procedure AccumField;
   var
      FldWrk : string;
      FldLoc,
      FldPos : integer;
   begin
      ft := '*';                      {Set field type to new '*'}
      fl := 0;                        {initialize field length}
      FldWrk := TrimR(formla);        {Remove trailing spaces from argument}
      while FldWrk <> '' do           {Repeat while there is still something}
                                      {in the work field.}
      begin
         FldPos := pos('+', FldWrk);  {Search for a '+' delimiter}
         if FldPos = 0 then FldPos := length(FldWrk)+1;
                                      {If no '+' then simulate for this pass}
                                      {by setting position to one beyond the}
                                      {end of the target field string.}

                                      {Go find the field using the substring}
                                      {from the string's beginning to one }
                                      {position before the '+' character.}
        if not HuntFieldName(SubStr(FldWrk,1,FldPos-1),FldLoc) then
         begin
            fl := 0;
            exit;
         end;
         if ft = '*' then ft := LastFldTyp
            else ft := 'C';           {Set type to C if more than one field}
                                      {Else save this field's type         }
         fl := fl + Fields^[FldLoc].FieldLen;
                                      {If a valid field, then add the field}
                                      {length to the total field length value.}
         system.delete(FldWrk,1,FldPos);
                                      {Delete the string up through the '+'};
         FldWrk := TrimL(FldWrk);     {Remove leading spaces}
      end;
   end;

{
             ┌──────────────────────────────────────────────────┐
             │  Main routine.  This takes and analyzes the      │
             │  argument to build an index file.  It does the   │
             │  following:                                      │
             │  1.  Reset current index files.                  │
             │  2.  Get the total new formula field length.     │
             │  3.  Create an index file.                       │
             │  4.  Build the index by reading all dbase        │
             │      records and updating the index file.        │
             └──────────────────────────────────────────────────┘
}

begin
   i := 1;
   while dbfNdxTbl[i] <> nil do
   begin
      dbfNdxTbl[i]^.Ndx_Close;
      Dispose(dbfNdxTbl[i]);
      dbfNdxTbl[i] := nil;
      inc(i);
   end;
   dbfNdxActv := false;               {Set index active flag to false}
   if formla <> '' then
   begin
      AccumField;                     {Get field length of the formula}
      if fl = 0 then
      begin
         ShowError(601,formla);       {Display Error if formula is bad}
         exit;                        {Exit if formula is no good}
      end;
      New(dbfNdxTbl[1]);              {Create a new index object}
      dbfNdxTbl[1]^.Ndx_Make(filname, formla, fl, ft);
                                      {Go create an index}
      Open;
      GetRec(Top_Record);             {Read all dBase file records}
      while not File_EOF do
      begin
         dbfNdxTbl[1]^.KeyUpdate(Formula(formla),RecNumber,-1);
                                      {Insert record in the index}
         GetRec(Next_Record);
      end;
{      dbfNdxTbl[1]^.KeyList('PRN');}
      dbfNdxActv := true;             {Set index active flag true if index }
      GetRec(Top_Record);             {Reset to top record}
   end;
end;

constructor GS_dBFld_Objt.Init(FName : string);
begin
   EditOn := true;
   GS_dBase_DB.Init(FName);
   Memo_Store.Init;                   {Initialize the edit object}
   Memo_Store.Edit_Lgth := 50;        {Set default memo line size to 50}
   Wait_Cr := false;                  {Set EditString not to wait for CR}
   DeleteOnF9 := false;               {Turn off F9 for delete/undelete}
end;

function GS_dBFld_Objt.MemoGetLine(linenum : integer) : string;
begin
   if linenum > Memo_Store.Total_Lines then
   begin
      MemoGetLine := '';
      exit;
   end;
   if not Memo_Store.Find_Line(linenum) then
   begin
      MemoGetLine := '';
      exit;
   end;
   MemoGetLine := Memo_Store.Work_line^.Valu_Line;
end;

Procedure GS_dBFld_Objt.MemoGet(rpt : string);
const
   EOFMark : byte = $1A;              {End of disk file code}

var
   cnt,                               {Counter for memo storage location}
   lCnt,                              {Counter for line length in characters}
   mCnt    : longint;                 {Counter for input buffer char position}
   Result  : word;                    {BlockRead number of bytes read}
   done    : boolean;                 {Flag set when end of memo field found}
   i,j     : integer;                 {Working variable}
   Mem_Block : array [0..GS_dBase_MaxMemoRec] of byte;
                                      {Input buffer}
BEGIN                       { Get Memo Field }
   Val(rpt, Memo_Loc, i);             {Save starting block number}
   Memo_Bloks := 0;                   {Initialize blocks read}
   Memo_Store.Clear_Editor;           {Begin memo line count at zero}
{
                    ┌─────────────────────────────────────┐
                    │  If no .DBT memo field for this     │
                    │  record, then exit.                 │
                    └─────────────────────────────────────┘
}
   if (Memo_Loc = 0) then exit;
   Memo_Store.Work_Line := Memo_Store.Get_Line_Mem(Memo_Store.Edit_Lgth);
                                      {Get the first edit line record}
   Memo_Store.Active_Line := 1;       {Set active line to first line}
   done := false;                     {Reset done flag to false}
   cnt := 0;                          {index into Memo_Store buffer}
   lCnt := 0;                         {line length counter}
   BEGIN
      while (not done) do             {loop until done (EOF mark)}
      begin
         GS_FileRead(mFile, Memo_Loc+Memo_Bloks, Mem_Block, 1, Result);
         inc(Memo_Bloks);
         mCnt := 0;                   {Counter into disk read buffer}
{
                    ┌─────────────────────────────────────┐
                    │  Start reading and processing the   │
                    │  sequential memo blocks until EOF   │
                    │  mark is found.                     │
                    └─────────────────────────────────────┘
}
         while (mCnt < GS_dBase_MaxMemoRec) and
               (done = false) do
{
                 ┌────────────────────────────────────────────┐
                 │   Repeat the following until you find an   │
                 │   End-of-Memo condition.  Read the next    │
                 │   block each time mCnt reaches 512 bytes   │
                 │   (GS_dBase_MaxMemoRec.  Group the memo    │
                 │   as a series of lines no greater than     │
                 │   Memo_Width long.                         │
                 └────────────────────────────────────────────┘
}
         begin

            case Mem_Block[mCnt] of   {Check for control characters}

               $1A : begin
                        done := true; {End of Memo field}
                        if Memo_Store.Work_line^.Valu_Line = '' then
                           Memo_Store.Rel_Line_Mem(Memo_Store.Active_Line);
                     end;

               $8D : begin            {Soft Return (Wordstar and dBase editor)}
                        if (Memo_Store.Work_Line^.Valu_Line[lCnt] <> ' ') and
                           (Memo_Store.Work_Line^.Valu_Line[lCnt] <> '-') and
                           (lCnt > 0) then
                        begin
                           inc(lCnt); {Add to line length count}
                           Memo_Store.Work_Line^.Valu_Line[lcnt] := ' ';
                                      {Insert a space in storage}
                           Memo_Store.Work_Line^.Valu_Line[0] := chr(lcnt);
                        end;
                     end;

               $0A : begin            {Linefeed}
                     end;             {Ignore these characters}

               $0D : begin            {Hard Return}
                        With Memo_Store do
                        begin
                           Work_Line^.Return_Cod := $0D;
                           Work_Line := Get_Line_Mem(Edit_Lgth);
                           inc(Memo_Store.Active_Line);
                           lCnt := 0;
                        end;
                     end;
               else                   {Here for other characters}
               begin
                  inc(lCnt);          {Add to line length count}
                  Memo_Store.Work_Line^.Valu_Line[lcnt] :=
                                      chr(Mem_Block[mCnt]);
                                      {Insert the character in storage}
                  Memo_Store.Work_Line^.Valu_Line[0] := chr(lcnt);
               end;
            end;
            inc(mCnt);                {Step to next input buffer location}

            if lCnt > Memo_Store.Edit_Lgth then
                                      {If lcnt longer than Memo_Width, you}
                                      {must word wrap to Memo_Width length}
                                      {or less}
            begin
               while (Memo_Store.Work_Line^.Valu_Line[lCnt] <> ' ') and
                     (Memo_Store.Work_Line^.Valu_Line[lCnt] <> '-') and
                     (lCnt > 0) do dec(lCnt);
                                      {Repeat search for space or hyphen until}
                                      {found or current line exhausted}
               if (lCnt = 0) then
                  lcnt := length(Memo_Store.Work_Line^.Valu_Line) - 1;
                                      {If no break point, truncate line}
               with Memo_Store do
               begin
                  Temp_Line := Work_Line^.Valu_Line;
                  system.delete(Temp_Line,1,lCnt);
                  if lCnt > Memo_Store.Edit_Lgth then
                     lCnt := Memo_Store.Edit_Lgth;
                  Work_Line^.Valu_Line[0] := chr(lcnt);
                                      {Get string up to cursor to split line}
                  Work_Line := Get_Line_Mem(Edit_Lgth);
                  inc(Memo_Store.Active_Line);
                  Work_Line^.Return_Cod := $8D;
                                      {Insert soft return character}
                  Work_Line^.Valu_Line  := Temp_Line;
                  lCnt := length(Work_Line^.Valu_Line);
               end;
            end;
         end;
      END;
   end;
END;                        { Get Memo Field }

Procedure GS_dBFld_Objt.MemoEdit;
begin
   Memo_Store.Edit;
end;

Function GS_dBFld_Objt.MemoLines : integer;
begin
   MemoLines := Memo_Store.Total_Lines;
end;

Procedure GS_dBFld_Objt.MemoWidth(l : integer);
begin
   Memo_Store.Edit_Lgth := l;
end;

Function GS_dBFld_Objt.MemoPut : string;
const
   EOFMark : byte = $1A;              {End of disk file code}
var
   bCnt,                              {Will hold bytes in memo field}
   lCnt,                              {Counter for line length in characters}
   mCnt,
   tcnt  :  longint;                  {Counter for input buffer char position}
   Result  : word;                    {BlockWrite number of bytes written}
   i     : longint;                   {Working variable}
   Mem_Block : array [0..GS_dBase_MaxMemoRec*2] of byte;
                                      {Output buffer}
   valu  : string[10];                {work string to convert block number}
BEGIN                       { Put Memo Field }
   bCnt := Memo_Store.Byte_Count;     {Get count of bytes in memo field}
   bCnt := bcnt div GS_dBase_MaxMemoRec;
                                      {Get number of blocks required}
   inc(bCnt);                         {Adjust from zero}
   if bCnt > Memo_Bloks then
   begin
      GS_FileRead(mFile, 0, Mem_Block, 1, Result);
                                      {read a block from the .DBT}
      Move(Mem_Block[0],Memo_Loc,4);
                                      {Get next block number to append}
   end;
   Memo_Bloks := bCnt;                {Set blocks written count}
   lCnt := 0;                         {line length counter}
   mCnt := 0;                         {Counter into disk write buffer}
   tCnt := Memo_Loc;
{
                    ┌─────────────────────────────────────┐
                    │  Start reading and processing the   │
                    │  sequential memo blocks until EOF   │
                    │  mark is found.                     │
                    └─────────────────────────────────────┘
}
      with Memo_Store do
      begin
         Work_Line := First_Line;
         while (Work_Line <> nil) do
         begin
            move(Work_Line^.Valu_Line[1],Mem_Block[mCnt],
                 length(Work_Line^.Valu_Line));
            mCnt := mCnt + length(Work_Line^.Valu_Line);
            if Work_Line^.Next_Line <> nil then
            begin
               Mem_Block[mCnt] := Work_Line^.Return_Cod;
               Mem_Block[mCnt+1] := $0A;
               inc(mCnt,2);
            end;
            Work_Line := Work_Line^.Next_Line;
            if (mCnt > GS_dBase_MaxMemoRec) then
            begin
               GS_FileWrite(mFile,tcnt,Mem_Block,1, Result);
                                      {read a block from the .DBT}
               inc(tcnt);
               mCnt := mCnt mod GS_dBase_MaxMemoRec;
                                      {Get excess buffer length used}
               Move(Mem_Block[GS_dBase_MaxMemoRec],Mem_Block[0],mCnt);
                                      {Move excess to beginning of buffer}
            end;
         end;
         Mem_Block[mCnt] := EOFMark;
         FillChar(Mem_Block[succ(mcnt)],GS_dBase_MaxMemoRec - mcnt,#0);
         GS_FileWrite(mFile,tcnt,Mem_Block,1, Result);
                                      {Write the last block to the .DBT}
         i := GS_FileSize(mFile);
         FillChar(Mem_Block,GS_dBase_MaxMemoRec,#0);
         Move(i,Mem_Block[0],4);
         GS_FileWrite(mFile,0,Mem_Block,1, Result);
                                      {Write the block to the .DBT.  It will}
                                      {point to the next available block};
   end;
   Str(Memo_Loc:10,valu);
   MemoPut := valu;
end;

end.