Topspeed_JPI/TS-V3/MODBASE/DBSTUFF.MOD

IMPLEMENTATION MODULE DBStuff;
(*
 *  ModBase
 *  Release 3.0
 *  (c) Copyright 1986 - 1991 PMI
    Copyright 1988 - 1991 John McMonagle
 *  P.O. Box 8402
 *  Green Bay Wi 53308
 *  All Rights Reserved
 *  by Ed Ross
 *)

FROM DBIndxes IMPORT DBIndex,GoTop,FindPositionCh,
     CurrentRec,CurrentKeyCh,NextRecord;
FROM ModBase3 IMPORT DBFile,ReadDBRec,DeleteRecord,DBFieldDescriptor;     
FROM StrConv IMPORT CardinalToStr;
FROM ScrnTypes IMPORT DisplayFrame;
FROM ControlUtils IMPORT ReadInput,ChangeField;
FROM DateFunctions IMPORT Date,DateToStr,StrToDate;
FROM GenLists IMPORT GenList,DisposeList,ListInsert,NewList,
                     GetElmt,ListInsertAdr,ListLength,Initialized;
FROM StrEdit IMPORT CrunchBlanks,SetLength,Append,
     CAPstr,DeleteChar;
FROM Str IMPORT Length,Compare,Copy;
FROM PosUtils IMPORT Pos,Present;
FROM LowLevel IMPORT Fill;
FROM SYSTEM IMPORT ADR,SIZE,ADDRESS;
FROM HandleIO IMPORT FileExists,OpenFile,SetFilePtr,CreateFile,BlockWrite,
     CloseHandle,BlockRead,FromStart;
FROM StringIO IMPORT ErrorMessage;
     
VAR
  CharSet : SET OF CHAR;
  J : CHAR;

PROCEDURE MakeDescriptor(VAR Desc : DBFieldDescriptor;
                         Name : ARRAY OF CHAR; Size : CARDINAL;
			 Dec  : CARDINAL;Type : CHAR);
BEGIN
  Fill(ADR(Desc),SIZE(Desc),0);
  Copy(Desc.name , Name);
  Desc.size := Size;
  Desc.decplaces := Dec;			
  Copy(Desc.fldtype , Type);
END MakeDescriptor;			 

PROCEDURE MakeSeqNbr(SeqFile,  (* file name where seq kept -no extention *)
                     Prefix : ARRAY OF CHAR; (*key prefix "91-','C'*)
	             VAR  Key : ARRAY OF CHAR); (* returned key *)
	 

VAR
 H : CARDINAL;
 Str : ARRAY [0..8] OF CHAR;
 Seq : CARDINAL;
 FileName : ARRAY[0..15] OF CHAR;	 
 EM : ErrorMessage;
 J : CARDINAL;
BEGIN
  Copy(FileName , SeqFile);
  CrunchBlanks(FileName);
  IF Pos(FileName,'.') < HIGH(FileName)+1
    THEN SetLength(FileName,Pos(FileName,'.'));
    END;
  Append(FileName,'Seq');
  IF FileExists(FileName)
    THEN
      EM := OpenFile(H,FileName);
      EM := BlockRead(H,ADR(Seq),SIZE(Seq));
      SetFilePtr(H,FromStart,0);
    ELSE
      EM := CreateFile(H,FileName);   (* initialize seq number *)
      Seq := 999;      
    END;
    INC(Seq);
    EM := BlockWrite(H,ADR(Seq),SIZE(Seq)); (* update the file *)
    EM := CloseHandle(H);
    CardinalToStr(Seq,5,Str);
    Copy(Key , Prefix);
    FOR J := 0 TO Length(Str) DO
      IF Str[J] = ' '
        THEN Str[J] := '0';
	END;
      END;	
    Append(Key,Str);
    MakeKey(Key);
END MakeSeqNbr;


PROCEDURE MakeKey(VAR Key : ARRAY OF CHAR);
VAR J : CARDINAL;
    L : CARDINAL;
 BEGIN
   CAPstr(Key);
   L := Length(Key);
   IF L > 0
     THEN
       DEC(L);
     END;  
   FOR J := 0 TO L DO
     IF NOT (Key[J] IN CharSet)
       THEN Key[J] := ' ';
       END;
   END;  
   DeleteChar(' ',Key);

END MakeKey;    




PROCEDURE ReadDateField( DF : DisplayFrame; VAR D : Date; 
                        FldName : ARRAY OF CHAR);
VAR
 S : ARRAY [0..15] OF CHAR;
 Ok : BOOLEAN;
BEGIN
 ReadInput(DF,S,FldName);
 StrToDate(S,D,Ok);
END ReadDateField;

PROCEDURE ChangeDateField(VAR DF : DisplayFrame; D : Date; 
                          FldName : ARRAY OF CHAR);
VAR
  S : ARRAY[0..15] OF CHAR;
  B : BOOLEAN;
BEGIN
  DateToStr(D,S,B);
  ChangeField(DF,S,FldName,TRUE);
END ChangeDateField;   



PROCEDURE ReadAllRecs(VAR DBF : DBFile; ReadProc :ReadRec; VAR TheList : GenList);

VAR
 TmpList : GenList;
 LI : LONGINT;
 J : CARDINAL;
 Code : CARDINAL;
 RecAddr : ADDRESS;
 Size : CARDINAL;
BEGIN
 NewList(TmpList);
 FOR J := 1 TO ListLength(TheList) DO
   GetElmt(TheList,J,LI,Code);
   ReadDBRec(DBF,LI);
   ReadProc(RecAddr,Size);
   ListInsertAdr(RecAddr,Size,1,TmpList,J)
 END;
 DisposeList(TheList);
 TheList := TmpList;  
 
END ReadAllRecs;

PROCEDURE DeleteAllRecs(VAR DBF : DBFile; TheList : GenList);
VAR
  LI : LONGINT;
  J : CARDINAL;
  Code : CARDINAL;
BEGIN
 FOR J := 1 TO ListLength(TheList) DO
   GetElmt(TheList,J,LI,Code);
   ReadDBRec(DBF,LI);  (* position data file *)
   DeleteRecord(DBF);
 END;  
END DeleteAllRecs;  
		      
PROCEDURE FindAll(Idx : DBIndex; KeyExp : ARRAY OF CHAR;
		  Condition : ConditionType;                  
		  VAR TheList : GenList );
		  
VAR
  B : BOOLEAN;	
  Str : ARRAY[0..80] OF CHAR;	  
  Cond : INTEGER;
  CRec : LONGINT;
BEGIN
  IF Initialized(TheList)
    THEN
      DisposeList(TheList);
    END;  
  NewList(TheList);
  CASE Condition OF 
      LT,LE         : GoTop(Idx);
                   B := TRUE;
     |EQ,BeginsWith,GE : FindPositionCh(Idx,KeyExp,B);
  END; (* end case of *)
  IF Condition = BeginsWith
    THEN
      CurrentKeyCh(Idx,Str);    (* get the current key *) 
      B := (Pos(KeyExp,Str) = 0)
    END;
  IF NOT B
    THEN RETURN; 
    END;

  LOOP
   CurrentKeyCh(Idx,Str);    (* get the current key *)
   Cond := Compare(KeyExp,Str);  (* do it here so I do it only once*)
   CASE Condition OF
     LT : IF Cond = 1
          THEN
	    EXIT;   (* done with this loop *)
          END;      
    |LE : IF Cond < 1
            THEN
              ListInsert(CurrentRec(Idx),1,TheList,1);  (* put in front of the list*)
	    END;  
    |EQ : IF Cond = 0
            THEN
  	      ListInsert(CurrentRec(Idx),1,TheList,1);  (* put in front of the list*)
            ELSE
	      EXIT;
	   END;
    |GE  : IF Cond >= 0	      	    
              THEN
	        ListInsert(CurrentRec(Idx),1,TheList,1);  (* put in front of the list*)
    	      END;	
    |BeginsWith :
           IF Pos(KeyExp,Str) = 0
	     THEN
  	       ListInsert(CurrentRec(Idx),1,TheList,1);  (* put in front of the list*)	  
	     ELSE
	       EXIT;
	    END;   
    |Contains  : IF Present(KeyExp,Str)
                  THEN
		   ListInsert(CurrentRec(Idx),1,TheList,1); 
		  END;
   END;    (* end of case condition of *)
   CRec := CurrentRec(Idx);   
   IF NOT NextRecord(Idx, CRec)	   
     THEN
       EXIT;
     END;  
  END;  (* end of loop *)         	    

   
END FindAll;	

BEGIN
  CharSet := CharSet / CharSet;
  FOR J := 'A' TO 'Z'  DO
   INCL ( CharSet,J);
   END;  
  FOR J := '0' TO '9' DO
   INCL(CharSet,J);
   END; 
 INCL(CharSet,'-');   
 INCL(CharSet,'&');
 INCL(CharSet,'!');
 INCL(CharSet,'?');
	  
END DBStuff.