units/indy/KOLClasses.pas

   1 // 7-dec-2002
   2 // 25-apr-2003
   3 unit KOLClasses;
   4
   5 interface
   6
   7 uses KOL,Windows;
   8
   9 type
  10   TDuplicates = (dupIgnore, dupAccept, dupError);
  11
  12   TThreadList = object(TObj)
  13   private
  14     FList: PList;//TList;
  15     FLock: TRTLCriticalSection;
  16     FDuplicates: TDuplicates;
  17   public
  18     procedure Init; virtual;
  19   //  constructor Create;
  20     destructor Destroy; virtual;//override;
  21     procedure Add(Item: Pointer);
  22     procedure Clear;
  23     function  LockList: PList;//TList;
  24     procedure Remove(Item: Pointer);
  25     procedure UnlockList;
  26     property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  27   end;
  28
  29   PThreadList=^TThreadList;
  30
  31   function NewThreadList({ACollection: PCollection}): PThreadList;
  32
  33   type
  34
  35   PCollection = ^TCollection;
  36
  37   PCollectionItem = ^TCollectionItem;
  38   TCollectionItem = object(TObj)
  39   private
  40     FCollection: PCollection;
  41     FID: Integer;
  42 //    FACollection:PCollection;
  43     function GetIndex: Integer;
  44     procedure SetCollection(Value: PCollection);
  45   protected
  46     FACollection:PCollection;
  47     procedure Changed(AllItems: Boolean);
  48     function GetOwner: PObj; // override;
  49     function GetDisplayName: string; virtual;
  50     procedure SetIndex(Value: Integer); virtual;
  51     procedure SetDisplayName(const Value: string); virtual;
  52   public
  53     { constructor Create(Collection: TCollection); virtual;
  54     } destructor Destroy;
  55       virtual;
  56     procedure Init; virtual;
  57     procedure Assign(Source: PCollectionItem);
  58     function GetNamePath: string; //override;
  59     property Collection: PCollection read FCollection write SetCollection;
  60     property ID: Integer read FID;
  61     property Index: Integer read GetIndex write SetIndex;
  62     property DisplayName: string read GetDisplayName write SetDisplayName;
  63   end;
  64
  65   TCollection = object(TObj)
  66   private
  67     //    FItemClass: TCollectionItemClass;
  68     FItems: PList;
  69     FUpdateCount: Integer;
  70     FNextID: Integer;
  71     FPropName: string;
  72     function GetCount: Integer;
  73     function GetPropName: string;
  74     procedure InsertItem(Item: PCollectionItem);
  75     procedure RemoveItem(Item: PCollectionItem);
  76   protected
  77     property NextID: Integer read FNextID;
  78     { Design-time editor support }
  79     function GetAttrCount: Integer; // dynamic;
  80     function GetAttr(Index: Integer): string; // dynamic;
  81     function GetItemAttr(Index, ItemIndex: Integer): string; // dynamic;
  82     procedure Changed;
  83     function GetItem(Index: Integer): PCollectionItem;
  84     procedure SetItem(Index: Integer; Value: PCollectionItem);
  85     procedure SetItemName(Item: PCollectionItem); virtual;
  86     procedure Update(Item: PCollectionItem); virtual;
  87     property PropName: string read GetPropName write FPropName;
  88     property UpdateCount: Integer read FUpdateCount;
  89   public
  90     { constructor Create(ItemClass: TCollectionItemClass);
  91     } destructor Destroy;
  92       virtual;
  93     procedure Init; virtual;
  94     function Add: PCollectionItem;
  95     procedure Assign(Source: PObj); // override;
  96     procedure BeginUpdate; virtual;
  97     procedure Clear;
  98     procedure Delete(Index: Integer);
  99     procedure EndUpdate; virtual;
 100     function FindItemID(ID: Integer): PCollectionItem;
 101     function GetNamePath: string; // override;
 102     function Insert(Index: Integer): PCollectionItem;
 103     property Count: Integer read GetCount;
 104     //    property ItemClass: TCollectionItemClass read FItemClass;
 105     property Items[Index: Integer]: PCollectionItem read GetItem write SetItem;
 106   end;
 107   //Pllection=^ollection;
 108
 109   { Collection class that maintains an "Owner" in order to obtain property
 110     path information at design-time }
 111
 112   POwnedCollection = ^TOwnedCollection;
 113   TOwnedCollection = object(TCollection)
 114   private
 115     FOwner: PObj;
 116   protected
 117     function GetOwner: PObj; // override;
 118   public
 119     //    procedure Init; virtual;
 120         { constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
 121      }
 122   end;
 123   //Plection=^llection;
 124   //function Newlection(AOwner: TPersistent; ItemClass: TCollectionItemClass):Plection; type  MyStupid20258=DWord;
 125 function NewOwnedCollection(AOwner: PObj {;
 126   ItemClass: TCollectionItemClass}): POwnedCollection;
 127 function NewCollection(Collection: PCollection): PCollection;
 128 function NewCollectionItem(ACollection: PCollection): PCollectionItem;
 129
 130 type
 131   PStringStream=^TStringStream;
 132   TStringStream=object(TStream)
 133   private
 134 //    FDataString: string;
 135 //    FPosition: Integer;
 136     function GetDataString:String;
 137   protected
 138     procedure SetSize(NewSize: Longint); //override;
 139   public
 140 //    constructor Create(const AString: string);
 141     function Read(var Buffer; Count: Longint): Longint; //override;
 142     function ReadString(Count: Longint): string;
 143     function Seek(Offset: Longint; Origin: Word): Longint; //override;
 144     function Write(const Buffer; Count: Longint): Longint; //override;
 145     procedure WriteString(const AString: string);
 146     property DataString: string read GetDataString;
 147   end;
 148
 149   PStringStreamData=^TStringStreamData;
 150   TStringStreamData=packed record
 151     FDataString: string;
 152     FPosition: Integer;
 153   end;
 154
 155   function NewStringStream(const AString: string):PStringStream;
 156
 157
 158
 159 implementation
 160
 161 function NewCollectionItem(ACollection: PCollection): PCollectionItem;
 162 //constructor TCollectionItem.Create(Collection: PCollection);
 163 begin
 164   New(Result, Create);
 165   with Result^ do
 166     FACollection:=ACollection;
 167   Result.Init;
 168   //  with Result^ do
 169   //    SetCollection(Collection);
 170 end;
 171
 172 procedure TCollectionItem.Init;
 173 begin
 174   SetCollection(FACollection);//Collection);
 175 end;
 176
 177 destructor TCollectionItem.Destroy;
 178 begin
 179   SetCollection(nil);
 180   inherited Destroy;
 181 end;
 182
 183 procedure TCollectionItem.Changed(AllItems: Boolean);
 184 var
 185   Item: PCollectionItem;
 186 begin
 187   if (FCollection <> nil) and (FCollection.FUpdateCount = 0) then
 188   begin
 189     if AllItems then
 190       Item := nil
 191     else
 192       Item := @Self;
 193     FCollection.Update(Item);
 194   end;
 195 end;
 196
 197 function TCollectionItem.GetIndex: Integer;
 198 begin
 199   if FCollection <> nil then
 200     Result := FCollection.FItems.IndexOf(@Self)
 201   else
 202     Result := -1;
 203 end;
 204
 205 function TCollectionItem.GetDisplayName: string;
 206 begin
 207   //  Result := ClassName;
 208 end;
 209
 210 function TCollectionItem.GetNamePath: string;
 211 begin
 212   if FCollection <> nil then
 213     Result := Format('%s[%d]', [FCollection.GetNamePath, Index]);
 214   {  else
 215       Result := ClassName;}
 216 end;
 217
 218 function TCollectionItem.GetOwner: PObj;
 219 begin
 220   Result := FCollection;
 221 end;
 222
 223 procedure TCollectionItem.SetCollection(Value: PCollection);
 224 begin
 225   if FCollection <> Value then
 226   begin
 227     if FCollection <> nil then
 228       FCollection.RemoveItem(@Self);
 229     if Value <> nil then
 230       Value.InsertItem(@Self);
 231   end;
 232 end;
 233
 234 procedure TCollectionItem.SetDisplayName(const Value: string);
 235 begin
 236   Changed(False);
 237 end;
 238
 239 procedure TCollectionItem.SetIndex(Value: Integer);
 240 var
 241   CurIndex: Integer;
 242 begin
 243   CurIndex := GetIndex;
 244   if (CurIndex >= 0) and (CurIndex <> Value) then
 245   begin
 246     FCollection.FItems.MoveItem(CurIndex, Value);
 247     Changed(True);
 248   end;
 249 end;
 250
 251 { TCollection }
 252
 253 function NewCollection(Collection: PCollection): PCollection;
 254 //constructor TCollection.Create(ItemClass: TCollectionItemClass);
 255 begin
 256   New(Result, Create);
 257   Result.Init;
 258   {  with Result^ do
 259     begin
 260       //  FItemClass := ItemClass;
 261       FItems := NewList; //TList.Create;
 262     end;   }
 263 end;
 264
 265 procedure TCollection.Init;
 266 begin
 267   //  FItemClass := ItemClass;
 268   FItems := NewList; //TList.Create;
 269 end;
 270
 271 destructor TCollection.Destroy;
 272 begin
 273   FUpdateCount := 1;
 274   if FItems <> nil then
 275     Clear;
 276   FItems.Free;
 277   inherited Destroy;
 278 end;
 279
 280 function TCollection.Add: PCollectionItem;
 281 begin
 282   Result := NewCollectionItem(@Self); //FItemClass.Create(Self);
 283 end;
 284
 285 procedure TCollection.Assign(Source: PObj);
 286 var
 287   I: Integer;
 288 begin
 289   if TCollection.AncestorOfObject(Source) { is TCollection} then
 290   begin
 291     BeginUpdate;
 292     try
 293       Clear;
 294       for I := 0 to PCollection(Source).Count - 1 do
 295         Add.Assign(PCollection(Source).Items[I]);
 296     finally
 297       EndUpdate;
 298     end;
 299     Exit;
 300   end;
 301   //  inherited Assign(Source);
 302 end;
 303
 304 procedure TCollection.BeginUpdate;
 305 begin
 306   Inc(FUpdateCount);
 307 end;
 308
 309 procedure TCollection.Changed;
 310 begin
 311   if FUpdateCount = 0 then
 312     Update(nil);
 313 end;
 314
 315 procedure TCollection.Clear;
 316 begin
 317   if FItems.Count > 0 then
 318   begin
 319     BeginUpdate;
 320     try
 321       while FItems.Count > 0 do
 322         PCollectionItem(FItems.Last).Free;
 323     finally
 324       EndUpdate;
 325     end;
 326   end;
 327 end;
 328
 329 procedure TCollection.EndUpdate;
 330 begin
 331   Dec(FUpdateCount);
 332   Changed;
 333 end;
 334
 335 function TCollection.FindItemID(ID: Integer): PCollectionItem;
 336 var
 337   I: Integer;
 338 begin
 339   for I := 0 to FItems.Count - 1 do
 340   begin
 341     Result := PCollectionItem(FItems.Items[I]);
 342     if Result.ID = ID then
 343       Exit;
 344   end;
 345   Result := nil;
 346 end;
 347
 348 function TCollection.GetAttrCount: Integer;
 349 begin
 350   Result := 0;
 351 end;
 352
 353 function TCollection.GetAttr(Index: Integer): string;
 354 begin
 355   Result := '';
 356 end;
 357
 358 function TCollection.GetItemAttr(Index, ItemIndex: Integer): string;
 359 begin
 360   Result := Items[ItemIndex].DisplayName;
 361 end;
 362
 363 function TCollection.GetCount: Integer;
 364 begin
 365   Result := FItems.Count;
 366 end;
 367
 368 function TCollection.GetItem(Index: Integer): PCollectionItem;
 369 begin
 370   Result := FItems.Items[Index];
 371 end;
 372
 373 function TCollection.GetNamePath: string;
 374 var
 375   S, P: string;
 376 begin
 377   //  Result := ClassName;
 378 //    if GetOwner = nil then Exit;
 379   //  S := GetOwner.GetNamePath;
 380   if S = '' then
 381     Exit;
 382   P := PropName;
 383   if P = '' then
 384     Exit;
 385   Result := S + '.' + P;
 386 end;
 387
 388 function TCollection.GetPropName: string;
 389 //var
 390 //  I: Integer;
 391   //  Props: PPropList;
 392   //  TypeData: PTypeData;
 393 //  Owner: PObj; //TPersistent;
 394 begin
 395   Result := FPropName;
 396   {  Owner := GetOwner;
 397     if (Result <> '') or (Owner = nil) or (Owner.ClassInfo = nil) then Exit;
 398     TypeData := GetTypeData(Owner.ClassInfo);
 399     if (TypeData = nil) or (TypeData^.PropCount = 0) then Exit;
 400     GetMem(Props, TypeData^.PropCount * sizeof(Pointer));
 401     try
 402       GetPropInfos(Owner.ClassInfo, Props);
 403       for I := 0 to TypeData^.PropCount-1 do
 404       begin
 405         with Props^[I]^ do
 406           if (PropType^^.Kind = tkClass) and
 407             (GetOrdProp(Owner, Props^[I]) = Integer(Self)) then
 408             FPropName := Name;
 409       end;
 410     finally
 411       Freemem(Props);
 412     end;}
 413   Result := FPropName;
 414 end;
 415
 416 function TCollection.Insert(Index: Integer): PCollectionItem;
 417 begin
 418   Result := Add;
 419   Result.Index := Index;
 420 end;
 421
 422 // Out param is more code efficient for interfaces than function result
 423 {procedure GetDesigner(Obj: TPersistent; out Result: IDesignerNotify);
 424 var
 425   Temp: TPersistent;
 426 begin
 427   Result := nil;
 428   if Obj = nil then Exit;
 429   Temp := Obj.GetOwner;
 430   if Temp = nil then
 431   begin
 432     if (Obj is TComponent) and (csDesigning in TComponent(Obj).ComponentState) then
 433       TComponent(Obj).QueryInterface(IDesignerNotify, Result);
 434   end
 435   else
 436   begin
 437     if (Obj is TComponent) and
 438       not (csDesigning in TComponent(Obj).ComponentState) then Exit;
 439     GetDesigner(Temp, Result);
 440   end;
 441 end;}
 442
 443 {function FindRootDesigner(Obj: TPersistent): IDesignerNotify;
 444 begin
 445   GetDesigner(Obj, Result);
 446 end;}
 447
 448 {procedure NotifyDesigner(Self, Item: TPersistent; Operation: TOperation);
 449 var
 450   Designer: IDesignerNotify;
 451 begin
 452   GetDesigner(Self, Designer);
 453   if Designer <> nil then
 454     Designer.Notification(Item, Operation);
 455 end;}
 456
 457 procedure TCollection.InsertItem(Item: PCollectionItem);
 458 begin
 459   //  if not (Item is FItemClass) then
 460   //    TList.Error(@SInvalidProperty, 0);
 461   FItems.Add(Item);
 462   Item.FCollection := @Self;
 463   Item.FID := FNextID;
 464   Inc(FNextID);
 465   SetItemName(Item);
 466   Changed;
 467   //  NotifyDesigner(Self, Item, opInsert);
 468 end;
 469
 470 procedure TCollection.RemoveItem(Item: PCollectionItem);
 471 begin
 472   //  NotifyDesigner(Self, Item, opRemove);
 473   FItems.Remove(Item);
 474   Item.FCollection := nil;
 475   Changed;
 476 end;
 477
 478 procedure TCollection.SetItem(Index: Integer; Value: PCollectionItem);
 479 begin
 480   PCollectionItem(FItems.Items[Index]).Assign(Value);
 481 end;
 482
 483 procedure TCollection.SetItemName(Item: PCollectionItem);
 484 begin
 485 end;
 486
 487 procedure TCollection.Update(Item: PCollectionItem);
 488 begin
 489 end;
 490
 491 procedure TCollection.Delete(Index: Integer);
 492 begin
 493   PCollectionItem(FItems.Items[Index]).Free;
 494 end;
 495
 496 { TOwnedCollection }
 497
 498 function NewOwnedCollection(AOwner: PObj {;
 499   ItemClass: TCollectionItemClass}): POwnedCollection;
 500 {constructor TOwnedCollection.Create(AOwner: TPersistent;
 501   ItemClass: TCollectionItemClass);}
 502 begin
 503   New(Result, Create);
 504   with Result^ do
 505     FOwner := AOwner;
 506   //  inherited Create(ItemClass);
 507 end;
 508
 509 function TOwnedCollection.GetOwner: PObj;
 510 begin
 511   Result := FOwner;
 512 end;
 513
 514 procedure TCollectionItem.Assign(Source: PCollectionItem);
 515 begin
 516   Collection := Source.Collection;
 517   FID := Source.FID; // ???
 518   Index := Source.Index;
 519   DisplayName := Source.DisplayName;
 520 end;
 521
 522 {constructor TStringStream.Create(const AString: string);
 523 begin
 524   inherited Create;
 525   FDataString := AString;
 526 end;}
 527
 528 function TStringStream.Read(var Buffer; Count: Longint): Longint;
 529 var
 530   CData:PStringStreamData;
 531 begin
 532   CData:=CustomData;
 533   Result := Length(CData.FDataString) - CData.FPosition;
 534   if Result > Count then Result := Count;
 535   Move(PChar(@CData.FDataString[Data.FPosition + 1])^, Buffer, Result);
 536   Inc(CData.FPosition, Result);
 537 end;
 538
 539 function TStringStream.Write(const Buffer; Count: Longint): Longint;
 540 var
 541   CData:PStringStreamData;
 542 begin
 543   CData:=CustomData;
 544   Result := Count;
 545   SetLength(CData.FDataString, (CData.FPosition + Result));
 546   Move(Buffer, PChar(@CData.FDataString[Data.FPosition + 1])^, Result);
 547   Inc(CData.FPosition, Result);
 548 end;
 549
 550 function TStringStream.Seek(Offset: Longint; Origin: Word): Longint;
 551 var
 552   CData:PStringStreamData;
 553 begin
 554   CData:=CustomData;
 555 {  case Origin of
 556     soFromBeginning: FPosition := Offset;
 557     soFromCurrent: FPosition := FPosition + Offset;
 558     soFromEnd: FPosition := Length(FDataString) - Offset;
 559   end;}
 560   if CData.FPosition > Length(CData.FDataString) then
 561     CData.FPosition := Length(CData.FDataString)
 562   else if CData.FPosition < 0 then CData.FPosition := 0;
 563   Result := CData.FPosition;
 564 end;
 565
 566 function TStringStream.ReadString(Count: Longint): string;
 567 var
 568   Len: Integer;
 569   CData:PStringStreamData;
 570 begin
 571   CData:=CustomData;
 572   with CData^ do
 573   begin
 574   Len := Length(FDataString) - FPosition;
 575   if Len > Count then Len := Count;
 576   SetString(Result, PChar(@FDataString[FPosition + 1]), Len);
 577   Inc(FPosition, Len);
 578   end;
 579 end;
 580
 581 procedure TStringStream.WriteString(const AString: string);
 582 begin
 583   Write(PChar(AString)^, Length(AString));
 584 end;
 585
 586 procedure TStringStream.SetSize(NewSize: Longint);
 587 var
 588   CData:PStringStreamData;
 589 begin
 590   CData:=CustomData;
 591   with CData^ do
 592   begin
 593   SetLength(FDataString, NewSize);
 594   if FPosition > NewSize then FPosition := NewSize;
 595   end;
 596 end;
 597
 598 function TStringStream.GetDataString:String;
 599 var
 600   CData:PStringStreamData;
 601 begin
 602   Result:=CData.FDataString;
 603 end;
 604
 605 function NewStringStream(const AString: string):PStringStream;
 606 var
 607   CData:PStringStreamData;
 608 begin
 609 //  New( Result, Create );
 610 //  Move( StreamMethods, Result.fMethods, Sizeof( TStreamMethods ) );
 611 //  Result.fPMethods := @Result.fMethods;
 612   Result:=PStringStream(NewMemoryStream);
 613
 614   with Result^ do
 615   begin
 616 //    inherited Create;
 617     GetMem(CData,Sizeof(CData^));
 618     FillChar(CData^,Sizeof(CData^),0);
 619     Result.CustomData:=CData;
 620
 621     CData.FDataString := AString;
 622   end;
 623 end;
 624
 625 { TThreadList }
 626
 627 procedure TThreadList.Add(Item: Pointer);
 628 begin
 629   LockList;
 630  // try
 631     if (Duplicates = dupAccept) or
 632        (FList.IndexOf(Item) = -1) then
 633       FList.Add(Item)
 634     else if Duplicates = dupError then
 635     begin
 636 //      FList.Error(@SDuplicateItem, Integer(Item));
 637     end;
 638 //  finally
 639     UnlockList;
 640 //  end;
 641 end;
 642
 643 procedure TThreadList.Clear;
 644 begin
 645 LockList;
 646   try
 647     FList.Clear;
 648   finally
 649     UnlockList;
 650   end;
 651
 652 end;
 653
 654 destructor TThreadList.Destroy;
 655 begin
 656   LockList;    // Make sure nobody else is inside the list.
 657   try
 658     FList.Free;
 659     inherited Destroy;
 660   finally
 661     UnlockList;
 662     DeleteCriticalSection(FLock);
 663   end;
 664 end;
 665
 666 procedure TThreadList.Init;
 667 begin
 668   inherited;// Create;
 669   InitializeCriticalSection(FLock);
 670   FList := NewList;//TList.Create;
 671   FDuplicates := dupIgnore;
 672 end;
 673
 674 function TThreadList.LockList: PList;//TList;
 675 begin
 676   EnterCriticalSection(FLock);
 677   Result := FList;
 678 end;
 679
 680 procedure TThreadList.Remove(Item: Pointer);
 681 begin
 682   LockList;
 683   try
 684     FList.Remove(Item);
 685   finally
 686     UnlockList;
 687   end;
 688 end;
 689
 690 procedure TThreadList.UnlockList;
 691 begin
 692   LeaveCriticalSection(FLock);
 693 end;
 694
 695 function NewThreadList({ACollection: PCollection}): PThreadList;
 696 begin
 697   New( Result, Create );
 698   Result.Init;
 699 {  inherited Create;
 700   InitializeCriticalSection(FLock);
 701   FList := TList.Create;
 702   FDuplicates := dupIgnore;}
 703 end;
 704
 705 end.