home *** CD-ROM | disk | FTP | other *** search
/ The Devil's Doorknob BBS Capture (1996-2003) / devilsdoorknobbbscapture1996-2003.iso / Dloads / OTHERUTI / TPASCAL3.ZIP / TVDEMOS.ZIP / DATACOLL.PAS < prev    next >
Pascal/Delphi Source File  |  1991-06-11  |  4KB  |  150 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal 6.0                             }
  4. {   Turbo Vision Forms Demo                      }
  5. {   Copyright (c) 1990 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. unit DataColl;
  10.  
  11. {$F+,O+,S-,D-}
  12.  
  13. interface
  14.  
  15. uses Objects;
  16.  
  17. type
  18.   KeyTypes = (StringKey, LongIntKey);
  19.  
  20.   PDataCollection = ^TDataCollection;
  21.   TDataCollection = object(TStringCollection)
  22.     ItemSize: Word;
  23.     KeyType: KeyTypes;
  24.     Status: Integer;
  25.     constructor Init(ALimit, ADelta, AnItemSize: Integer; AKeyType: KeyTypes);
  26.     constructor Load(var S: TStream);
  27.     function Compare(Key1, Key2: Pointer): Integer; virtual;
  28.     procedure Error(Code, Info: Integer); virtual;
  29.     procedure FreeItem(Item: Pointer); virtual;
  30.     function GetItem(var S: TStream): Pointer; virtual;
  31.     procedure PutItem(var S: TStream; Item: Pointer); virtual;
  32.     procedure SetLimit(ALimit: Integer); virtual;
  33.     procedure Store(var S: TStream); virtual;
  34.   end;
  35.  
  36. const
  37.   RDataCollection: TStreamRec = (
  38.     ObjType: 10050;
  39.     VmtLink: Ofs(TypeOf(TDataCollection)^);
  40.     Load: @TDataCollection.Load;
  41.     Store: @TDataCollection.Store);
  42.  
  43. procedure RegisterDataColl;
  44.  
  45. implementation
  46.  
  47. uses Memory;
  48.  
  49. procedure RegisterDataColl;
  50. begin
  51.   RegisterType(RDataCollection);
  52. end;
  53.  
  54. constructor TDataCollection.Init(ALimit, ADelta, AnItemSize: Integer;
  55.   AKeyType: KeyTypes);
  56. begin
  57.   TStringCollection.Init(ALimit, ADelta);
  58.   ItemSize := AnItemSize;
  59.   KeyTYpe := AKeyType;
  60. end;
  61.  
  62. constructor TDataCollection.Load(var S: TStream);
  63. begin
  64.   S.Read(ItemSize, SizeOf(ItemSize));
  65.   TStringCollection.Load(S);
  66.   S.Read(KeyType, SizeOf(KeyType));
  67.   Status := 0;
  68. end;
  69.  
  70. function TDataCollection.Compare(Key1, Key2: Pointer): Integer;
  71. var
  72.   SK1, SK2: String;
  73.   i: Integer;
  74. begin
  75.   if KeyType = StringKey then
  76.   begin
  77.     SK1 := PString(Key1)^;
  78.     for i := 1 to Length(SK1) do SK1[i] := UpCase(SK1[i]);
  79.     SK2 := PString(Key2)^;
  80.     for i := 1 to Length(SK2) do SK2[i] := UpCase(SK2[i]);
  81.     Compare := TStringCollection.Compare(@SK1, @SK2);
  82.   end
  83.   else if KeyType = LongIntKey then
  84.   begin
  85.     if LongInt(Key1^) < LongInt(Key2^) then
  86.       Compare := -1
  87.     else if LongInt(Key1^) = LongInt(Key2^) then
  88.       Compare := 0
  89.     else
  90.       Compare := 1;
  91.   end;
  92. end;
  93.  
  94. procedure TDataCollection.Error(Code, Info: Integer);
  95. { Save error status instead of giving a runtime error }
  96. begin
  97.   Status := Code;
  98. end;
  99.  
  100. procedure TDataCollection.FreeItem(Item: Pointer);
  101. begin
  102.   if Item <> nil then FreeMem(Item, ItemSize);
  103. end;
  104.  
  105. function TDataCollection.GetItem(var S: TStream): Pointer;
  106. var
  107.   Item: Pointer;
  108. begin
  109.   GetMem(Item, ItemSize);
  110.   S.Read(Item^, ItemSize);
  111.   GetItem := Item;
  112. end;
  113.  
  114. procedure TDataCollection.PutItem(var S: TStream; Item: Pointer);
  115. begin
  116.   S.Write(Item^, ItemSize);
  117. end;
  118.  
  119. procedure TDataCollection.SetLimit(ALimit: Integer);
  120. var
  121.   AItems: PItemList;
  122. begin
  123.   if ALimit < Count then ALimit := Count;
  124.   if ALimit > MaxCollectionSize then ALimit := MaxCollectionSize;
  125.   if ALimit <> Limit then
  126.   begin
  127.     if ALimit = 0 then AItems := nil else
  128.     begin
  129.       { Restrict collection: don't allow it to eat into safety pool.
  130.         Requires careful checking for success at point of insertion.
  131.       }
  132.       AItems := MemAlloc(ALimit * SizeOf(Pointer));
  133.       if AItems = nil then Exit;
  134.       if Count <> 0 then Move(Items^, AItems^, Count * SizeOf(Pointer));
  135.     end;
  136.     if Limit <> 0 then FreeMem(Items, Limit * SizeOf(Pointer));
  137.     Items := AItems;
  138.     Limit := ALimit;
  139.   end;
  140. end;
  141.  
  142. procedure TDataCollection.Store(var S: TStream);
  143. begin
  144.   S.Write(ItemSize, SizeOf(ItemSize));
  145.   TStringCollection.Store(S);
  146.   S.Write(KeyType, SizeOf(KeyType));
  147. end;
  148.  
  149. end.
  150.