another pack alternative

[Chris Miller]

Her's the continuation of

Using low level file operations on the dbf file instead of SCATTER/GATHER.

Pros:
1. Even faster, as it doesn't touch cdx or fpt, any usual updates of indexes and memo file by scatter are avoided.
2. The readonly nature of autoinc fields is overcome
3. No index violations occur.

Cons:
Needs exclusive dbf access just like the usual PACK
1. Needs a final REINDX so the index tags become valid again - I plan to replace this by low level cdx file operations as mainly only the recno of shifted records has to change in the current index trees and nodes about now truncated non-existing records have to be removed completely.
2. Does not pack the fpt file. I could simply claim that's off my goal for this PACK alternative, but in the snes of tha pack alternative working on the existing files instead of creating new files, this could also be addressed.

Lparameters tcDBF

Local lcDeleted, lcAlias
lcDeleted = Set("Deleted")
lcAlias = Alias()

If Pcount()=0
   tcDBF = Dbf()
   USE
Endif

Local lnFile, lnLastByte
lnFile = Fopen(tcDBF,12)
If lnFile<0
   * ? "can't pack DBF"
Else
   Local lcSuffix, lnFirstDeleted, lnLastUndeleted
   lcSuffix = Sys(2015)

   Local lcAliasIsDeleted, lcAliasUnDeleted, lcRecord
   lcAliasIsDeleted = 'Deleted'+lcSuffix
   lcAliasUnDeleted = 'UnDeleted'+lcSuffix

   Set Deleted Off

   * Use the passed in DBF file twice for two record pointers on deleted and undeleted records
   Create Cursor recordmoves (nSource I, nDest I)

   Fclose(lnFile)
   Use (tcDBF) In Select(lcAliasIsDeleted) Exclusive Alias (lcAliasIsDeleted)
   Use (tcDBF) In Select(lcAliasUnDeleted) Exclusive Again Alias (lcAliasUnDeleted)
   tcDBF = Dbf(lcAliasUnDeleted)

   Erase (Getenv("TEMP")+"\IsDeleted.idx")
   Erase (Getenv("TEMP")+"\UnDeleted.idx")

   Select (lcAliasIsDeleted)
   Index On Recno() To (Getenv("TEMP")+"\IsDeleted.idx") For Deleted() Additive
   Locate
   lnFirstDeleted = Recno()

   Select (lcAliasUnDeleted)
   Index On RECCOUNT()-Recno() To (Getenv("TEMP")+"\UnDeleted.idx") For Not Deleted() Additive
   Locate
   lnLastUndeleted = Recno()

   Local lnHeader, lnRecsize
   lnHeader = Header()
   lnRecsize = Recsize()

   * While the first deleted record is before the last undeleted records, move that undeleted record to fill the gap:
   Do While lnFirstDeleted<lnLastUndeleted And ;
         Not Deleted(lcAliasUnDeleted) And Deleted(lcAliasIsDeleted) And ;
         Not Eof(lcAliasUnDeleted) And Not Eof(lcAliasIsDeleted)

      Insert Into recordmoves (nSource, nDest) Values (lnLastUndeleted-1, lnFirstDeleted-1)

      Skip 1 In (lcAliasIsDeleted)
      lnFirstDeleted = Recno(lcAliasIsDeleted)
      Skip 1 In (lcAliasUnDeleted)
      lnLastUndeleted = max(Recno(lcAliasUnDeleted),recordmoves.nDest+1)
   Enddo
   Set Order To 0
   Set Index To
   Use In Select(lcAliasIsDeleted)
   Use In Select(lcAliasUnDeleted)
   Set Deleted &lcDeleted
   Select 0
   Erase (Getenv("TEMP")+"\IsDeleted.idx")
   Erase (Getenv("TEMP")+"\UnDeleted.idx")
   lnLastByte = lnHeader+lnLastUndeleted*lnRecsize+1
   ? lnLastUndeleted, lnLastByte
   
   * process dbf with low level file operations
   lnFile = Fopen(tcDBF,2)
   SELECT recordmoves   
   Scan
      * copy undeleted row with scatter/gather
      ? Fseek(lnFile, lnHeader+nSource*lnRecsize)
      Store Fread(lnFile,lnRecsize) To lcRecord
      ? Fseek(lnFile, lnHeader+nDest*lnRecsize)
      ? Fwrite(lnFile,lcRecord,lnRecsize)
   Endscan

   * change reccount in DBF header offset 4:
   Fseek(lnFile, 4)
   Fwrite(lnFile, Chr(Bitand(lnLastUndeleted,0xff)),1)
   lnLastUndeleted = Bitrshift(lnLastUndeleted,8)
   Fwrite(lnFile, Chr(Bitand(lnLastUndeleted,0xff)),1)
   lnLastUndeleted = Bitrshift(lnLastUndeleted,8)
   Fwrite(lnFile, Chr(Bitand(lnLastUndeleted,0xff)),1)
   lnLastUndeleted = Bitrshift(lnLastUndeleted,8)
   Fwrite(lnFile, Chr(Bitand(lnLastUndeleted,0xff)),1)
   * change byte after last undeleted record to EOF (1A)
   Fseek(lnFile, lnLastByte)
   Fwrite(lnFile, Chr(0x1A),1)
   * truncate file
   Fchsize(lnFile, lnLastByte)

   SELECT 0
   Fclose(lnFile)
   Use (tcDBF) Exclusive Again Alias (lcAliasUnDeleted)
   REINDEX
   USE
   IF PCOUNT()=0
      Use (tcDBF) Shared Again Alias (lcAlias)
   ENDIF
Endif

If Not lcAlias=="" And Used(lcAlias)
   Select (lcAlias)
Endif

Chriss