mmobjlst.pas

一套及时通讯的原码

   { Read the object name }
   S.ReadBuffer(Name[0],1);
   S.ReadBuffer(Name[1],Ord(Name[0]));
   { If Name is valid (registered)... }
   Result:=CreateInstanceByName(Name,LoadProc);
   { Then ask it to load itself }
   CallStreamProc(Result,S,LoadProc);
end;

{========================================================================}
procedure WriteObjectToStream(Source: TObject; S: TStream);
Var
   R: TRegisterRec;
   Name: TClassName;

begin
   If Source <> nil then
   begin
      Name := Source.ClassName;
      R := GetRegistration(Name);
      if R = nil then
         raise EClassNotFound.CreateFmt('Source Class <%s> not registered',[Name]);
      { First write out the object name }
      S.WriteBuffer(Name,Length(Name)+1);
      { And ask the object to write itself to S }
      CallStreamProc(Source,S,R.DoStore); { S now contains Source }
   end
   else raise EClassNotFound.Create('Nil Source Class!');
end;

{== TObjectList =========================================================}
constructor TObjectList.Create;
begin
   inherited Create;

   FCount := 0;
   FCapacity := 0;
   FDestroy := True;
end;

{-- TObjectList ---------------------------------------------------------}
constructor TObjectList.CreateWithOptions(DestroyObjects: Boolean;
                                          InitialCapacity: TOLSize);
begin
   Create;
   FDestroy := DestroyObjects;
   SetCapacity(InitialCapacity);
end;

{-- TObjectList ---------------------------------------------------------}
constructor TObjectList.CreateFromFile(const FileName: string);
begin
   Create;
   LoadFromFile(FileName);
end;

{-- TObjectList ---------------------------------------------------------}
destructor TObjectList.Destroy;
begin
   OnChange := nil;
   OnChanging := nil;
   FreeAll;
   Clear;

   inherited Destroy;
end;

{-- TObjectList ---------------------------------------------------------}
function TObjectList.AddObject(Item: TObject): TOLSize;
begin
   Result := FCount;
   Insert(Result, Item);
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.AddObjects(Objects: TObjectList);
var
   i: integer;

begin
   BeginUpdate;
   try
      for i := 0 to Objects.Count-1 do
          AddObject(Objects.Items[i]);
   finally
      EndUpdate;
   end;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Clear;
begin
   { Clear does not free it's objects. It's the same as calling DeleteAll }
   if FCount <> 0 then
   begin
      Changing;
      SetCount(0);
      SetCapacity(0);
      Changed;
   end;
end;

{-- TObjectList ---------------------------------------------------------}
Procedure TObjectList.FreeItem(AnItem: Pointer);
begin
   { Overwrite if Items are not objects }
   if FDestroy then TObject(AnItem).Free;
end;

{-- TObjectList ---------------------------------------------------------}
function TObjectList.Remove(Item: TObject): TOLSize;
begin
   Result := IndexOf(Item);
   if Result <> -1 then Delete(Result);
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Delete(Index: TOLSize);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   Changing;
   dec(FCount);
   if Index < FCount then
      System.Move(FList^[Index+1], FList^[Index],
                 (FCount-Index)*SizeOf(TObject));
   Changed;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.DeleteAll;
begin
   Clear;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.FreeAt(Index: TOLSize);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   FreeItem(FList^[Index]);
   Delete(Index);
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.FreeAll;
var
   Index: TOLSize;
begin
   for Index := 0 to FCount-1 do
       FreeItem(FList^[Index]);
   Clear;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.FreeObject(Item: TObject);
begin
   try
      FreeAt(IndexOf(Item));

   except
      on EListError do
         raise EListError.CreateFmt('TObject %s not in item list',[Item.ClassName]);
   end;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Error;
begin
   raise EListError.Create({$IFDEF DELPHI3}SListIndexError{$ELSE}LoadStr(SListIndexError){$ENDIF});
end;

{-- TObjectList ---------------------------------------------------------}
function TObjectList.First: TObject;
begin
   Result := Get(0);
end;

{-- TObjectList ---------------------------------------------------------}
function TObjectList.Last: TObject;
begin
   Result := Get(FCount - 1);
end;

{-- TObjectList ---------------------------------------------------------}
function TObjectList.Get(Index: TOLSize): TObject;
begin
   if (Index < 0) or (Index >= FCount) then Error;
   Result := FList^[Index];
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Grow;
Var
   Delta: TOLSize;

begin
   if FCapacity > 8 then Delta := 16
   else if FCapacity > 4 then Delta := 8
   else Delta := 4;
   SetCapacity(FCapacity+Delta);
end;

{-- TObjectList ---------------------------------------------------------}
function TObjectList.IndexOf(Item: TObject): TOLSize;
begin
   Result := 0;
   while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
   if Result = FCount then Result := -1;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Insert(Index: TOLSize; Item: TObject);
begin
   if (Index < 0) or (Index > FCount) then Error;
   Changing;
   if FCount = FCapacity then Grow;
   if Index < FCount then
   begin
      System.Move(FList^[Index], FList^[Index+1],
                  (FCount-Index)*SizeOf(TObject));
   end;
   FList^[Index] := Item;
   inc(FCount);
   Changed;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Exchange(Index1, Index2: TOLSize);
var
  Item: TObject;

begin
   if (Index1 <> Index2) then
   begin
      if (Index1 < 0) or (Index1 >= FCount) or
         (Index2 < 0) or (Index2 >= FCount) then Error;
      Changing;
      Item := FList^[Index1];
      FList^[Index1] := FList^[Index2];
      FList^[Index2] := Item;
      Changed;
   end;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Move(CurIndex, NewIndex: TOLSize);
var
   Item: TObject;

begin
   if CurIndex <> NewIndex then
   begin
      if (NewIndex < 0) or (NewIndex >= FCount) then Error;
      Item := Get(CurIndex);
      Delete(CurIndex);
      Insert(NewIndex, Item);
   end;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Put(Index: TOLSize; Item: TObject);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   FList^[Index] := Item;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Pack;
var
   i: Integer;

begin
   for i := FCount-1 downto 0 do if Items[i] = nil then Delete(i);
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.SetCapacity(NewCapacity: TOLSize);
var
   NewList: PObjects;

begin
   if (NewCapacity <> FCapacity) then
   begin
      if (NewCapacity < FCount) or (integer(NewCapacity)>=cMaxList) then Error;
      if NewCapacity = 0 then NewList := nil
      else
      begin
         NewList := Allocate(NewCapacity * SizeOf(tObject));
         if FCount <> 0 then System.Move(FList^, NewList^, FCount * SizeOf(tObject));
      end;
      if FCapacity <> 0 then FreeMem(FList, FCapacity * SizeOf(tObject));
      FList := NewList;
      FCapacity := NewCapacity;
   end;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.SetCount(NewCount: TOLSize);
begin
   if (NewCount < 0) or (integer(NewCount) >= cMaxList) then Error;
   if NewCount > FCapacity then SetCapacity(NewCount);
   if NewCount > FCount then
      FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(TObject), 0);
   FCount := NewCount;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.DefineProperties(Filer: TFiler);
begin
   Filer.DefineBinaryProperty('ObjectContainer', ReadData, WriteData, FCount>0);
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.ReadData(S: TStream);
Var
   ObjCount,
   Index: TOLSize;
   Kennung: Longint;

begin
   BeginUpdate;
   try
      S.ReadBuffer(Kennung,sizeOf(STREAMKENNUNG));
      if (Kennung <> STREAMKENNUNG) then
         raise EStreamError.Create('Invalid Object stream');
      FreeAll;
      { load stream items }
      S.ReadBuffer(FDestroy,SizeOf(FDestroy));
      S.ReadBuffer(ObjCount,SizeOf(Objcount));  { Read in Object count }
      if FCapacity-FCount < ObjCount then SetCapacity(FCount+ObjCount);

      { Read in Object Count }
      for Index := 0 to ObjCount-1 do
          AddObject(ReadObjectFromStream(S));
   finally
      EndUpdate;
   end;
end;

{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.WriteData(S: TStream);
var
   Index,
   ObjCount: TOlSize;