| Program SortFile;
(* Demonstration program. Sort all records
of a file,
using the TSortedCollection
object from Objects.PAS (TP6..)
This example is made to show
how easy the Turbo Vision objects
can be used in an application.
It is not meant as a suggestion
to sort database files usually
(like good old dBase did), instead
some kind of indexing is the
state of the art.
Franz Glaser *)
Uses Objects; {Turbo
Vision}
Type Str27 = String[27];
Str63 = String[63];
Str79 = String[79];
{in
unit DOS: PathStr}
PKeyRec = ^KeyRec;
KeyRec = Record
{used for sorting, in RAM}
Rec : Longint; {an integer would be sufficient
here}
Key : Str27;
End; {uses 32 bytes total.
It is suggested to use records with multiples of
8 bytes on the heap}
FilRec = Record
{very primitive, example file record}
StatusNum : Longint;
Name1 : Str63;
Name2 : Str63;
Age : Integer; {a
byte would be sufficient...}
Address : Str79;
End;
SorTyp = (NameSort,AdrSort,AgeSort);
{create a derivative of TSortedCollection,
which "knows" how to handle
the particular job}
PSortColl = ^TSortColl;
{put your flesh around the bones}
TSortColl = Object(TSortedCollection)
Sor : SorTyp;
Constructor Init(ASor : SorTyp; ALimit,ADelta:Integer);
function Compare(Key1, Key2: Pointer): Integer; virtual;
procedure FreeItem(Item: Pointer); virtual;
End;
(* implementation if a unit *)
Var SColl : PSortColl;
FSiz : Longint;
{max. 16000!}
F1,F2 : File; {source
file, intermediate dest.file}
(* three virtual procedures declare the special
behaviour of
our sorted collection. *)
Constructor TSortColl.Init(ASor : SorTyp;
ALimit,ADelta:Integer);
Begin
TSortedCollection.Init(ALimit,ADelta);
Sor := ASor;
Duplicates := true; {allow
more records with same Age etc.}
End;
{note that it is not really necessary to
redefine the Init constructor
in this example. Setting Sor and Duplicates
could have been done
simply in the main program after the
New ... ,Init....
But it is more elegant to put this
setup into the Init constructor,
so the programmer cannot forget it
accidentally...}
(* Compare and FreeItem MUST be specified
(redefined) in any
derivative of TSortedCollection!
*)
Function TSortColl.Compare(Key1, Key2: Pointer):
Integer;
Var KKey1 : PKeyRec absolute Key1;
KKey2 : PKeyRec absolute
Key2; {one of the possible ways to
typecast an untyped "Pointer"}
Begin
{case Sor of not used
here, for ref only.
Useful if more than 1 key in the keyrec}
if KKey1^.Key = KKey2^.Key then
Compare := 0
else
if KKey1^.Key > KKey2^.Key
then
Compare :=
1
else
Compare :=
-1;
{possible improvement: case Sor of AgeSort:
if ages are equal, then
sort by names. Would need another KeyRec:
both age and key-string}
End;
Procedure TSortColl.FreeItem(Item: Pointer);
Begin
FreeMem(Item,sizeof(KeyRec)); {tell
TSortColl.Done how big
the records are}
(*Dispose(PKeyRec(Item));
{another possible solution} *)
End;
{---- TSortColl virtual procedures finished
-----------------------}
Function UpcaseStr(S:String):String; {aux
function for easy sorting}
Var I : Integer;
Begin
if S > '' then
For I := 1 to length(S)
do
S[I] := Upcase(S[I]);
UpcaseStr := S;
End;
Procedure ReadOriFile; {read
unsorted records, build sorted list}
Var R : Longint;
HaveRead : Integer;
Cus : FilRec;
P : PKeyRec;
Begin
{assumed:
Record Nr. 0 is a special record for database management,
eg. linked list of erased records and other stuff.
All valid records have StatusNum=0 else StatusNum=link
to the next erased record }
Seek(F1,1); {skip
rec. 0}
for R := 1 to FSiz-1 do
Begin
BlockRead(F1,Cus,1,HaveRead);
{read
from unsorted file}
if (HaveRead
= 1) and (Cus.StatusNum=0) then {valid record
read}
Begin
New(P); {key - record}
{here some test could be useful: if P <> Nil then...}
with Cus, P^ do
Begin
Rec := R;
Case SColl^.Sor of
NameSort : Key := UpcaseStr(Name1+'
'+Name2); {Lastname+' '+Firstname}
AdrSort : Key :=
UpcaseStr(Address);
AgeSort : Str(Age:3,Key);
{for alpha sorting}
End; {case}
End;
SColl^.Insert(P); {sort the key into
the collection}
End;
End;
End; {readorifile}
Procedure CopyToDestFile; {copy
the valid records to the intermediate file}
Var Cus : FilRec;
HaveRead,HaveWritten :
Integer;
Procedure CopyRecord(P : PKeyRec);
Far; (* !!! Far !!! *)
Begin
Seek(F1,P^.Rec);
BlockRead(F1,Cus,1,HaveRead);
if HaveRead=1 then
{what else?}
BlockWrite(F2,Cus,1,HaveWritten);
End;
Begin
fillchar(Cus,sizeof(Cus),#0);
{management
record}
Cus.StatusNum := -1; {see
below}
{any
special data for record #0 here -> Cus ...}
BlockWrite(F2,Cus,1,HaveWritten);
SColl^.ForEach(@CopyRecord);
{== for I:=0 to SColl^.Count-1 do
CopyRecord(PKeyRec(SColl^.At(I))) }
End; {copy2destfile}
{main SortFile}
Begin
Assign(F1,'CUSTOM.DAT');
{$I-} Reset(F1,sizeof(FilRec)); {$I+}
if IOresult <> 0 then Halt(55);
FSiz := FileSize(F1);
if (FSiz < 2) or (FSiz > 16000)
then {16383 limitation with TCollection}
Begin
Close(F1);
Halt(55);
End;
SColl := New(PSortColl,Init(NameSort,FSiz,4));
{or
another sort-typ}
ReadOriFile; {read
all records, create key, sort key into collection}
if SColl^.Count
= 0 then
Begin
Close(F1);
Dispose(SColl,Done);
Halt(42);
{there
was no valid record}
End;
Assign(F2,'CUSTOM.$$$');
Rewrite(F2,sizeof(FilRec));
CopyToDestFile;
Dispose(SColl,Done); {will
dispose all key-recs automatically}
Close(F1);
Close(F2);
Erase(F1);
Rename(F2,'CUSTOM.DAT');
End.
=======================================================================
Additional explanation to the 0 - record:
With TAccess.PAS, the Borland database - toolbox
unit, the data file
has a record #0 with special data. The most important
contents is the
chained list of erased records, where each erased
record has a longint
in the first 4 bytes as a link to the next erased
record. In record
#0 this longint points to the first erased record
or -1 if no erased
record is stored. The last record has -1.
Valid records can use the first 4 bytes for anything
else, but I
found it very useful to dedicate it for this
purpose, filling the
link (named StatusNum) with 0 whenever a valid
record is written to
the database file. This is evident in case of
disturbed index files.
This are rather low level considerations, compared
with the stuff,
which Delphi programmers are dealing with.
|
.
Get your own FREE
HOMEPAGE