Power-Programmierung/CD1.mdf/pascal/library/dos/database/gsdb28/gs_dbfld.pas

Pascal/Delphi Source File | 1992-02-27 | 49.1 KB | 1,482 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:

       02 May 91 - Changed the type of value returned for a date field from
                   string to longint.  The value assigned is the julian date.
                   Note that the Julian day number is not the same as the
                   serial day number (1-366) which is sometimes (erroneously)
                   called a Julian date.  Refer to the GS_Date unit for more
                   information.

       03 May 91 - Ensured Date field is a julian date for .NDX indexes in the
                   IndexTo method.

       02 Jun 91 - Allowed a 'blank' date field to be acccepted if the field
                   was originally blank in AcceptField.

       31 Jul 91 - Created a StatusUpdate virtual method to allow a user to
                   track progress of actions such as Pack and IndexTo.  The
                   status will be passed to StatusUpdate from within those
                   methods.  The basic StatusUpdate is empty and does nothing
                   with the passed status.  The user has the option to create
                   his own virtual method to capture this information.

       20 Oct 91 - Added a Zap method to delete and remove all records.

       20 Oct 91 - Corrected the Pack Method to write the EOF Mark in the
                   proper location.

       11 Nov 91 - Corrected IndexTo problem with garbage object data.
                   Added close and init calls to ensure good object.

       20 Feb 92 - Added a Done destructor to allow dynamic allocation
                   of objects.

                   Added GSP_dBFld_Objct as pointer type to the object.
                   This facilitates dynamic creation of the object.

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

interface

uses
   CRT,
   GS_Date,
   GS_Edit,
   GS_FileH,
   GS_Error,
   GS_KeyI,
   GS_Strng,
   GS_Winfc,
   GS_dBase;

const
   StatusStart     = -1;
   StatusStop      = 0;
   StatusIndexTo   = 1;
   StatusPack      = 2;

type
   GSP_dBFld_Objt = ^GS_dBFld_Objt;
   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}

      Constructor Init(FName : string);
      Destructor Done;
      Procedure Check_Func_Keys; virtual;
      Function  Create(FName : string) : boolean;
      function  DateGet(st : string) : longint;
      function  DateGetN(n : integer) : longint;
      Procedure DatePut(st : string; jdte : longint);
      Procedure DatePutN(n : integer; jdte : longint);
      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; var ftyp : char) : string; virtual;
      Function  HuntFieldName(st : string; var fs : integer) : boolean;
      Procedure IndexTo(filname, formla : 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;
      Procedure StatusUpdate(statword1,statword2,statword3 : longint); virtual;
      function  StringGet(st : string) : string;
      function  StringGetN(n : integer) : string;
      Procedure StringPut(st1, st2 : string);
      Procedure StringPutN(n : integer; st1 : string);
      Procedure Zap;
   end;

implementation

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;

destructor GS_dBFld_Objt.Done;
begin
   Memo_Store.Done;
   GS_dBase_DB.UnInit;
end;

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) : longint;
var
   t     : string;
   v     : longint;
begin
   t := FieldGet(st);
   v := GS_Date_Juln(t);
   if v > 0 then DateGet := v else DateGet := 0;
end;

function  GS_dBFld_Objt.DateGetN(n : integer) : longint;
var
   t     : string;
   v     : longint;
begin
   t := FieldGetN(n);
   v := GS_Date_Juln(t);
   if v > 0 then DateGetN := v else DateGetN := 0;
end;

Procedure GS_dBFld_Objt.DatePut(st : string; jdte : longint);
var
   f    : integer;
   t    : string[8];
begin
   if not HuntFieldName(st,f) then
   begin
      ShowError(625,st);
      exit;
   end;
   if jdte = 0 then t := '        '
      else t := GS_Date_DBStor(jdte);
   FieldPutN(f,t);
end;

Procedure GS_dBFld_Objt.DatePutN(n : integer; jdte : longint);
var
   t    : string[8];
begin
   if n > NumFields then
   begin
      ShowError(627,'Field number out of range');
      exit;
   end;
   if jdte = 0 then t := '        '
      else t := GS_Date_DBStor(jdte);
   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;
   don : 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);
                don := false;         {Reset done flag to false}
               while (not don) 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 (don = false) do
                  begin
                     if mbuf[mcnt] = $1A then don := true;
                     inc (mcnt);
                  end;
                  if not don 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}
   StatusUpdate(StatusStart,StatusPack,NumRecs);
   i := 1;
   while dbfNdxTbl[i] <> nil do
   begin
      Dispose(dbfNdxTbl[i], Done);
      dbfNdxTbl[i] := nil;
      inc(i);
   end;
   dbfNdxActv := nil;
   j := 0;
   if WithMemo then
   begin
      GS_FileAssign(df,'DB3$$$.D$$');
      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;
      StatusUpdate(StatusPack,i,0);
   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), EOFMark, 1, rsl);
                                      {Write End of File byte at file end}
      GS_FileTruncate(dfile,HeadLen+(j*RecLen));
                                      {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); {Set file type to new file}
      GS_FileReset(mFile, GS_dBase_MaxMemoRec);
   end;
   StatusUpdate(StatusStop,0,0);
END;                        { Pack }

Procedure GS_dBFld_Objt.Zap;
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;
   don : boolean;
   rl   : real;
   FNam : string[64];

begin
   i := 1;
   while dbfNdxTbl[i] <> nil do
   begin
      Dispose(dbfNdxTbl[i], Done);
      dbfNdxTbl[i] := nil;
      inc(i);
   end;
   dbfNdxActv := nil;
   if WithMemo then
   begin
      FillChar(mbuf,GS_dBase_MaxMemoRec,#0);
      mbuf[0] := 1;
      GS_FileWrite(mfile,0,mbuf,1,rsl);
      GS_FileTruncate(mfile,1);
   end;
   NumRecs := 0;                   {Store new record count in objectname}
   RecNumber := 0;
   GS_FileWrite(dfile, HeadLen, EOFMark, 1, rsl);
                                      {Write End of File byte at file end}
   GS_FileTruncate(dfile,HeadLen);
                                      {Set new file size for dBase file};
   dStatus := Updated;
   Close;
   Open;
END;                        { Zap }

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
      okDate : boolean;
      v1,
      v2     : longint;
      h1     : string[10];
   begin
      t := TrimR(t);
      if length(t) <> 8 then
      begin
         t := '  /  /    ';
         if not GS_Date_Century then t[0] := #8;
      end
      else
      begin
         v1 := GS_Date_Juln(t);
         t := GS_Date_View(v1);
      end;
      h1 := t;
      LastFldLth := length(t);
      okDate := false;
      repeat
         AcceptC;
         if EditOn then
         begin
            if GS_KeyI_Esc then v2 := v1
               else v2 := GS_Date_Juln(t);
            if v2 >= 0 then
            begin
               okDate := true;
               t := GS_Date_DBStor(v2);
            end
            else
            begin
               if t = h1 then
               begin
                  t := FieldGet(st);
                  okDate := true;
               end;
            end;
         end else okDate := true;
         if not okDate then SoundBell(BeepTime,BeepFreq);
      until okDate;
   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 := GS_Date_View(GS_Date_Juln(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; var ftyp : char) : 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}
            ftyp := FieldType;
            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;
   ftyp : char;
   fval : longint;
   fkey : string;

{
             ┌──────────────────────────────────────────────────┐
             │  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
   StatusUpdate(StatusStart,StatusIndexTo,NumRecs);
   i := 1;
   while dbfNdxTbl[i] <> nil do
   begin
      Dispose(dbfNdxTbl[i], Done);
      dbfNdxTbl[i] := nil;
      inc(i);
   end;
   dbfNdxActv := nil;
   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], Ndx_Make(filname, formla, fl, ft));
                                      {Go create an index}
      Dispose(dbfNdxTbl[1], Done);
      Open;
      New(dbfNdxTbl[1], Init(filname));
      GetRec(Top_Record);             {Read all dBase file records}
      while not File_EOF do
      begin
         fkey := Formula(formla,ftyp);
         if (IsDB3NDX) and (ftyp = 'D') then
         begin
            fval := GS_Date_Juln(fkey);
            str(fval,fkey);
         end;
         dbfNdxTbl[1]^.KeyUpdate(fkey,RecNumber,-1);
                                      {Insert record in the index}
         StatusUpdate(StatusIndexTo,RecNumber,0);
         GetRec(Next_Record);
      end;
      dbfNdxTbl[1]^.Ndx_Flush;
      dbfNdxActv := dbfNdxTbl[1];
      GetRec(Top_Record);             {Reset to top record}
   end;
   StatusUpdate(StatusStop,0,0);
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}
   don     : 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}
   don := false;                     {Reset done flag to false}
   cnt := 0;                          {index into Memo_Store buffer}
   lCnt := 0;                         {line length counter}
   BEGIN
      while (not don) 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
               (don = 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
                        don := 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;

Procedure GS_dBFld_Objt.StatusUpdate(statword1,statword2,statword3 : longint);
begin
end;


end.