Listing: 1 IMPLEMENTATION MODULE DBStuff; 2 (* 3 * ModBase 4 * Release 3.0 5 * (c) Copyright 1986 - 1991 PMI 6 Copyright 1988 - 1991 John McMonagle 7 * P.O. Box 8402 8 * Green Bay Wi 53308 9 * All Rights Reserved 10 * by Ed Ross 11 *) 12 13 FROM DBIndxes IMPORT DBIndex,GoTop,FindPositionCh, 14 CurrentRec,CurrentKeyCh,NextRecord; 15 FROM ModBase3 IMPORT DBFile,ReadDBRec,DeleteRecord,DBFieldDescriptor; 16 FROM StrConv IMPORT CardinalToStr; 17 FROM ScrnTypes IMPORT DisplayFrame; 18 FROM ControlUtils IMPORT ReadInput,ChangeField; 19 FROM DateFunctions IMPORT Date,DateToStr,StrToDate; 20 FROM GenLists IMPORT GenList,DisposeList,ListInsert,NewList, 21 GetElmt,ListInsertAdr,ListLength,Initialized; 22 FROM StrEdit IMPORT CrunchBlanks,SetLength,Append, 23 CAPstr,DeleteChar; 24 FROM Str IMPORT Length,Compare,Copy; 25 FROM PosUtils IMPORT Pos,Present; 26 FROM LowLevel IMPORT Fill; 27 FROM SYSTEM IMPORT ADR,SIZE,ADDRESS; 28 FROM HandleIO IMPORT FileExists,OpenFile,SetFilePtr,CreateFile,BlockWrite, 29 CloseHandle,BlockRead,FromStart; 30 FROM StringIO IMPORT ErrorMessage; 31 32 VAR 33 CharSet : SET OF CHAR; ***** ^ not supported yet 34 J : CHAR; 35 36 PROCEDURE MakeDescriptor(VAR Desc : DBFieldDescriptor; 37 Name : ARRAY OF CHAR; Size : CARDINAL; ***** ^ not supported yet 38 Dec : CARDINAL;Type : CHAR); 39 BEGIN 40 Fill(ADR(Desc),SIZE(Desc),0); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 41 Copy(Desc.name , Name); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 42 Desc.size := Size; ***** ^ not supported yet ***** ^ not supported yet 43 Desc.decplaces := Dec; ***** ^ not supported yet ***** ^ not supported yet 44 Copy(Desc.fldtype , Type); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 45 END MakeDescriptor; ***** ^ not supported yet 46 47 PROCEDURE MakeSeqNbr(SeqFile, (* file name where seq kept -no extention *) 48 Prefix : ARRAY OF CHAR; (*key prefix "91-','C'*) ***** ^ not supported yet 49 VAR Key : ARRAY OF CHAR); (* returned key *) ***** ^ not supported yet 50 51 52 VAR 53 H : CARDINAL; 54 Str : ARRAY [0..8] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 55 Seq : CARDINAL; 56 FileName : ARRAY[0..15] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 57 EM : ErrorMessage; 58 J : CARDINAL; 59 BEGIN 60 Copy(FileName , SeqFile); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 61 CrunchBlanks(FileName); ***** ^ not supported yet ***** ^ not supported yet 62 IF Pos(FileName,'.') < HIGH(FileName)+1 ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 63 THEN SetLength(FileName,Pos(FileName,'.')); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 64 END; 65 Append(FileName,'Seq'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 66 IF FileExists(FileName) ***** ^ not supported yet ***** ^ not supported yet 67 THEN 68 EM := OpenFile(H,FileName); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 69 EM := BlockRead(H,ADR(Seq),SIZE(Seq)); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 70 SetFilePtr(H,FromStart,0); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 71 ELSE 72 EM := CreateFile(H,FileName); (* initialize seq number *) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 73 Seq := 999; 74 END; 75 INC(Seq); ***** ^ undeclared identifier ***** ^ not supported yet 76 EM := BlockWrite(H,ADR(Seq),SIZE(Seq)); (* update the file *) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 77 EM := CloseHandle(H); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 78 CardinalToStr(Seq,5,Str); ***** ^ not supported yet ***** ^ not supported yet 79 Copy(Key , Prefix); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 80 FOR J := 0 TO Length(Str) DO ***** ^ not supported yet ***** ^ not supported yet 81 IF Str[J] = ' ' ***** ^ not supported yet ***** ^ not supported yet 82 THEN Str[J] := '0'; ***** ^ not supported yet ***** ^ not supported yet 83 END; 84 END; 85 Append(Key,Str); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 86 MakeKey(Key); ***** ^ undeclared identifier ***** ^ not supported yet 87 END MakeSeqNbr; ***** ^ not supported yet 88 89 90 PROCEDURE MakeKey(VAR Key : ARRAY OF CHAR); ***** ^ not supported yet 91 VAR J : CARDINAL; 92 L : CARDINAL; 93 BEGIN 94 CAPstr(Key); ***** ^ not supported yet ***** ^ not supported yet 95 L := Length(Key); ***** ^ not supported yet ***** ^ not supported yet 96 IF L > 0 97 THEN 98 DEC(L); ***** ^ undeclared identifier ***** ^ not supported yet 99 END; 100 FOR J := 0 TO L DO 101 IF NOT (Key[J] IN CharSet) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 102 THEN Key[J] := ' '; ***** ^ not supported yet ***** ^ not supported yet 103 END; 104 END; 105 DeleteChar(' ',Key); ***** ^ not supported yet ***** ^ not supported yet 106 107 END MakeKey; ***** ^ not supported yet 108 109 110 111 112 PROCEDURE ReadDateField( DF : DisplayFrame; VAR D : Date; 113 FldName : ARRAY OF CHAR); ***** ^ not supported yet 114 VAR 115 S : ARRAY [0..15] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 116 Ok : BOOLEAN; 117 BEGIN 118 ReadInput(DF,S,FldName); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 119 StrToDate(S,D,Ok); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 120 END ReadDateField; ***** ^ not supported yet 121 122 PROCEDURE ChangeDateField(VAR DF : DisplayFrame; D : Date; 123 FldName : ARRAY OF CHAR); ***** ^ not supported yet 124 VAR 125 S : ARRAY[0..15] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 126 B : BOOLEAN; 127 BEGIN 128 DateToStr(D,S,B); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 129 ChangeField(DF,S,FldName,TRUE); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 130 END ChangeDateField; ***** ^ not supported yet 131 132 133 134 PROCEDURE ReadAllRecs(VAR DBF : DBFile; ReadProc :ReadRec; VAR TheList : GenList); ***** ^ undeclared identifier 135 136 VAR 137 TmpList : GenList; 138 LI : LONGINT; 139 J : CARDINAL; 140 Code : CARDINAL; 141 RecAddr : ADDRESS; 142 Size : CARDINAL; 143 BEGIN 144 NewList(TmpList); ***** ^ not supported yet ***** ^ not supported yet 145 FOR J := 1 TO ListLength(TheList) DO ***** ^ not supported yet ***** ^ not supported yet 146 GetElmt(TheList,J,LI,Code); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 147 ReadDBRec(DBF,LI); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 148 ReadProc(RecAddr,Size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 149 ListInsertAdr(RecAddr,Size,1,TmpList,J) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 150 END; 151 DisposeList(TheList); ***** ^ not supported yet ***** ^ not supported yet 152 TheList := TmpList; ***** ^ not supported yet ***** ^ not supported yet 153 154 END ReadAllRecs; ***** ^ not supported yet 155 156 PROCEDURE DeleteAllRecs(VAR DBF : DBFile; TheList : GenList); 157 VAR 158 LI : LONGINT; 159 J : CARDINAL; 160 Code : CARDINAL; 161 BEGIN 162 FOR J := 1 TO ListLength(TheList) DO ***** ^ not supported yet ***** ^ not supported yet 163 GetElmt(TheList,J,LI,Code); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 164 ReadDBRec(DBF,LI); (* position data file *) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 165 DeleteRecord(DBF); ***** ^ not supported yet ***** ^ not supported yet 166 END; 167 END DeleteAllRecs; ***** ^ not supported yet 168 169 PROCEDURE FindAll(Idx : DBIndex; KeyExp : ARRAY OF CHAR; ***** ^ not supported yet 170 Condition : ConditionType; ***** ^ undeclared identifier 171 VAR TheList : GenList ); 172 173 VAR 174 B : BOOLEAN; 175 Str : ARRAY[0..80] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 176 Cond : INTEGER; 177 CRec : LONGINT; 178 BEGIN 179 IF Initialized(TheList) ***** ^ not supported yet ***** ^ not supported yet 180 THEN 181 DisposeList(TheList); ***** ^ not supported yet ***** ^ not supported yet 182 END; 183 NewList(TheList); ***** ^ not supported yet ***** ^ not supported yet 184 CASE Condition OF ***** ^ not supported yet 185 LT,LE : GoTop(Idx); ***** ^ undeclared identifier ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 186 B := TRUE; 187 |EQ,BeginsWith,GE : FindPositionCh(Idx,KeyExp,B); ***** ^ undeclared identifier ***** ^ undeclared identifier ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 188 END; (* end case of *) 189 IF Condition = BeginsWith ***** ^ not supported yet ***** ^ undeclared identifier 190 THEN 191 CurrentKeyCh(Idx,Str); (* get the current key *) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 192 B := (Pos(KeyExp,Str) = 0) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 193 END; 194 IF NOT B 195 THEN RETURN; 196 END; 197 198 LOOP 199 CurrentKeyCh(Idx,Str); (* get the current key *) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 200 Cond := Compare(KeyExp,Str); (* do it here so I do it only once*) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 201 CASE Condition OF ***** ^ not supported yet 202 LT : IF Cond = 1 ***** ^ undeclared identifier 203 THEN 204 EXIT; (* done with this loop *) 205 END; 206 |LE : IF Cond < 1 ***** ^ undeclared identifier 207 THEN 208 ListInsert(CurrentRec(Idx),1,TheList,1); (* put in front of the list*) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 209 END; 210 |EQ : IF Cond = 0 ***** ^ undeclared identifier 211 THEN 212 ListInsert(CurrentRec(Idx),1,TheList,1); (* put in front of the list*) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 213 ELSE 214 EXIT; 215 END; 216 |GE : IF Cond >= 0 ***** ^ undeclared identifier 217 THEN 218 ListInsert(CurrentRec(Idx),1,TheList,1); (* put in front of the list*) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 219 END; 220 |BeginsWith : ***** ^ undeclared identifier 221 IF Pos(KeyExp,Str) = 0 ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 222 THEN 223 ListInsert(CurrentRec(Idx),1,TheList,1); (* put in front of the list*) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 224 ELSE 225 EXIT; 226 END; 227 |Contains : IF Present(KeyExp,Str) ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 228 THEN 229 ListInsert(CurrentRec(Idx),1,TheList,1); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 230 END; 231 END; (* end of case condition of *) 232 CRec := CurrentRec(Idx); ***** ^ not supported yet ***** ^ not supported yet 233 IF NOT NextRecord(Idx, CRec) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 234 THEN 235 EXIT; 236 END; 237 END; (* end of loop *) 238 239 240 END FindAll; ***** ^ not supported yet 241 242 BEGIN 243 CharSet := CharSet / CharSet; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 244 FOR J := 'A' TO 'Z' DO ***** ^ FOR needs integer variable and bounds ***** ^ FOR needs integer variable and bounds ***** ^ FOR needs integer variable and bounds 245 INCL ( CharSet,J); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 246 END; 247 FOR J := '0' TO '9' DO ***** ^ FOR needs integer variable and bounds ***** ^ FOR needs integer variable and bounds ***** ^ FOR needs integer variable and bounds 248 INCL(CharSet,J); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 249 END; 250 INCL(CharSet,'-'); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 251 INCL(CharSet,'&'); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 252 INCL(CharSet,'!'); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 253 INCL(CharSet,'?'); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 254 255 END DBStuff. ***** ^ not supported yet 256 272 errors