Topspeed_JPI/TS/MODBASE/DBCOPIER.MOD

IMPLEMENTATION MODULE DBCopier;

(*
 * ModBase
 * Release 3.0
 * (c) Copyright 1990-1991 PMI
 *  P.O. Box 8402
 *  Green Bay Wi 53308
 *  All Rights Reserved
 *
 *)

  FROM M2Strings IMPORT
    Delete, Pos, Length, Assign, CompareStr, Concat;

  FROM SYSTEM IMPORT
    BYTE, ADR,  TSIZE, ADDRESS;

  FROM DBFields IMPORT
    ReplaceL, ReplaceD, GetLogicalField, GetDateField;

  FROM ErrorManager IMPORT
    WARN;

  FROM MemoFunctions IMPORT
    GetMemoField, ReplaceM;

  FROM ModBase3 IMPORT
    AppendBlank, Deleted, ReadDBRec, WriteDBRec, DBFile, DBFieldDescriptor,
    UpdateDBFile, GetField, CloseDBF, InitDBF, SetDBBuffer,OpenDBF,
    IndexList,BuildDBF,NumberOfFields,FieldList,DefaultFixUp,
    FileName,HasMemo,SetIndexList,Replace,RecordPtr,MaxRecLength,
    DBFieldPtr,NumberRecords,SetDBSafetyOn,SetDBSafetyOff,SafetySet,
    BufferSize,RecordLength,DisposeDBF;

  FROM HandleIO IMPORT
    FindFile, FileOffSet, CreateFile, OpenFile, EndReached, BlockWrite,
    CloseHandle, SetFilePtr, FileExists, BlockRead;

  FROM StringIO IMPORT
     ErrorMessage, WriteStr, ReadStr, WriteEol, PrintMessage;

  FROM Drectory IMPORT
    RenameFile, DeleteFile;

  FROM LowLevel IMPORT
    Move;

  FROM VStorage IMPORT
    DosAlloc, DosDealloc;

  PROCEDURE DEALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
  BEGIN
    DosDealloc(loc,size);
  END DEALLOCATE;

  PROCEDURE ALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
  BEGIN
    DosAlloc(loc,size);
  END ALLOCATE;

  (* all routines assume dbase3 file naming conventions *)

  PROCEDURE CompareDescriptor
            ( VAR a,
                  b    : ARRAY OF DBFieldDescriptor;
                  size : CARDINAL                   ) : BOOLEAN;

  VAR
    i : CARDINAL;

  BEGIN
    FOR i := 0 TO size-1 DO
      IF CompareStr( a[i].name, b[i].name ) # 0
      THEN
        RETURN FALSE;
      END (* if CompareStr *);
      IF a[i].size # b[i].size
      THEN
        RETURN FALSE;
      END (* if a *);
      IF a[i].fldtype # b[i].fldtype
      THEN
        RETURN FALSE;
      END (* if a *);
      IF a[i].fldtype = 'N'
      THEN
        IF a[i].decplaces # b[i].decplaces
        THEN
          RETURN FALSE;
        END (* if a *);
      END (* if a *);
    END (* for *);
    RETURN TRUE;
  END CompareDescriptor;


  PROCEDURE DBPack
            ( VAR dbf : DBFile );

  VAR
    indexes:ADDRESS;
    pos,
    handle  : CARDINAL;
    TempDBF : DBFile;
    name,
    string,
    memo    : ARRAY[ 0 .. 30 ] OF CHAR;
    fields  : DBFieldPtr;

  BEGIN
    IF NOT OpenDBF(dbf)
    THEN
      WARN('Not able to open file in DBPack');
    END;
    indexes:=IndexList(dbf);
    (* Should consider a better Temp name system *)
    FileName(dbf,name);
    InitDBF( '@@tempfi.dbf', TempDBF, 0 ,FALSE,TRUE,TRUE,DefaultFixUp);
    fields:=FieldList(dbf);
    IF BuildDBF(  fields^,NumberOfFields(dbf), TempDBF )=0 THEN
      DBCopy( dbf, TempDBF, FALSE );
      CloseDBF( dbf );
      CloseDBF( TempDBF );
      PrintMessage( DeleteFile(name ) );
      IF HasMemo(dbf)
      THEN
        Assign( name, string );
        pos := Pos( '.', string ) + 1;
        Delete( string, pos, 3 );
        Concat( string, 'DBT', string );
        PrintMessage( DeleteFile( string ) );
        PrintMessage( RenameFile( '@@tempfi.dbt', string ) );
      END (* if *);
      PrintMessage( RenameFile( '@@tempfi.dbf', name ) );
      SetIndexList(dbf,indexes);
    ELSE
      WARN('Unable to create temporary file in Pack, Operation aborted');
    END;
    DisposeDBF(TempDBF);
  END DBPack;


  PROCEDURE DBFieldCopy
            ( VAR Source     : DBFile;
              VAR Dest       : DBFile );

  VAR
    i,
    j          : CARDINAL;
    ok         : BOOLEAN;
    string     : POINTER TO ARRAY[ 0 .. 5000 ] OF CHAR;(* for memo *)
    SourceName,
    DestName   : ARRAY[ 0 .. 9 ] OF CHAR;
    SourceRec,
    DestRec    :POINTER TO ARRAY[1..MaxRecLength] OF CHAR;
    DestFields,
    SourceFields :DBFieldPtr;
  BEGIN
    NEW(string);
    SourceRec:=RecordPtr(Source);
    DestRec:=RecordPtr(Dest);
    DestFields:=FieldList(Dest);
    SourceFields:=FieldList(Source);
    DestRec^[1] := SourceRec^[1];   (* copy delete mark *)
    FOR i := 1 TO NumberOfFields(Source) DO
      FOR j := 1 TO NumberOfFields(Dest) DO
        IF CompareStr( SourceFields^[i].name, DestFields^[j].name ) = 0
        THEN
          IF SourceFields^[i].fldtype = DestFields^[j].fldtype
          THEN
            IF SourceFields^[i].fldtype = 'M'
            THEN
              GetMemoField( Source, i, string^ );
              ReplaceM( Dest, j, string^ );
            ELSE
              GetField( Source, i, string^ );
              Replace( Dest, j, string^ );
            END (* if *);
          END (* if *);
        END (* if *);
      END (* for *);
    END (* for *);
    DISPOSE(string);
  END DBFieldCopy;


  PROCEDURE DBCopy
            ( VAR Source      : DBFile;
              VAR Dest        : DBFile;
                  CopyDeleted : BOOLEAN );

  VAR

    CurRec        : LONGINT;
    oldbuffer,
    pos,i           : CARDINAL;
    CopyMemo,
    SameStructure,
    ok            : BOOLEAN;
    string        : ARRAY[ 0 .. 29 ] OF CHAR;
    OldSafety     : BOOLEAN;
    memo          : POINTER TO ARRAY[0..5000] OF CHAR;
    SourceRec,
    DestRec    :POINTER TO ARRAY[1..MaxRecLength] OF CHAR;
    DestFields,
    SourceFields :DBFieldPtr;

  BEGIN
    IF NOT OpenDBF(Source)
    THEN
      WARN('Not able to open Source file in DBCopy');
    END;
    IF NOT OpenDBF(Dest)
    THEN
      WARN('Not able to open Dest file in DBCopy');
    END;
    SourceRec:=RecordPtr(Source);
    DestRec:=RecordPtr(Dest);
    DestFields:=FieldList(Dest);
    SourceFields:=FieldList(Source);
    oldbuffer:=BufferSize(Source);
    SetDBBuffer( Source, 32000 );
    OldSafety:=SafetySet(Dest);
    SetDBSafetyOff(Dest);
    IF HasMemo(Source) AND HasMemo(Dest)
    THEN
      CopyMemo := TRUE;
    ELSE
      CopyMemo := FALSE;
    END (* if hasmemo *);
    SameStructure := FALSE;
    IF ( NumberOfFields(Source) = NumberOfFields(Dest) )
    THEN
      IF CompareDescriptor( SourceFields^, DestFields^,
                            NumberOfFields(Source) )
      THEN
        SameStructure := TRUE;
      END (* if *);
    END (* if *);
    IF SameStructure AND CopyMemo
    THEN
      NEW(memo);
    END;
    CurRec := VAL( LONGINT, 1 );
    WHILE CurRec <= NumberRecords(Source) DO
      ReadDBRec( Source, CurRec );
      IF CopyDeleted OR NOT Deleted( Source )
      THEN
        AppendBlank( Dest );
        IF SameStructure
        THEN
          Move( SourceRec, DestRec, RecordLength(Source));
          IF CopyMemo
          THEN
            (* both structures are the same *)
            FOR i := 1 TO NumberOfFields(Dest) DO
              IF SourceFields^[i].fldtype = 'M'
              THEN
                GetMemoField( Source, i, memo^ );
                ReplaceM( Dest, i, memo^ );
              END (* if *);
            END (* for *);
          END (* IF COPY MEMO *);
        ELSE
          DBFieldCopy( Source,  Dest );
        END (* if *);
        WriteDBRec( Dest );
      END (* if *);
      INC( CurRec );
    END (* while *);
    IF OldSafety THEN
      SetDBSafetyOn(Dest)
    END;
    UpdateDBFile(Dest);
    IF SameStructure AND CopyMemo
    THEN
      DISPOSE(memo);
    END;
    SetDBBuffer( Source, oldbuffer );
  END DBCopy;



END DBCopier.