Listing: 1 IMPLEMENTATION MODULE DBCopier; 2 3 (* 4 * ModBase 5 * Release 3.0 6 * (c) Copyright 1990-1991 PMI 7 * P.O. Box 8402 8 * Green Bay Wi 53308 9 * All Rights Reserved 10 * 11 *) 12 13 FROM M2Strings IMPORT 14 Delete, Pos, Length, Assign, CompareStr, Concat; 15 16 FROM SYSTEM IMPORT 17 BYTE, ADR, TSIZE, ADDRESS; 18 19 FROM DBFields IMPORT 20 ReplaceL, ReplaceD, GetLogicalField, GetDateField; 21 22 FROM ErrorManager IMPORT 23 WARN; 24 25 FROM MemoFunctions IMPORT 26 GetMemoField, ReplaceM; 27 28 FROM ModBase3 IMPORT 29 AppendBlank, Deleted, ReadDBRec, WriteDBRec, DBFile, DBFieldDescriptor, 30 UpdateDBFile, GetField, CloseDBF, InitDBF, SetDBBuffer,OpenDBF, 31 IndexList,BuildDBF,NumberOfFields,FieldList,DefaultFixUp, 32 FileName,HasMemo,SetIndexList,Replace,RecordPtr,MaxRecLength, 33 DBFieldPtr,NumberRecords,SetDBSafetyOn,SetDBSafetyOff,SafetySet, 34 BufferSize,RecordLength,DisposeDBF; 35 36 FROM HandleIO IMPORT 37 FindFile, FileOffSet, CreateFile, OpenFile, EndReached, BlockWrite, 38 CloseHandle, SetFilePtr, FileExists, BlockRead; 39 40 FROM StringIO IMPORT 41 ErrorMessage, WriteStr, ReadStr, WriteEol, PrintMessage; 42 43 FROM Drectory IMPORT 44 RenameFile, DeleteFile; 45 46 FROM LowLevel IMPORT 47 Move; 48 49 FROM VStorage IMPORT 50 DosAlloc, DosDealloc; 51 52 PROCEDURE DEALLOCATE(VAR loc:ADDRESS;size:CARDINAL); 53 BEGIN 54 DosDealloc(loc,size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 55 END DEALLOCATE; ***** ^ not supported yet 56 57 PROCEDURE ALLOCATE(VAR loc:ADDRESS;size:CARDINAL); 58 BEGIN 59 DosAlloc(loc,size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 60 END ALLOCATE; ***** ^ not supported yet 61 62 (* all routines assume dbase3 file naming conventions *) 63 64 PROCEDURE CompareDescriptor 65 ( VAR a, 66 b : ARRAY OF DBFieldDescriptor; ***** ^ not supported yet 67 size : CARDINAL ) : BOOLEAN; 68 69 VAR 70 i : CARDINAL; 71 72 BEGIN 73 FOR i := 0 TO size-1 DO 74 IF CompareStr( a[i].name, b[i].name ) # 0 ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 75 THEN 76 RETURN FALSE; 77 END (* if CompareStr *); 78 IF a[i].size # b[i].size ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 79 THEN 80 RETURN FALSE; 81 END (* if a *); 82 IF a[i].fldtype # b[i].fldtype ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 83 THEN 84 RETURN FALSE; 85 END (* if a *); 86 IF a[i].fldtype = 'N' ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 87 THEN 88 IF a[i].decplaces # b[i].decplaces ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 89 THEN 90 RETURN FALSE; 91 END (* if a *); 92 END (* if a *); 93 END (* for *); 94 RETURN TRUE; 95 END CompareDescriptor; ***** ^ not supported yet 96 97 98 PROCEDURE DBPack 99 ( VAR dbf : DBFile ); 100 101 VAR 102 indexes:ADDRESS; 103 pos, 104 handle : CARDINAL; 105 TempDBF : DBFile; 106 name, 107 string, 108 memo : ARRAY[ 0 .. 30 ] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 109 fields : DBFieldPtr; 110 111 BEGIN 112 IF NOT OpenDBF(dbf) ***** ^ not supported yet ***** ^ not supported yet 113 THEN 114 WARN('Not able to open file in DBPack'); ***** ^ not supported yet ***** ^ not supported yet 115 END; 116 indexes:=IndexList(dbf); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 117 (* Should consider a better Temp name system *) 118 FileName(dbf,name); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 119 InitDBF( '@@tempfi.dbf', TempDBF, 0 ,FALSE,TRUE,TRUE,DefaultFixUp); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 120 fields:=FieldList(dbf); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 121 IF BuildDBF( fields^,NumberOfFields(dbf), TempDBF )=0 THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 122 DBCopy( dbf, TempDBF, FALSE ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 123 CloseDBF( dbf ); ***** ^ not supported yet ***** ^ not supported yet 124 CloseDBF( TempDBF ); ***** ^ not supported yet ***** ^ not supported yet 125 PrintMessage( DeleteFile(name ) ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 126 IF HasMemo(dbf) ***** ^ not supported yet ***** ^ not supported yet 127 THEN 128 Assign( name, string ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 129 pos := Pos( '.', string ) + 1; ***** ^ not supported yet ***** ^ not supported yet 130 Delete( string, pos, 3 ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 131 Concat( string, 'DBT', string ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 132 PrintMessage( DeleteFile( string ) ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 133 PrintMessage( RenameFile( '@@tempfi.dbt', string ) ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 134 END (* if *); 135 PrintMessage( RenameFile( '@@tempfi.dbf', name ) ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 136 SetIndexList(dbf,indexes); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 137 ELSE 138 WARN('Unable to create temporary file in Pack, Operation aborted'); ***** ^ not supported yet ***** ^ not supported yet 139 END; 140 DisposeDBF(TempDBF); ***** ^ not supported yet ***** ^ not supported yet 141 END DBPack; ***** ^ not supported yet 142 143 144 PROCEDURE DBFieldCopy 145 ( VAR Source : DBFile; 146 VAR Dest : DBFile ); 147 148 VAR 149 i, 150 j : CARDINAL; 151 ok : BOOLEAN; 152 string : POINTER TO ARRAY[ 0 .. 5000 ] OF CHAR;(* for memo *) ***** ^ not supported yet ***** ^ not supported yet 153 SourceName, 154 DestName : ARRAY[ 0 .. 9 ] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 155 SourceRec, 156 DestRec :POINTER TO ARRAY[1..MaxRecLength] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 157 DestFields, 158 SourceFields :DBFieldPtr; 159 BEGIN 160 NEW(string); ***** ^ undeclared identifier ***** ^ not supported yet 161 SourceRec:=RecordPtr(Source); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 162 DestRec:=RecordPtr(Dest); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 163 DestFields:=FieldList(Dest); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 164 SourceFields:=FieldList(Source); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 165 DestRec^[1] := SourceRec^[1]; (* copy delete mark *) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 166 FOR i := 1 TO NumberOfFields(Source) DO ***** ^ not supported yet ***** ^ not supported yet 167 FOR j := 1 TO NumberOfFields(Dest) DO ***** ^ not supported yet ***** ^ not supported yet 168 IF CompareStr( SourceFields^[i].name, DestFields^[j].name ) = 0 ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 169 THEN 170 IF SourceFields^[i].fldtype = DestFields^[j].fldtype ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 171 THEN 172 IF SourceFields^[i].fldtype = 'M' ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 173 THEN 174 GetMemoField( Source, i, string^ ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 175 ReplaceM( Dest, j, string^ ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 176 ELSE 177 GetField( Source, i, string^ ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 178 Replace( Dest, j, string^ ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 179 END (* if *); 180 END (* if *); 181 END (* if *); 182 END (* for *); 183 END (* for *); 184 DISPOSE(string); ***** ^ undeclared identifier ***** ^ not supported yet 185 END DBFieldCopy; ***** ^ not supported yet 186 187 188 PROCEDURE DBCopy 189 ( VAR Source : DBFile; 190 VAR Dest : DBFile; 191 CopyDeleted : BOOLEAN ); 192 193 VAR 194 195 CurRec : LONGINT; 196 oldbuffer, 197 pos,i : CARDINAL; 198 CopyMemo, 199 SameStructure, 200 ok : BOOLEAN; 201 string : ARRAY[ 0 .. 29 ] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 202 OldSafety : BOOLEAN; 203 memo : POINTER TO ARRAY[0..5000] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 204 SourceRec, 205 DestRec :POINTER TO ARRAY[1..MaxRecLength] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 206 DestFields, 207 SourceFields :DBFieldPtr; 208 209 BEGIN 210 IF NOT OpenDBF(Source) ***** ^ not supported yet ***** ^ not supported yet 211 THEN 212 WARN('Not able to open Source file in DBCopy'); ***** ^ not supported yet ***** ^ not supported yet 213 END; 214 IF NOT OpenDBF(Dest) ***** ^ not supported yet ***** ^ not supported yet 215 THEN 216 WARN('Not able to open Dest file in DBCopy'); ***** ^ not supported yet ***** ^ not supported yet 217 END; 218 SourceRec:=RecordPtr(Source); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 219 DestRec:=RecordPtr(Dest); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 220 DestFields:=FieldList(Dest); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 221 SourceFields:=FieldList(Source); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 222 oldbuffer:=BufferSize(Source); ***** ^ not supported yet ***** ^ not supported yet 223 SetDBBuffer( Source, 32000 ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 224 OldSafety:=SafetySet(Dest); ***** ^ not supported yet ***** ^ not supported yet 225 SetDBSafetyOff(Dest); ***** ^ not supported yet ***** ^ not supported yet 226 IF HasMemo(Source) AND HasMemo(Dest) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 227 THEN 228 CopyMemo := TRUE; 229 ELSE 230 CopyMemo := FALSE; 231 END (* if hasmemo *); 232 SameStructure := FALSE; 233 IF ( NumberOfFields(Source) = NumberOfFields(Dest) ) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 234 THEN 235 IF CompareDescriptor( SourceFields^, DestFields^, ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 236 NumberOfFields(Source) ) ***** ^ not supported yet ***** ^ not supported yet 237 THEN 238 SameStructure := TRUE; 239 END (* if *); 240 END (* if *); 241 IF SameStructure AND CopyMemo 242 THEN 243 NEW(memo); ***** ^ undeclared identifier ***** ^ not supported yet 244 END; 245 CurRec := VAL( LONGINT, 1 ); ***** ^ undeclared identifier ***** ^ not supported yet 246 WHILE CurRec <= NumberRecords(Source) DO ***** ^ not supported yet ***** ^ not supported yet 247 ReadDBRec( Source, CurRec ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 248 IF CopyDeleted OR NOT Deleted( Source ) ***** ^ not supported yet ***** ^ not supported yet 249 THEN 250 AppendBlank( Dest ); ***** ^ not supported yet ***** ^ not supported yet 251 IF SameStructure 252 THEN 253 Move( SourceRec, DestRec, RecordLength(Source)); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 254 IF CopyMemo 255 THEN 256 (* both structures are the same *) 257 FOR i := 1 TO NumberOfFields(Dest) DO ***** ^ not supported yet ***** ^ not supported yet 258 IF SourceFields^[i].fldtype = 'M' ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 259 THEN 260 GetMemoField( Source, i, memo^ ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 261 ReplaceM( Dest, i, memo^ ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 262 END (* if *); 263 END (* for *); 264 END (* IF COPY MEMO *); 265 ELSE 266 DBFieldCopy( Source, Dest ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 267 END (* if *); 268 WriteDBRec( Dest ); ***** ^ not supported yet ***** ^ not supported yet 269 END (* if *); 270 INC( CurRec ); ***** ^ undeclared identifier ***** ^ not supported yet 271 END (* while *); 272 IF OldSafety THEN 273 SetDBSafetyOn(Dest) ***** ^ not supported yet ***** ^ not supported yet 274 END; 275 UpdateDBFile(Dest); ***** ^ not supported yet ***** ^ not supported yet 276 IF SameStructure AND CopyMemo 277 THEN 278 DISPOSE(memo); ***** ^ undeclared identifier ***** ^ not supported yet 279 END; 280 SetDBBuffer( Source, oldbuffer ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 281 END DBCopy; ***** ^ not supported yet 282 283 284 285 END DBCopier. ***** ^ not supported yet 260 errors