rtlvcloptimize.pas

Delphi RTL-VCL optimization addon. I ve used, really good job.

  P: PChar;
  I, Count: Integer;
  LDelimiters: TSysCharSet;
  QuoteCh: Char;
  Delim: string;
begin
  Count := GetCount;
  QuoteCh := QuoteChar;
  if (Count = 1) and (Get(0) = '') then
    Result := QuoteChar + QuoteChar
  else
  begin
    Result := '';
    if Count = 0 then
      Exit;
    Delim := Delimiter; // convert char to string here to remove this conversation from the loop
    LDelimiters := [#0, QuoteCh, Delim[1]];
    {$IFDEF COMPILER10_UP}
    if not StrictDelimiter then
    {$ENDIF COMPILER10_UP}
      LDelimiters := LDelimiters + [#1..' '];

    {$IFDEF NOLEADBYTES_HOOK}
    if not NoLeadBytes then
    begin
    {$ENDIF NOLEADBYTES_HOOK}
      for I := 0 to Count - 1 do
      begin
        S := Get(I);
        P := Pointer(S);
        if P <> nil then
        begin
          while not (P^ in LDelimiters) do
            P := CharNext(P);
          if P^ <> #0 then
            S := AnsiQuotedStr(S, QuoteCh);
        end;
        if I > 0 then
          Result := Result + Delim + S
        else
          Result := S;
      end;
    {$IFDEF NOLEADBYTES_HOOK}
    end
    else
    begin
      for I := 0 to Count - 1 do
      begin
        S := Get(I);
        P := Pointer(S);
        if P <> nil then
        begin
          while not (P^ in LDelimiters) do
            Inc(P);
          if P^ <> #0 then
            S := AnsiQuotedStr(S, QuoteCh);
        end;
        if I > 0 then
          Result := Result + Delim + S
        else
          Result := S;
      end;
    end;
    {$ENDIF NOLEADBYTES_HOOK}
  end;
end;

{ Helps to get the addresses of private methods }
type
  TPublishedStrings = class(TStrings)
  published
    property DelimitedText;
  end;

function GetGetDelimitedText: Pointer;
var
  Prop: PPropInfo;
begin
  Prop := GetPropInfo(TPublishedStrings, 'DelimitedText');
  if Prop <> nil then Result := Prop.GetProc else
    Result := nil;
end;

function GetSetDelimitedText: Pointer;
var
  Prop: PPropInfo;
begin
  Prop := GetPropInfo(TPublishedStrings, 'DelimitedText');
  if Prop <> nil then Result := Prop.SetProc else
    Result := nil;
end;
{$ENDIF COMPILER7_UP}

{------------------------------------------------------------------------------}
{ TComponent optimization                                                      }
{------------------------------------------------------------------------------}
{.$REGION 'class TNameHashList'}
type
  PNameCompItem = ^TNameCompItem;
  TNameCompItem = record
    Key: string;
    Value: TComponent;
    Next: PNameCompItem;
  end;

  TNameHashList = class(TList)
  private
    FNameCount: Integer;
    FItems: array[0..64 - 1] of PNameCompItem;

    function NameFind(const AItem: string; out Value: TComponent): Boolean; overload;
    function NameAdd(const AItem: string; AData: TComponent): TComponent; overload;
    function NameRemove(const AItem: string): TComponent;
  protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
  public
    procedure Clear; override;
  end;

{ A very simple but fast string hash algorithm (no prime number) }
function HashUpString(const AItem: string): Integer;
asm
  or eax, eax
  jz @@Leave

  xchg eax, edx
  mov eax, [edx-$04] // Length(AItem)
  xor ecx, ecx

@@HashStringNextChar:
  mov cl, [edx]

  cmp     cl, 'a'
  jb      @@UpCaseEnd
  cmp     cl, 'z'
  ja      @@UpCaseEnd
  sub     cl, 'a' - 'A'
@@UpCaseEnd:

  ror cl, 4
  shl cx, 1
  add eax, ecx
  xor ch, ch
  inc edx
  or ecx, ecx
  jnz @@HashStringNextChar

  and eax, 64-1
@@Leave:
end;

{ TNameHashList }

procedure TNameHashList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  case Action of
    lnAdded:
      if TComponent(Ptr).Name <> '' then
        NameAdd(TComponent(Ptr).Name, TComponent(Ptr));
    lnExtracted, lnDeleted:
      if TComponent(Ptr).Name <> '' then
        NameRemove(TComponent(Ptr).Name);
  end;
end;

procedure TNameHashList.Clear;
var
  P, N: PNameCompItem;
  i: Integer;
begin
  if FNameCount > 0 then
  begin
    for i := 0 to High(FItems) do
    begin
      P := FItems[i];
      while P <> nil do
      begin
        N := P.Next;
        Dispose(P);
        P := N;
        Dec(FNameCount);
      end;
      FItems[i] := nil;
      if FNameCount = 0 then
        Break;
    end;
  end;
  FNameCount := 0;
  inherited Clear;
end;

function TNameHashList.NameAdd(const AItem: string; AData: TComponent): TComponent;
var
  N: PNameCompItem;
  AHash: Integer;
begin
  New(N);
  AHash := HashUpString(AItem);
  N.Next := FItems[AHash];
  FItems[AHash] := N;
  Inc(FNameCount);
  N.Key := AItem;
  N.Value := AData;
  Result := AData;
end;

function TNameHashList.NameRemove(const AItem: string): TComponent;
var
  Index: Integer;
  P, N: PNameCompItem;
begin
  if FNameCount > 0 then
  begin
    Index := HashUpString(AItem);
    N := FItems[Index];
    if N <> nil then
    begin
      if CompareText(N.Key, AItem) = 0 then
      begin
        Result := N.Value;
        P := N.Next;
        Dispose(N);
        FItems[Index] := P;
        Dec(FNameCount);
        Exit;
      end
      else
      begin
        P := N;
        N := N.Next;
        while N <> nil do
        begin
          if CompareText(N.Key, AItem) = 0 then
          begin
            Result := N.Value;
            P.Next := N.Next;
            Dispose(N);
            Dec(FNameCount);
            Exit;
          end;
          P := N;
          N := N.Next;
        end;
      end;
    end;
  end;
  Result := nil;
end;

function TNameHashList.NameFind(const AItem: string; out Value: TComponent): Boolean;
var
  N: PNameCompItem;
  AHash: Integer;
begin
  Value := nil;
  AHash := HashUpString(AItem);
  N := FItems[AHash];
  while N <> nil do
  begin
    if CompareText(N.Key, AItem) = 0 then
    begin
      Value := N.Value;
      Result := True;
      Exit;
    end;
    N := N.Next;
  end;
  Result := False;
end;
{.$ENDREGION}

type
  TFastComponent = class(TComponent)
  protected
    function ReplaceComponentList: TNameHashList;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure ChangeName(const NewName: TComponentName);
  public
    procedure Destroying;
    function FindComponent(const AName: string): TComponent;
  end;

  TOpenComponent = class(TComponent);

  TPrivateComponent = class(TPersistent{, IInterface, IInterfaceComponentReference})
  public
    FOwner: TComponent;
    FName: TComponentName;
    FTag: Longint;
    FComponents: TNameHashList{TList};
    FFreeNotifies: TList;
    FDesignInfo: Longint;
    {$IFDEF COMPILER5}
    FVCLComObject: Pointer;
    {$ENDIF COMPILER5}
    FComponentState: TComponentState;
    {$IFDEF COMPILER6_UP}
    //FVCLComObject: Pointer;
    {$ENDIF COMPILER6_UP}
  end;

{ TFastComponent }

function TFastComponent.ReplaceComponentList: TNameHashList;
var
  List: TList;
  I: Integer;
begin
  Result := TNameHashList.Create;
  List := TPrivateComponent(Self).FComponents;
  Result.Capacity := List.Capacity;
  for I := 0 to List.Count - 1 do
    Result.Add(List.List[I]); // copy and hash
  TPrivateComponent(Self).FComponents := Result;
  List.Free;
end;

procedure TFastComponent.Destroying;

  procedure InternDestroying(Owner: TComponent);
  var
    I: Integer;
    Comps: TList;
    Comp: TPrivateComponent;
  begin
    Comps := TPrivateComponent(Owner).FComponents;
    for I := 0 to Comps.Count - 1 do
    begin
      Comp := TPrivateComponent(Comps.List[I]);
      if not (csDestroying in Comp.FComponentState) then
      begin
        Include(Comp.FComponentState, csDestroying);
        if Comp.FComponents <> nil then
          InternDestroying(TComponent(Comp));
      end;
    end;
  end;

var
  I: Integer;
  Comps: TList;
  Comp: TPrivateComponent;
begin
  if not (csDestroying in TPrivateComponent(Self).FComponentState) then
  begin
    Include(TPrivateComponent(Self).FComponentState, csDestroying);
    Comps := TPrivateComponent(Self).FComponents;
    if Comps <> nil then
      for I := 0 to Comps.Count - 1 do
      begin
        Comp := TPrivateComponent(Comps.List[I]);
        if not (csDestroying in Comp.FComponentState) then
        begin
          Include(Comp.FComponentState, csDestroying);
          if Comp.FComponents <> nil then
            InternDestroying(TComponent(Comp));
        end;
        //TFastComponent(Comps.List[I]).Destroying;
      end;
  end;
end;

function TFastComponent.FindComponent(const AName: string): TComponent;
var
  Comps: TNameHashList;
begin
  if AName <> '' then
  begin
    Comps := TPrivateComponent(Self).FComponents;
    if Comps <> nil then
    begin
      if PMetaClass(Comps).ClassType <> TNameHashList then
        Comps := ReplaceComponentList;

      if Comps.NameFind(AName, Result) then
        Exit;
    end;
  end;
  Result := nil;
end;

procedure TFastComponent.ChangeName(const NewName: TComponentName);
var
  Comps: TNameHashList;
begin
  if (Owner <> nil) then
  begin
    Comps := TPrivateComponent(Owner).FComponents;
    if (Comps <> nil) and (PMetaClass(Comps).ClassType = TNameHashList) then
    begin
      if Name <> '' then
        Comps.NameRemove(Name);
      if NewName <> '' then
        Comps.NameAdd(NewName, Self);
    end;
  end;
  TPrivateComponent(Self).FName := NewName;
end;

procedure TFastComponent.Notification(AComponent: TComponent; Operation: TOperation);
var
  I, CompCount: Integer;
  Comps: TList;
begin
  if (Operation = opRemove) and (AComponent <> nil) then
    RemoveFreeNotification(AComponent);

  Comps := TPrivateComponent(Self).FComponents;
  if Comps <> nil then
  begin
    I := Comps.Count - 1;
    while I >= 0 do
    begin
      TOpenComponent(Comps.List[I]).Notification(AComponent, Operation);
      Dec(I);
      CompCount := Comps.Count;
      if I >= CompCount then
        I := CompCount - 1;
    end;
  end;
end;

{------------------------------------------------------------------------------}
{ File optimization                                                            }
{------------------------------------------------------------------------------}
{$IFNDEF COMPILER10_UP}
{ GetFileAttributes() is a lot faster than the FindFirstFile call in the original
  FileExists function that calls FileAge. BDS 2006 fixes this. }
function FastFileExists(const Filename: string): Boolean;
begin
  Result := (Filename <> '') and (GetFileAttributes(Pointer(Filename)) and FILE_ATTRIBUTE_DIRECTORY = 0);
end;
{$ENDIF ~COMPILER10_UP}

{------------------------------------------------------------------------------}
{$IFDEF COMPILER5}
const
  PathSep = ';';
  DriveDelim = ':';
  PathDelim = '\';
{$ENDIF COMPILER5}

{$IFNDEF DELPHI2007_UP}
function FastFileSearch(const Name, DirList: string): string;
var
  I, P, L: Integer;
  C: Char;
begin
  Result := Name;
  if Result = '' then
    Exit;
  P := 0;
  L := Length(DirList) - 1;
  while True do
  begin
    if FileExists(Result) then
      Exit;
    while (P <= L) and (DirList[P + 1] = PathSep) do
      Inc(P);
    if P > L then
      Break;
    I := P;
    {$IFDEF NOLEADBYTES_HOOK}
    if not NoLeadBytes then
    begin
    {$ENDIF NOLEADBYTES_HOOK}
      while (P <= L) and (DirList[P + 1] <> PathSep) do
      begin
        if DirList[P + 1] in LeadBytes then
        {$IFNDEF COMPILER6_UP}
          Inc(P);
        {$ELSE}
          P := NextCharIndex(DirList, P)
        else
        {$ENDIF ~COMPILER6_UP}
          Inc(P);
      end;
      Result := Copy(DirList, I + 1, P - I);
      C := AnsiLastChar(Result)^;
    {$IFDEF NOLEADBYTES_HOOK}
    end
    else
    begin
      while (P <= L) and (DirList[P + 1] <> PathSep) do
        Inc(P);
      Result := Copy(DirList, I + 1, P - I);
      if Result <> '' then
        C := Result[Length(Result)]
      else
        C := #0;
    end;
    {$ENDIF NOLEADBYTES_HOOK}