Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/LOOKER.ZIP/LOOKER.PAS

Pascal/Delphi Source File | 1989-10-09 | 19.8 KB | 822 lines

unit looker;

interface

uses  TPCrt, TPEdit, TPString, TPWindow, TAccess;

var
  Fields : string;

procedure makeparmstr(Dtype:word; var field; Mask:string);

function Look(var KFile :IndexFile;  var DFile : DataFile; var Rcrd;
                       FldStr: string; Depth, X, Y: integer;
                       InKey:string; KeyMask: String): Longint;

implementation

const
   NumSet : set of char = ['0'..'9'];
   MaskSet  : set of char = ['@','*','#','x','X'];


var
  MainWAttr, EditWAttr, MainFAttr, EditFAttr,
  MainHAttr, EditHAttr, BarAttr: word;
  MainHeader, EditHeader{, Fields} : string;


function Expand(InString: string): string;
var i, x, r : integer;
  Temp1, Temp2 : String;
  Error: boolean;

begin
   i := 1; Error := false; Temp2 := '';
   while (i <= length(instring)) and (not error) do begin
      Temp1 := '';
      if instring[i] in NumSet then begin
            repeat
               Temp1 := Temp1 + Instring[i];
               inc(i);
            until not(Instring[i] in NumSet);
            val(Temp1, x, r);
            if r > 0 then Error := true;
            if x > 80 then Error:= true;
            if not Error then begin
               FillChar(Temp1, x+1, Instring[i]);
               Temp1[0] := chr(x);
               inc(i);
               Temp2 := Temp2 + Temp1
            end;
         end
      else begin
         Temp2 := Temp2 + Instring[i];
         inc(i);
      end;
   end;
   if Error then
      Expand := 'bad Mask'
   else
      Expand := Temp2
end;


procedure makeparmstr(Dtype:word; var field; Mask:string);
var
  tempstr:string;
begin
  Mask := Expand(Mask);
  tempstr:=long2str(seg(field));
  fields :=fields+','+tempstr;
  tempstr:=long2str(ofs(Field));
  fields:=fields+','+tempstr;
  tempstr:=long2str(dtype);
  if Mask = '' then Mask := ' ';
  fields:=fields+','+tempstr+','+Mask;
end;


function Look;

const
   EndKey    = $4F {#79};
   PgDnKey   = $51 {#81};
   PgUpKey   = $49 {#73};
   CRKey     = $0D {#13};
   UpKey     = $48 {#72};
   DwnKey    = $50 {#80};
   HomKey    = $47 {#71};

type
  ItemPointer = ^Item;
  Item = record
    Segment, Offset, Typ : word;
    Mask : string;
    Next : ItemPointer
  end;

var
  List, Spec, FrontNode, RearNode : ItemPointer;

var
  T_Key, TmpKy,
  PointKey, SaveKey    : String;
  Line, NewX,
  DatRef, SaveRef      : LongInt;
  KeyWord              : word;
  Segment, Offset      : integer;
  Main,SubWin          : WindowPtr;
  WindowsOn, Complete  : boolean;
  WinWidthStr          : string;
  Width                : word;
  NumNodes             : integer;
  DupKeys              : boolean;

  procedure ErrorMem(ErrNbr:integer);
  var
   OpStr : string;

  begin
    window(1,1,80,25);
    NormVideo;
    ClrScr;
    FastWrite('Insufficient memory available to continue processing.',10,13,MainWAttr);
    Case ErrNbr of
      1 : OpStr := '  Unable to allocate enough memory to make Main window!!';
      2 : OpStr := '  Unable to allocate enough memory to make Edit window!!';
      3 : OpStr := 'Unable to allocate enough memory to display Main window!!';
      4 : OpStr := 'Unable to allocate enough memory to display Edit window!!';
    end;
    FastWrite(OpStr,11,11,MainWAttr);
    Halt(1);
  end;

  procedure Beep;
  begin
    write(^G);
  end;

{----- Construct the windows and display them...if false is returned by -----}

  procedure DisplayMain;
  begin
    if not MakeWindow(Main,X,Y,X+Width,Y+Depth,True,True,True,
                      MainWAttr,MainFAttr,MainHAttr,MainHeader) then
      ErrorMem(1)
    else
       if not MakeWindow(SubWin,1,23,80,25,True,True,True,
                         EditWAttr,EditFAttr,EditHAttr,EditHeader) then
         ErrorMem(2)
       else
          if not DisplayWindow(SubWin) then
            ErrorMem(3)
          else
             begin
               FastWriteWindow('Use Arrows, PgUp, PgDn, Home, End, or Enter String: ',1,2,MainWAttr);
               if not DisplayWindow(Main) then
                 ErrorMem(4);
             end;
  end;

  procedure ClearBox;
  begin
     ClrScr;
  end;



function IVal(NumStr: string) : integer;
var result, TempVal : integer;
begin
   val(NumStr, TempVal, Result);
   if Result > 0 then
      IVal := 0
   else
      IVal := TempVal
end;

Procedure DisposeList;
begin
  List := FrontNode;
  while list <> nil do begin
    Dispose(List);
    List := List^.next;
  end;
end;

{--- Build a Queue linked list of the FldStr Parameters ---}

procedure ParseFldStr;

var
  i : integer;
  TempStr : string;

{--- extract the individual elements from the
     parameter list (FldStr) ---}

procedure BuildTemp;
begin
 TempStr := '';
 if FldStr[i] = ',' then inc(i);
 while (FldStr[i] <> ',') and (i <= length(FldStr))  do begin
    TempStr := TempStr + FldStr[i];
    inc(i);
  end;
end;

{--- build the linked list ---}

begin
  WinWidthStr := '';
  i := 2;
  NumNodes := 0;
  FrontNode := nil;
  while i < length(FldStr) do begin
    inc(NumNodes);
    new(Spec);
      BuildTemp;
      Spec^.Segment := Ival(TempStr);
      BuildTemp;
      inc(i);
      Spec^.Offset := Ival(TempStr);
      BuildTemp;
      inc(i);
      Spec^.Typ := Ival(TempStr);
      BuildTemp;
      inc(i);
      TempStr := Expand(TempStr);
      Spec^.Mask := TempStr;
      WinWidthStr := WinWidthStr + TempStr;
      Spec^.next := nil;
      if FrontNode = nil then begin
      FrontNode := Spec;
      RearNode := Spec;
    end else begin
      RearNode^.next := Spec;
      RearNode := Spec;
    end;
  end;
  if FldStr = '' then
    Width := Length(KeyMask)+4
  else
    Width := length(WinWidthStr)+Length(KeyMask)+NumNodes*2+4;
  if Width+x > 80 then Width := 80-x;
end;

  {-----Construct the string of the data fields -----}

function ConstructString: String;
  var
    TS,PS  : String;
    Len, lngth, i,j: integer;
    Segment, Offset, Typ :word;
    Mask : string;
    Dummyint : ^integer;
    DummyLong: ^longint;
    DummyReal: ^real;
    DummyStr : ^string;
    DummyChar: ^char;

{--- count the number of delimeters
     ex: '(###)###-####' would return 3 - one each for the parentheses
     and one for the dash ---}

function InValids(Msk:string): integer;
var
  i, count: integer;

begin
  count := 0;
  for i := 1 to length(Msk) do
    if not(Msk[i] in MaskSet) then inc(count);
  InValids := count;
end;

{--- Insert the delimeters in the string;
     ex: Mask = '##/##', PStr = '1234'
     then InsertMask will change PStr to 12/34 ---}

procedure InsertMask(Msk: string; var PStr: string);
var
 i,j : integer;
begin
  i := 1;
  for j := 1 to length(Msk) do
    if (Msk[j] in MaskSet) then begin
      Msk[j] := Pstr[i];
      inc(i);
    end;
  PStr := Msk;
end;

begin
  TS := '';
  PS := '';
  List := FrontNode;
  PointKey := Pad(PointKey,length(KeyMask));
  InsertMask(KeyMask,PointKey);
  if PointKey <> '' then TS := ' '+PointKey+' ';
  while (list <> nil) do begin
    Segment := List^.Segment;
    Offset  := List^.Offset;
    Typ := List^.Typ;
    Mask := List^.Mask;
    PS := '';
    case Typ of
      1 : begin {string}
            DummyStr := ptr(segment,offset);
            PS := DummyStr^;
            PS := Pad(PS,length(mask));
            InsertMask(Mask,PS);
          end;
    2,3 : begin {longint,integer}
             case Typ of
             3: begin
                  DummyLong:= ptr(segment,offset);
                  PS := Long2Str(DummyLong^);
                  PS := LeftPadCh(PS,'0',Length(Mask)-InValids(Mask));
                end;
             2: begin
                  DummyInt := ptr(segment,offset);
                  PS := Long2Str(DummyInt^);
                  PS := LeftPadCh(PS,'0',Length(Mask)-InValids(Mask));
                end;
             end;
             InsertMask(Mask,PS);
             PS := Pad(PS,Length(Mask));
          end;
      4: begin {real}
           DummyReal := ptr(segment,offset);
           PS := Form(Mask,DummyReal^);
         end;
      5: begin {char}
           DummyChar := ptr(segment,offset);
           PS:= DummyChar^;
           PS := Pad(PS,Length(Mask));
           InsertMask(Mask,PS);
         end;
    end;
    TS := TS+' ';
    TS := TS+' '+PS;
    List := List^.next;
   end;
   TS := copy(TS,1,width-2);
   ConstructString := TS+' ';
   PointKey := SaveKey;
end;

procedure DisplayFieldsLo;
begin
  FastWrite(ConstructString,Line,NewX-1,MainWAttr);
end;

procedure DisplayFieldsHi;
begin
    FastWrite(ConstructString,Line,NewX-1,BarAttr);
end;

{----- Display the first page in the box -----}

procedure FillWindow;
  begin
    Line := Y+1;
    while OK and (Line < (Y+Depth)) do begin
      NextKey(KFile,DatRef,PointKey);
      if OK then GetRec(DFile,DatRef,Rcrd);
      if OK then DisplayFieldsLo;
      inc(Line);
    end;
    ClearKey(KFile);
    NextKey(KFile,DatRef,PointKey);
    if OK then GetRec(DFile,DatRef,Rcrd);
    Line := Y+1;
    DisplayFieldsHi;
    Line := Y+1;
end;

procedure Home;
begin
  ClearBox;
  ClearKey(KFile);
  FillWindow;
  TmpKy := PointKey;
end;

  procedure Endd;
  var
     i,j : integer;

  begin
    ClearBox;
    i := 1; j := 1;
    Line := Y+1;
    ClearKey(KFile);

{----- Go to EOF and back up one page -----}
    repeat
      PrevKey(KFile,DatRef,PointKey);
      inc(i);
    until (i = (Depth)) or (not OK);
    OK := true;
{----- Save the first display key -----}
    SaveKey := PointKey;
    if DupKeys then SaveRef := DatRef;
    if OK then begin
      GetRec(DFile,DatRef,Rcrd);
      DisplayFieldsHi;
    end;
    inc(Line);
    SearchKey(KFile,DatRef,SaveKey);
    if DupKeys and (SaveRef<>DatRef) then
      repeat
        NextKey(KFile,DatRef,PointKey);
      until SaveRef=DatRef;

{----- Display the page from the current pointer -----}
    repeat
      NextKey(KFile,DatRef,PointKey);
      if OK then GetRec(DFile,DatRef,Rcrd);
      if OK then DisplayFieldsLo;
      inc(Line); inc(j);
    until (i-1=j) or (not OK);
    Line := Y+1;

{----- Get and display the top of page pointer -----}
    FindKey(KFile,DatRef,SaveKey);
    if DupKeys and (SaveRef<>DatRef) then
      repeat
        NextKey(KFile,DatRef,PointKey);
      until SaveRef=DatRef;
    if OK then GetRec(DFile,DatRef,Rcrd);
  end;

  procedure SearchString(S:String);
  begin
    if WindowIsActive(SubWin) then
      WindowsOn := SetTopWindow(Main)
    else
      WindowsOn := DisplayWindow(Main);
    ClearBox;

{----- Find the first key >= the input string and display it ----}
    SearchKey(KFile,DatRef,S);
    if OK then begin
      GetRec(DFile,DatRef,Rcrd);
      PointKey := S;
      DisplayFieldsHi;
      Inc(Line);

{----- Display the rest of the page -----}
      while OK and (Line < (Y+Depth)) do begin
        NextKey(KFile,DatRef,PointKey);
        if OK then begin
          GetRec(DFile,DatRef,Rcrd);
          DisplayFieldsLo;
          inc(Line);
        end;
      end;
      Line := Y+1;
      SearchKey(KFile,DatRef,S);
      if OK then GetRec(DFile,DatRef,Rcrd);

{---- if search goes to EOF then list the last page -----}
    end else begin
      PrevKey(KFile,DatRef,PointKey);
      GetRec(DFile, DatRef,Rcrd);
      DisplayFieldsHi;
    end;

  end;

  procedure Search;
  var
    S, NewS   : String;
    count,i,j : integer;
    Escaped   : boolean;

  begin
    Line := Y+1;
    S := ' ';
    S := Trim(S);
    NewS := '';
    count := 1;
{----- Get the search string; Display the string as it is entered -----}
    ReadString(' ',24,54,15,MainFAttr,MainFAttr,count,Escaped,S);
    if WindowIsActive(SubWin) then
      WindowsOn := SetTopWindow(Main)
    else
      WindowsOn := DisplayWindow(Main);
    ClearBox;

{----- Find the first key >= the input string and display it ----}
    SearchKey(KFile,DatRef,S);
    if OK then begin
      GetRec(DFile,DatRef,Rcrd);
      PointKey := S;
      DisplayFieldsHi;
      Inc(Line);

{----- Display the rest of the page -----}
      while OK and (Line < (Y+Depth)) do begin
        NextKey(KFile,DatRef,PointKey);
        if OK then begin
          GetRec(DFile,DatRef,Rcrd);
          DisplayFieldsLo;
          inc(Line);
        end;
      end;
      Line := Y+1;
      SearchKey(KFile,DatRef,S);
      if OK then GetRec(DFile,DatRef,Rcrd);

{---- if search goes to EOF then list the last page -----}
    end else begin
      PrevKey(KFile,DatRef,PointKey);
      GetRec(DFile, DatRef,Rcrd);
      DisplayFieldsHi;
    end;

{------ Empty Keyboard buffer upon exit  -----}
    if CheckKbd(KeyWord) then
      KeyWord := ReadKeyWord;
  end;


  Procedure PageDown;
  var
    i : integer;

  begin
    i := 1;
    ClearBox;

{----- get the next page pointer -----}
    while OK and (i < Depth-1) and (i < Depth+Y-Line) do begin
      NextKey(KFile,DatRef,PointKey);
      inc(i);
    end;
    Line := Y + 1;

{----- Save the top of page pointer -----}
    SaveKey := PointKey;
    if DupKeys then SaveRef := DatRef;

    if OK then
      GetRec(DFile,DatRef,Rcrd);
    DisplayFieldsHi;

 {----- Display the rest of the page -----}
      while OK and (Line < Depth+Y-1) do begin
        inc(Line); inc(i);
        NextKey(KFile,DatRef,PointKey);
        if OK then begin
          GetRec(DFile,DatRef,Rcrd);
          DisplayFieldsLo;
        end;
      end;

{----- Get the saved top of page pointer -----}

      FindKey(KFile,DatRef,SaveKey);
      if DupKeys and (DatRef <> SaveRef) then
       repeat
         NextKey(KFile,DatRef,PointKey);
        until (DatRef=SaveRef);
      Line := Y+1;

{----- if EOF then go back to last record to prevent
       going back to the top of file                -----}
      if not OK then begin
        PrevKey(KFile,DatRef,PointKey);
        if OK then GetRec(DFile,DatRef,Rcrd);
      end;
  end;

procedure PageUp;
  var
    i : integer;

  begin
    i := 1;
    ClearBox;

{----- Get the top of page pointer -----}

    while OK and (i < Depth+Line-Y-2) do begin
      PrevKey(KFile,DatRef,PointKey);
      inc(i);
    end;

{----- If top of file then display the first page -----}
    if not OK then begin
      Line := Y+1;
      OK := True;
      Home;
    end else
    begin
      Line := Y+1;

{----- Save the top of page pointer -----}
      SaveKey := PointKey;
      if DupKeys then SaveRef := DatRef;

{ ----- Hilite the the first display record -----}
      if OK then begin
        GetRec(DFile,DatRef,Rcrd);
        DisplayFieldsHi;
      end;

{----- Display the rest of the page -----}
      while OK and (Line < Depth+Y-1) do begin
        inc(Line); inc(i);
        NextKey(KFile,DatRef,PointKey);
        if OK then begin
          GetRec(DFile,DatRef,Rcrd);
          DisplayFieldsLo;
        end;
      end;

{----- Get the top of page pointer -----}
      FindKey(KFile,DatRef,SaveKey);
      if DupKeys and (SaveRef<>DatRef) then
        repeat
          NextKey(KFile,DatRef,PointKey);
        until (SaveRef=DatRef);
      Line := Y+1;

{----- If top of file then reset the pointer to top of file to
       prevent wrapping back to the top of file -----}
       if not OK then begin
         NextKey(KFile,DatRef,PointKey);
         if OK then GetRec(DFile,DatRef,Rcrd);
      end;
    end;
  end;



  procedure ScrollUp;
  begin
     PrevKey(KFile,DatRef,PointKey);
     if OK then GetRec(DFile,DatRef,Rcrd);
     if not OK then NextKey(KFile,DatRef,PointKey)
     else

{----- if at the top of the box -----}
       begin
         if ((Line = Y+1) and OK) then
           begin
             NextKey(KFile,DatRef,PointKey);

{----- Redisplay the old fields with normal attributes -----}
             if OK then begin
               GetRec(DFile,DatRef,Rcrd);
               DisplayFieldsLo;
             end;

{-----  scroll the display area -----}
             PrevKey(KFile,DatRef,PointKey);
             if OK then GetRec(DFile,DatRef,Rcrd);
             ScrollWindowDown(x+1,y+1,x+width-1,Y+depth-1,1);
             DisplayFieldsHi;
          end

{----- Move up one line -----}
       else
         begin
           ChangeAttribute(Width-1,Line,1+x,MainWAttr);
           Dec(Line);
           ChangeAttribute(Width-1,Line,1+x,BarAttr);
         end;
     end;
   end;


  procedure ScrollDn;

  begin
    NextKey(KFile,DatRef,PointKey);
    if OK then GetRec(DFile,DatRef,Rcrd);
    if not OK then PrevKey(KFile,DatRef,PointKey)
    else

{----- if at the bottom of the box  -----}
       begin
         if ((Line > (Y+Depth-2)) and OK)  then
           begin
             PrevKey(KFile,DatRef,PointKey);

{----- redisplay the current fields with normal attributes -----}
             if OK then begin
               GetRec(DFile,DatRef,Rcrd);
               DisplayFieldsLo;
             end;

{-----  scroll the display area -----}
             NextKey(KFile,DatRef,PointKey);
             if OK then GetRec(DFile,DatRef,Rcrd);
             ScrollWindowUp(x+1,y+1,x+width-1,Y+depth-1,1);
             if OK then DisplayFieldsHi;
          end
       else

{----- if not at the bottom of the box....-----}
         begin
           ChangeAttribute(Width-1,Line, 1+x,MainWAttr);
           inc(Line);
           ChangeAttribute(Width-1,Line,1+x,BarAttr);
         end;
       end;
  end;

procedure CheckCoordinates;
begin
  if y > 18 then y := 18;
  if y < 4 then y := 4;
  if x < 1 then x := 1;
  if x > 74 then x := 74;
  if Y+Depth > 22 then Depth := 21-y;
end;

begin  { Look}
  HiddenCursor;
{----- Get the address of the data field -----}

  KeyMask := Expand(KeyMask);
  ParseFldStr;
  Complete := False;
  PointKey := '';
  CheckCoordinates;
  DisplayMain;
  NewX := X+2;
  Line := Y+1;
  if KFile.AllowDuplKeys then DupKeys := true else DupKeys := false;
  if InKey[0] = '0' then begin
    ClearKey(KFile);

{----- X is where the left box line is drawn; leave a space -----}

    NextKey(KFile,DatRef,PointKey);
    Home;
    ClearKey(KFile);
    NextKey(KFile,DatRef,PointKey);
    if OK then GetRec(DFile,DatRef,Rcrd);

{----- Y is where the top box line is drawn; start on the next line -----}

    TmpKy := PointKey;
  end
  else
    SearchString(InKey);
  repeat
    if CheckKbd(KeyWord) then
      begin
        if Lo(KeyWord) = 0 then
          begin
            KeyWord := ReadKeyWord;
            case Hi(KeyWord) of
              UpKey  : ScrollUp;
              DwnKey : ScrollDn;
              HomKey : Home;
              EndKey : Endd;
              PgUpKey: PageUp;
              PgDnKey: PageDown;
            end;
          end
        else
          begin
            if WindowIsActive(Main) then
              WindowsOn := SetTopWindow(SubWin)
            else
              WindowsOn := DisplayWindow(SubWin);
            if Lo(KeyWord) <> CRKey then
              Search
            else
              begin
                Complete := True;

{---------- Empty Keyboard buffer upon exit from function----------}

                if CheckKbd(KeyWord) then
                  KeyWord := ReadKeyWord;
              end;
          end;
      end;
  until Complete;
  SubWin := EraseTopWindow;
  DisposeWindow(SubWin);
  Main := EraseTopWindow;
  DisposeWindow(Main);
  Look := DatRef;
  NormalCursor;
  DisposeList;
end;

procedure InitializeDefaults;
begin
  if CurrentDisplay <> MonoHerc then begin
    MainWAttr := 30;
    MainFAttr := 30;
    MainHAttr := 30;
    EditWAttr := 30;
    EditFAttr := 30;
    EditHAttr := 30;
    BarAttr   := 63;
  end else begin
    MainWAttr := 7;
    MainFAttr := 7;
    MainHAttr := 7;
    EditWAttr := 7;
    EditFAttr := 7;
    EditHAttr := 7;
    BarAttr   := 15;
  end;
  MainHeader := '';
  EditHeader := '';
end;

begin
 InitializeDefaults;
end.