home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TPDB311.ZIP / TPDBSORT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-02-14  |  2.9 KB  |  137 lines
  1. Unit TPDBSORT;
  2.  
  3.  
  4. INTERFACE
  5.  
  6. Uses Crt,TPDB,TPDBSrtS,TPDBSrtL,TPDBStr;
  7.  
  8. TYPE
  9.     SortingFunction = FUNCTION : DBKey;
  10.     ProcPtr = ^BYTE;
  11.  
  12. VAR
  13.     SortFile : DataObject;
  14.     SortFunc : SortingFunction;
  15.  
  16. PROCEDURE SortOn(Operation : SortingFunction;Source,Dest : FileName);
  17.  
  18. IMPLEMENTATION
  19.  
  20. CONST
  21.     EOFMarker : Char = #26;
  22.  
  23. TYPE
  24.     SortRecord = RECORD
  25.                  KeyStr : DBKey;
  26.                  RecNum : LONGINT;
  27.                  END;
  28.  
  29. VAR
  30.     SortRec : SortRecord;
  31.     OutFile : File;
  32.     SortResult,LSortResult : Integer;
  33.     SortFileName : FileName;
  34.  
  35.  
  36. {$F+}
  37.  
  38.  
  39. PROCEDURE ReadRecs;
  40. VAR
  41.     RecNum : LONGINT;
  42. BEGIN
  43.     RecNum := 1;
  44.     REPEAT
  45.         SortFile^.GetDBRec(RecNum);
  46.         SortRec.KeyStr := SortFunc;
  47.         SortRec.RecNum := RecNum;
  48.         SortRelease(SortRec);
  49.         INC(RecNum);
  50.     UNTIL SortFile^.DBEOF;
  51. END;
  52.  
  53. FUNCTION LessRecs(VAR x,y : SortRecord) : BOOLEAN;
  54. BEGIN
  55.     LessRecs := x.KeyStr < y.KeyStr;
  56. END;
  57.  
  58. PROCEDURE WriteRecs;
  59. VAR
  60.     X : LONGINT;
  61.     Buffer : DBType;
  62.     FNo : BYTE;
  63. BEGIN
  64.     Assign(OutFile,SortFileName);
  65.     ReWrite(OutFile,1);
  66.     BlockWrite(OutFile,SortFile^.Header^,32,ErrCode);
  67.     For FNo := 1 to SortFile^.NumFields do
  68.     BlockWrite(OutFile,SortFile^.Fields^[FNo],32,ErrCode);
  69.     SortFile^.Header^.Terminator := Chr(Ord($0D));
  70.     BlockWrite(OutFile,SortFile^.Header^.Terminator,1,ErrCode);
  71.     X := 1;
  72.     REPEAT
  73.     SortReturn(SortRec);
  74.     SortFile^.GetDBRec(SortRec.RecNum);
  75.     {Move(SortFile^.DBRecord^,Buffer,SortFile^.Header^.RecordLen);}
  76.     BlockWrite(OutFile,SortFile^.DBRecord^,SortFile^.Header^.RecordLen);
  77.     UNTIL SortEOS;
  78.     Close(OutFile);
  79. END;
  80.  
  81. PROCEDURE LReadRecs;
  82. VAR
  83.     RecNum : LONGINT;
  84. BEGIN
  85.     RecNum := 1;
  86.     REPEAT
  87.         SortFile^.GetDBRec(RecNum);
  88.         SortRec.KeyStr := SortFunc;
  89.         SortRec.RecNum := RecNum;
  90.         SortRelease(SortRec);
  91.         INC(RecNum);
  92.     UNTIL SortFile^.DBEOF;
  93. END;
  94.  
  95. FUNCTION LLessRecs(VAR x,y : SortRecord) : BOOLEAN;
  96. BEGIN
  97.     LLessRecs := x.KeyStr < y.KeyStr;
  98. END;
  99.  
  100. PROCEDURE LWriteRecs;
  101. VAR
  102.     X : LONGINT;
  103.     Buffer : DBType;
  104.     FNo : BYTE;
  105. BEGIN
  106.     Assign(OutFile,SortFileName);
  107.     ReWrite(OutFile,1);
  108.     BlockWrite(OutFile,SortFile^.Header^,32,ErrCode);
  109.     For FNo := 1 to SortFile^.NumFields do
  110.     BlockWrite(OutFile,SortFile^.Fields^[FNo],32,ErrCode);
  111.     SortFile^.Header^.Terminator := Chr(Ord($0D));
  112.     BlockWrite(OutFile,SortFile^.Header^.Terminator,1,ErrCode);
  113.     X := 1;
  114.     REPEAT
  115.     SortReturn(SortRec);
  116.     SortFile^.GetDBRec(SortRec.RecNum);
  117.     Move(SortFile^.DBRecord^,Buffer,SortFile^.Header^.RecordLen);
  118.     BlockWrite(OutFile,Buffer,SortFile^.Header^.RecordLen);
  119.     UNTIL SortEOS;
  120.     BlockWrite(OutFile,EOFMarker,1);
  121.     Close(OutFile);
  122. END;
  123. {$F-}
  124.  
  125. PROCEDURE SortOn(Operation : SortingFunction;Source,Dest : FileName);
  126. BEGIN
  127.     NEW(SortFile,Init(Source));
  128.     SortFileName := Dest;
  129.     IF SortFile^.TotalRecs <= 32767 THEN
  130.         SortResult := SmallTPDBSort(SizeOf(SortRec),@ReadRecs,@LessRecs,@WriteRecs)
  131.     ELSE
  132.         LSortResult := LargeTPDBSort(SizeOf(SortRec),@LReadRecs,@LLessRecs,@LWriteRecs);
  133.     DISPOSE(SortFile,Done);
  134. END;
  135.  
  136. BEGIN
  137. END.