Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ENTRDATA.ZIP/ENTRDATA.INC

Text File | 1993-01-04 | 18.1 KB | 701 lines

{ entrdata.inc - Data entry procedures for entrdata.pas }

function InsertOn: boolean;
const InsertStateBit=$80;  { Bit 7 }
var  KeyStatus: byte absolute $0040:$0017;
begin
  InsertOn := (KeyStatus and InsertStateBit)<>0;
end;

procedure ToggleNumLock (Switch: Toggle);
const
  LastNumLockBit: byte = 0;   { dummy assumption }
  NumLockBit           = $20; { bit 5 }
var  KeyStatus: byte absolute $0000:$0417;
begin
  if (TopEntry.TypeOfData<Strings) and AutoNumLock then
    case Switch of
      On:  begin
             LastNumLockBit := KeyStatus and NumLockBit;
             KeyStatus      := KeyStatus or  NumLockBit;
           end;
      Off: KeyStatus := (KeyStatus and $DF) or LastNumLockBit;
    end;
end;

procedure CallTranslate;  { indirect }
inline ($FF/$1E/TopEntry+11);
  {  call DWORD PTR [>TopEntry.TranslateProc] }

procedure CallCheckRange;  { indirect }
inline ($FF/$1E/TopEntry+15);
  {  call DWORD PTR [>TopEntry.CheckRangeProc] }

procedure CallErrHandler;  { indirect }  {Added [GAF]}
inline ($FF/$1E/DataPad+10);
  {  call DWORD PTR [>DataPad.ErrHandlerProc] }

procedure TransferData (VAR UserVariable);
var
  Size:      byte;
  StrLength: byte absolute UserVariable;
begin
  with TopEntry,DataPad do
    begin
      case TypeOfData of
        Bytes,Chars,ShortInts: Size:=1;
        Words,Integers:        Size:=2;
        LongInts:              Size:=4;
        Reals:                 Size:=6;
      else
        if StoreMode then
             Size := succ( MinI( ord(Sdata[0]),MaxField ))
        else Size := succ(StrLength);
      end;
      if StoreMode then
        Move16 (Bdata,UserVariable,Size)
      else
        begin
          Ldata := 0;    { Clear first }
          Move16 (UserVariable,Bdata,Size);
        end;
    end
end;

procedure StripLeadingSpaces (Field: byte);
var
  i: integer;
begin
  if DataStrL>0 then
    begin
      i := 1;
      while (DataStr[i]=' ') and (i<Field) do
        inc(i);
      DataStrL := succ(Field-i);
      Move16 (DataStr[i],DataStr[1],DataStrL);
    end;
end;

procedure ConvertDataToStr;
begin
  with TopEntry,DataPad do
    begin
      StoreMode := false;
      TransferData (VarAddr^);
      case TypeOfData of
        Bytes..Words,LongInts: DataStr := StrL (Ldata);
        ShortInts:             DataStr := StrL (SIdata);
        Integers:              DataStr := StrL (Idata);
        Reals:
          begin
            if Decimals<0 then
              DataStr := StrRF (Rdata,Field)
            else
              begin
                DataStr := StrRFD (Rdata,Field,Decimals);
                if DataStrL>Field then
                  DataStr := StrRF (Rdata,Field);
              end;
            StripLeadingSpaces (Field);
          end;
        Chars: DataStr := Cdata;
      else DataStr := Sdata;
      end;  { case }
    end;    { with }
end;

procedure ConvertStrToData;
var  i: integer;
begin
  with TopEntry,DataPad do
    begin
      Valid := true;
      case TypeOfData of
        Chars:  if DataStrL=0  then
                     Cdata := #00
                else Cdata := DataStr[1];
        Reals: begin
                 val (DataStr,Rdata,i);
                 Valid := i=0;
               end;
        Bytes..LongInts:
          begin
            val (DataStr,Ldata,i);
            Valid := i=0;
            if Valid then
              case TypeOfData of
                Bytes:     Valid := Ldata=Bdata;
                Words:     Valid := Ldata=Wdata;
                ShortInts: Valid := Ldata=SIdata;
                Integers:  Valid := Ldata=Idata;
              end;
          end;
      else  Sdata:=DataStr;
      end;  { case }
      if not Valid then  {Added [GAF]}
        begin
          if ErrHandlerProc<>nil then
            CallErrHandler;
          ExtKey:=false;  {Set keys to force edit to stay here}
          Key:=NullKey;
        end;
      {$ifdef UseMsgLineCode } {HERE - hook for invalid entry}
      if not Valid then
        ShowErrMsg (ord(InvalidEM));  { Invalid Entry message }
      {$endif }
    end;
end;

procedure StoreData;
begin
  with TopEntry,DataPad do
    if Valid then
      begin
        RangeOK := true;
        if CheckRangeProc<>nil then
          CallCheckRange;
        DataStored := RangeOK;    { OK to set in advance }
        if DataStored then
          begin
            StoreMode := true;
            TransferData (VarAddr^);
          end
        else
          Key:=NullKey; {To stay in data entry}
    end
end;

procedure UpdateField (Attr: integer);
var
  FieldStr,SubStr: string;
  L: byte absolute SubStr;
begin
  with TopEntry,DataPad,TWS do
    begin
      SubStr := copy (DataStr,FieldIndex,Field);
      if Justify=Left then
           FieldStr := StrSL (SubStr,Field)   { Fill up blanks w/ spaces }
      else FieldStr := StrSR (SubStr,Field);
      if DataWriteMode=ScrnRel then
         Qwrite (Row,Col,Attr,FieldStr)
      else
         Qwrite (pred(Wrow+Row),pred(Wcol+Col),Attr,FieldStr);
    end;
end;

procedure MoveCursor;
begin
  with TopEntry,DataPad do
    begin
      if DataWriteMode=ScrnRel then
        GotoRC (Row,Col+CursorOfs)
      else
        WGotoRC (Row,Col+CursorOfs);
      if InsertOn then
           SetCursor (CursorHalfBlock)
      else SetCursor (CursorUnderline);
    end;
end;

function MaxCursorOfs: byte;
begin
  with TopEntry,DataPad do
    MaxCursorOfs := MinI (DataStrL,Field-Flex);
end;

function MaxFieldIndex: byte;
begin
  with TopEntry,DataPad do
    MaxFieldIndex := MaxI (1,succ(DataStrL-Field+Flex));
end;

procedure CursorFirst;
begin
  with DataPad do
    begin
      FieldIndex := 1;
      CursorOfs  := 0;
    end;
end;

procedure CursorLast;
begin
  with TopEntry,DataPad do
    if MaxField>1 then
      begin
        Flex := byte(MaxField<>Field);
        FieldIndex := MaxFieldIndex;
        CursorOfs  := MaxCursorOfs;
      end
    else CursorFirst;
end;

procedure CursorLeft;
begin
  with DataPad do
    begin
      if CursorOfs=0 then
           FieldIndex := MaxI (1,pred(FieldIndex))
      else dec(CursorOfs);
    end;
end;

procedure CursorRight;
begin
  with TopEntry,DataPad do
    if MaxField>1 then
      begin
        if CursorOfs=MaxCursorOfs then
             FieldIndex := MinI (succ(FieldIndex),MaxFieldIndex)
        else inc(CursorOfs);
      end;
end;

procedure DeleteChar;
begin
  with DataPad do
    Delete (DataStr,FieldIndex+CursorOfs,1);
end;

procedure BackSpace;
begin
  with TopEntry,DataPad do
    begin
      if (FieldIndex+CursorOfs>1) or (MaxField=1) then
        begin
          CursorLeft;
          DeleteChar;
          if (FieldIndex>1) and (CursorOfs=0) then
            begin
              CursorLeft;
              CursorRight;
            end;
        end;
    end;
end;

procedure ClrDataStr;
begin
  DataStr := '';
  CursorFirst;
end;

procedure ToggleInsert;
const  InsertBit = $80;
var  KeyStatus: byte absolute $0040:$0017;
begin
  KeyStatus := KeyStatus xor InsertBit;
end;

procedure AddChar;
var  DI: integer;    { DataStr Index }
begin
  with TopEntry,DataPad do
    begin
      if MaxField=1 then
        DataStr := Key    { Just overwrite the charcter }
      else
        begin
          if NewData then
            ClrDataStr;
          DI := FieldIndex+CursorOfs;
          if not InsertOn and (DI<=DataStrL) then
            begin
              DataStr[DI] := Key;
              CursorRight;
            end
          else
            if (DataStrL<MaxField) and (InsertOn or (DI>DataStrL)) then
              begin
                insert (Key,DataStr,DI);
                CursorRight;
              end;
        end;
    end;
end;

procedure ExtKeyEdit;
begin
  with TopEntry,DataPad do
    begin
      case Key of
        LArrKey:             CursorLeft;
        RArrKey:             CursorRight;
        DelKey:              DeleteChar;
        HomeKey,CtrlLArrKey: CursorFirst;
        EndKey,CtrlRArrKey:  CursorLast;
        InsKey:  ;
        {$ifdef UseHelpWndwCode } {Future help window call here}
        {HelpKey: PullHelpWndw (HelpWndwNum);}
        {$endif }
        {else CallCheckGlobalKeys;} {future global key handler call}
      end      { end case }
    end;
end;

procedure NormKeyEdit;
var DI: integer;    { DataStr Index }
begin
  with TopEntry,DataPad do
    begin
      if (Key in EntrySet[SetName]) then
        AddChar
      else
        begin
          case Key of
            ^S:  CursorLeft;
            ^D:  CursorRight;
            ^G:  DeleteChar;
            ^H,BSkey: BackSpace;
            ^A:  CursorFirst;
            ^F:  CursorLast;
            ^Y:  ClrDataStr;
            ^R,^U:
              begin
                ConvertDataToStr;
                CursorLast;
              end;
            ^V:  ToggleInsert;
          end      { end case }
        end;
    end;    { with }
end;

procedure DisplayField (Attr: integer);
begin
  with TopEntry,DataPad do
    begin
      ConvertDataToStr;
      Justify := JustifyOutput;
      if Justify=Left then
           FieldIndex := 1
      else FieldIndex := MaxI (1,succ(DataStrL-Field));
      if Attr=SameAttr then
        Attr := Oattr;
      UpdateField (Attr);
    end;
end;

procedure GetDataEntryRec (Index: word);
begin
  DEI := Index;
  TopEntry := DataEntry^[DEI];
end;

procedure DisplayFields; { (DEGroup : DEGroupRec; First,Last: byte); }
var
  i: integer;
begin
  if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
    runerror(204);
  DataEntry:=DEGroup.GroupPtr; {Point to proper DE group}
  for i:=First to Last do
    begin
      GetDataEntryRec (i);
      DisplayField (TopEntry.Oattr);
    end;
end;

procedure SaveData;
begin
  ConvertStrToData;
  StoreData;
end;

procedure EnterData;
begin
  with TopEntry,DataPad do
    begin
      ToggleNumLock (On);
      ConvertDataToStr;
      CursorLast;
      Justify := Left;
      repeat
        if WaitForKbd then
          begin
            UpdateField (Iattr);
            MoveCursor;
          end;
        if not WaitForKbd then
          WaitForKbd:=true
        else
          ReadKbd(ExtKey,Key); {[GAF]}
        if TranslateProc<>nil then
          CallTranslate;
        if ExtKey then
             ExtKeyEdit
        else NormKeyEdit;
        NewData := false;
        if (Key=RetKey) then      { RetKey will even apply from Help window }
          SaveData;
      until (Key=RetKey) or (Key=EscKey) ;
      ToggleNumLock (Off);
    end;  { with TopEntry }
end;

procedure Enter; { (DEGroup : DEGroupRec; RecNum: word); }
var
  OldCursor:      word;
begin
  OldCursor := GetCursor;
  if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
    runerror(204);
  DataEntry:=DEGroup.GroupPtr; {Point to proper DE group}
  with TopEntry,DataPad do
    begin
      GetDataEntryRec (RecNum);
      if VarAddr = nil then {cause error and halt if nil pointer}
        runerror(204);
      NewData := true;
      EnterData;
      DisplayField (Oattr);
    end;
  SetCursor (OldCursor);
end;

procedure MoveCursorToField;
begin
  with TopEntry,DataPad,TWS do
    begin
      CursorOfs:=0;
      if DataWriteMode=ScrnRel then
        Qattr (Row,Col,1,Field,Hattr)
      else
        Qattr (pred(Wrow+Row),pred(Wcol+Col),1,Field,Hattr);
      MoveCursor;
    end;
end;

function RollInc (First,NumToRoll,Last: word): word;
begin
  if NumToRoll=Last then
       RollInc:=First
  else RollInc:=succ(NumToRoll);
end;

function RollDec (First,NumToRoll,Last: word): word;
begin
  if NumToRoll=First then
       RollDec:=Last
  else RollDec:=pred(NumToRoll);
end;

procedure EnterSeq; { (DEGroup : DEGroupRec; First,Last: word; VAR Start: word); }
var
  Edit: boolean;
  Attr: integer;
{}procedure HorizAdj (AdjacentCol,NearestCol: byte);
  var  i: word;
  begin
    for i:=First to Last do
      with DataEntry^[i] do
        if (Row=TopEntry.Row) and
           InRangeW(AdjacentCol,Col,NearestCol) then
          begin
            Start := i;
            NearestCol := Col;
          end;
{}end;
{}procedure HorizEnd (Dir: DirType);
  var
    i:      word;
    FarCol: byte;
  begin
    FarCol := TopEntry.Col;
    for i:=First to Last do
      with DataEntry^[i] do
        if (Row=TopEntry.Row) then
          if ((Dir=Right) and (Col>FarCol)) or
             ((Dir=Left ) and (Col<FarCol)) then
            begin
              Start  := i;
              FarCol := Col;
            end;
{}end;
{}procedure VertAdj (AdjacentRow,NearestRow: byte);
  var
    i:           word;
    NearestCols: byte;
    Cols:        integer;
    Closer:      boolean;
  begin
    NearestCols := 255;
    for i:=First to Last do
      with DataEntry^[i] do
        begin
          Cols := Col-TopEntry.Col;
          if Cols<0 then
            Cols := abs( MinI(Cols+Field,0) );
          if (Row=NearestRow) then
               Closer := Cols<NearestCols
          else Closer := InRangeW (AdjacentRow,Row,NearestRow);
          if Closer then
            begin
              Start := i;
              NearestRow  := Row;
              NearestCols := Cols;
            end;
        end;
{}end;
{}procedure NextField;
  begin
    Start := RollInc (First,Start,Last);
{}end;

var
  OldCursor:      word;
begin
  OldCursor := GetCursor;
  if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
    runerror(204);
  DataEntry:=DEGroup.GroupPtr; {Point to proper DE group}
  with TopEntry,DataPad do
    begin
      repeat
        GetDataEntryRec (Start);
        if VarAddr = nil then {cause error and halt if nil pointer}
          runerror(204);      {Didn't assign this entry}
        MoveCursorToField;
        if not WaitForKbd then
          WaitForKbd:=true
        else
          ReadKbd(ExtKey,Key); {[GAF]}
        Edit := false;
        if ExtKey then
          case Key of
            UpArrKey:            VertAdj  (pred(TopEntry.Row),  0);{ Prev row }
            DnArrKey:            VertAdj  (succ(TopEntry.Row),255);{ Next row }
            LArrKey:             HorizAdj (pred(TopEntry.Col),  0);{ Prev col }
            RArrKey:             HorizAdj (succ(TopEntry.Col),255);{ Next col }
            CtrlLArrKey,HomeKey: HorizEnd (Left);                { First char }
            CtrlRArrKey,EndKey:  HorizEnd (Right);               { Last char  }
            CtrlHomeKey,PgUpKey: Start := First;
            CtrlEndKey,PgDnKey:  Start := Last;
            ShiftTabKey:         Start := RollDec (First,Start,Last);
            InsKey: ;
            {$ifdef UseHelpWndwCode }
            {HelpKey: PullHelpWndw (1);} {future help here}
            {$endif }
            {else CallCheckGlobalKeys;} {future global key handler here}
          end
        else
          case Key Of
            RetKey:  Edit := true;
            TabKey:  NextField;
            EscKey:  ; { Exit sequence }
            ^V:      ToggleInsert;
          else
            Edit       := true;
            WaitForKbd := false;
          end;
        if Edit then
          begin
            NewData := Key<>RetKey;
            EnterData;
            if (Key=RetKey) and AutoTab then
              NextField;
            case Key of
              RetKey,EscKey:
                if (Start=DEI) then
                  DisplayField (Hattr);
            end;
            if Key=EscKey
              then Key := #00;
          end;
        if Start<>DEI then
          DisplayField (Oattr);
      until (Key=EscKey) or (ExtKey and (Key=SeqDoneKey));
      DisplayField (Oattr);
    end;  { with }
  SetCursor (OldCursor);
end;

function GetJustify (Justify: DirType; TOD: TypeOfDataType): DirType;
begin
  if Justify=NoDir then
    begin
      if TOD<=UserNums then
           GetJustify := Right   { for nums }
      else GetJustify := Left;   { for chars and strings }
    end
  else GetJustify:=Justify;
end;

function GetSetName (SN: SetNames; TOD: TypeOfDataType): SetNames;
begin
  if SN=NoSet then
    case TOD of
      Bytes,Words:         GetSetName := UnsignedSet;
      ShortInts..LongInts: GetSetName := SignedSet;
      Reals:               GetSetName := RealSet;
    else
      GetSetName := CharSet;
    end
  else GetSetName:=SN;
end;

procedure GetDataEntry; { (DEGroup : DEGroupRec; Index: word); }
begin
  if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
    runerror(204);
  DataEntry:=DEGroup.GroupPtr; {Point to proper DE group}
  DEI := Index;
  TopEntry := DataEntry^[DEI];
  fillchar(TopEntry,sizeof(TopEntry),0); {clear it}
end;

procedure SaveDataEntry;
begin
  with TopEntry do
    begin
      SetName := GetSetName (SetName,TypeOfData);
      if MaxField=0 then
        MaxField := Field;
      JustifyOutput := GetJustify (JustifyOutput,TypeOfData);
      if Iattr=0 then
        Iattr := DataEntryIattr;  { Default Input  attribute }
      if Oattr=0 then
        Oattr := DataEntryOattr;  { Output attribute }
    end;
  DataEntry^[DEI] := TopEntry;
end;

procedure AllocateDataEntries; {(var DEGroup : DEGroupRec; NumEntries : word);}
{Allocates memory for a group of data entries and assigns pointer to group rec}
var
  size: word;
begin
  Size:=sizeof(DataEntryRec)*NumEntries; {memory needed}
  with DEGroup do
    begin
      if InRangeW(1,NumEntries,MaxDataEntries) and HeapOK(Size) then
        begin
          getmem(GroupPtr,Size);
          NumInGroup:=NumEntries;
          fillchar(GroupPtr^,Size,0);
        end
      else
        begin
          GroupPtr:=nil; {range or other error}
          NumInGroup:=0;
        end;
    end; {with}
end;

procedure RemoveDataEntries; {(var DEGroup : DEGroupRec);}
{De-allocates DE recs created w/ Create}
begin
  if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
    runerror(204);
  with DEGroup do
    begin
      freemem(GroupPtr,sizeof(DataEntryRec)*NumInGroup);
      GroupPtr:=nil; {Clear rec}
      NumInGroup:=0;
    end; {with}
end;