Systemressourcen erschöpft beim VirtualStringTree.AfterCellPaint

[Hobbycoder]

Im Rahmen einer Planungssoftware stelle ich RTF-Text formatierte Text in einer Spalte eines VirtualStringTree dar.

Die Daten werden im Objekt in einem MemoryStream gespeichert. Weiterhin hat das Object ein TPicture, wo ich in die Bitmap mir das Bild für die Anzeige im VST ablegen. Während des Ladevorgangs wird also ein JvRichEdit erzeugt, dort wird aus dem Stream die RTF-Information geladen, mittels TJvRichEdit.SaveToImage das RTF in das TPicture ausgegeben und das JvRichEdit anschließen wieder gelöscht. Soweit kein Problem.

Im AfterCellPaint sieht's dann so aus:

Delphi-Quellcode:

procedure TfrmMain.vstTermineAfterCellPaint(Sender: TBaseVirtualTree;
    TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect:
    TRect);
  procedure AddSymbol(SymbolIndex: Integer; AddText: string; var DestBMP: TBitmap);
  var
    bmp: TBitmap;
    textwidth: Integer;
    textleft: Integer;
    destleft: Integer;
  begin
    bmp:=TBitmap.Create;
    try
      ilInformation.GetBitmap(SymbolIndex, bmp);
      if AddText<>'' then
      begin
        bmp.Canvas.Font.Size:=vstTermine.Font.Size;
        bmp.Canvas.Font.Style:=[fsBold];
        textwidth:=bmp.Canvas.TextWidth(AddText);
        textleft:=bmp.Width;
        bmp.Width:=bmp.Width+textwidth+4;
        bmp.Canvas.TextOut(textleft+2, Trunc((bmp.Height-bmp.Canvas.TextHeight(AddText))/2), AddText);
      end;
      destleft:=DestBMP.Width;
      DestBMP.Width:=DestBMP.Width+bmp.Width;  //<--- Manchmal tritt der Fehler hier auf
      BitBlt(DestBMP.Canvas.Handle, Destleft, 0, bmp.Width, bmp.Height, bmp.Canvas.Handle, 0, 0, SRCCOPY);
    finally
      bmp.Free;
    end;
  end;
var
  t: TTermin;
  bmp: TBitmap;
begin
  t:=TTermin(vstTermine.GetNodeData(Node)^);
  if Assigned(t) then
  begin
    case Column of
      11:          begin
          if t.RTFTextList.Items(ttArbeiten)<>Nil then
          begin
            top:=Trunc((CellRect.Height-t.RTFTextList.Items(ttArbeiten).pic.Bitmap.Height)/2);
            BitBlt(TargetCanvas.Handle, CellRect.Left, CellRect.Top+top, CellRect.Width, CellRect.Height, t.RTFTextList.Items(ttArbeiten).pic.Bitmap.Canvas.Handle, 0, 0, SRCAND);  //<---- Manchmal aber auch hier
          end;
          bmp:=TBitmap.Create;
          bmp.Height:=ilInformation.Height;
          bmp.Width:=0;
          try
          try
            if t.TB then AddSymbol(SymTB, '', bmp);
            if t.TD then AddSymbol(SymTD, '', bmp);
            if t.FD then AddSymbol(SymFD, '', bmp);
            if t.HB then AddSymbol(SymHB, '', bmp);
            if t.PlainTextList.Items(ttBemerkung)<>nil then
              if t.PlainTextList.Items(ttBemerkung).text<>'' then
                AddSymbol(SymBemerkung, '', bmp);
            if t.REgeschrieben then AddSymbol(SymRE, '', bmp);
            if t.dmsAuftragNr<>'' then AddSymbol(SymAB, '', bmp);
            top:=Trunc((CellRect.Height-bmp.Height)/2);
            BitBlt(TargetCanvas.Handle, CellRect.Left+CellRect.Width-bmp.Width, CellRect.Top+top, bmp.Width, bmp.Height, bmp.Canvas.Handle, 0, 0, SRCCOPY);
          finally
            bmp.Free;
          end;
        end;
    end;
  end;
end;

Der Fehler tritt nicht regelmäßig auf. Aber doch sooft, dass nicht wirklich damit arbeiten kann. Die Objekte sind alle das, das habe ich geprüft.
Vor allem der Fehler in der Procedure AddSymbol, wo das Bitmap für die überlagerten Symbol gezeichnet wird, sollte doch eigentlich nicht auftreten.

Hat jemand eine Idee, wie ich dem Fehler auf die Spurkommen kann.
Bild vom MADExcept habe ich mal als Anhang beigefügt.

[hoika]

Hallo,
du erzeugst Bitmaps und gibst sie nicht mehr frei.

FastMM4 benutzen oder ReportMemoryLeaksAtShutDown.

Dann einen VST mit 1-2 Einträgen und laufen lassen.
Danach siehst Du, wo das entsprechende Objekt erzeugt, aber nicht freigegeben wurde.


ilInformation.GetBitmap(SymbolIndex, bmp);
Wird in GetBitmap das Bitmap vielleicht auch erzeugt?

[Hobbycoder]

ilInformation Ist eine TImageList. Die wird ja in in bmp kopiert, welches nach dem finally auch wieder freigegeben wird.
FastMM und ReportMemoryLeaksOnShutdown habe ich schon mit mäßigem Erfolg ausprobiert. Leider liefern die mir auch (nicht wenige) MemoryLeaks von UniDAC, zu denen ich aber keine Sources habe. Früher hatte ich mal Zeos verwendet. uniDAC verwende ich im dem Projekt das erste mal.

[Bernhard Geyer]

Zitat von Hobbycoder:

Leider liefern die mir auch (nicht wenige) MemoryLeaks von UniDAC, zu denen ich aber keine Sources habe.

Wir haben auch Unidac und nutzen auch FastMM und uns ist bisher kein MemoryLeak von Unidac (Oracle + MySQL) aufgefallen.

[Hobbycoder]

Zitat von Bernhard Geyer:

Zitat von Hobbycoder:

Leider liefern die mir auch (nicht wenige) MemoryLeaks von UniDAC, zu denen ich aber keine Sources habe.

Wir haben auch Unidac und nutzen auch FastMM und uns ist bisher kein MemoryLeak von Unidac (Oracle + MySQL) aufgefallen.

Gut. Aber wenn ich meine Anwendung kurz starte, dann bekomme ich eine ganz Liste (ReportMemoryLeaksOnShutDown, FastMM muss ich noch mal ausprobieren für mehr Details).
Und da mach ich dann noch nicht mal viel. Die Connection wird geöffnet, es werden 2-3 Query abgefragt, 2 Threads laufen durch. Das wars. Da sind ein paar Einträge, über deren Klassennamen kann meine Klassen erkennen. Das meiste stammt von UniDAC.
Ich will aber nicht ausschließen, dass es mein Fehler ist. Ich arbeite grundsätzlich über Klassen, in denen die Datenbankabfragen laufen. Alles ist über Try..Finally abgesichert, dass jedes object auch wieder freigegeben wird (kann höchstens sein, dass ich es mal an einer Stelle übersehen habe. Aber soweit ich das bisher gesichtet habe, sollte das nicht der Fall sein).

Die Connection halte in einer globalen Klasse, die beim Programmstart erzeugt wird und übergebe die halt immer an die Querys.
Hier mal ein Beispiel für eine Query-Klasse:

Delphi-Quellcode:

procedure TZeitenList.LoadFromDB(Con: TUniConnection; Betriebguid: TGUID);
var
  q: TUniQuery;
  z: TZeiten;
begin
  q:=TUniQuery.Create(nil);
  try
    self.Clear;
    q.Connection:=Con;
    q.SQL.Text:='Select * from zeiten where betriebguid=:betriebguid order by ID';
    q.Params.ParamValues['betriebguid']:=Betriebguid.ToString;
    q.Active:=True;
    while not q.Eof do
    begin
      z:=TZeiten.Create;
      z.ID:=q.FieldByName('ID').AsInteger;
      z.guid:=StringToGUID(q.FieldByName('guid').AsString);
      z.betriebguid:=StringToGUID(q.FieldByName('betriebguid').AsString);
      z.zeitstr:=q.FieldByName('zeitstr').AsString;
      self.Add(z);
      q.Next;
    end;
    q.active:=False
  finally
    q.Free;
  end;
end;

Ungefähr so sehen alle Abfragen aus.
Und meine globale Klasse sieht so aus:

Delphi-Quellcode:

unit Data.tpdbaccess;

interface

uses Classes, System.SysUtils, Data.DB, DBAccess, Uni, Tools.globalTypes, MySQLUniProvider, Local.ConnectionList, Tools.globalConst,
  MemData;

type
  TOnConnect=procedure(Verindungsname: string) of object;
  TOnDisconnect=procedure of object;
  TOnSendDBUpdateMessage=procedure(Msg: string; Append: Boolean) of object;

  TDBAccess=class
  private
    class var FCon: TUniConnection;
    class var FConnectionList: TConnectionList;
    class var FVerbindungsname: string;
    class var FOnConnect: TOnConnect;
    class var FOnDisconnect: TOnDisconnect;
    class var FOnSendDBUpdatemessage: TOnSendDBUpdateMessage;
    class constructor Create; overload;
    class procedure SetConnectionList(const Value: TConnectionList); static;
    class procedure SetVerbindungsname(const Value: string); static;
    class procedure DoConnect(Verbindungsname: string);
    class procedure DoDisconnect;
    class procedure AfterConnect(Sender: TObject);
    class procedure BeforeDisconnect(Sender: TObject);
    class procedure ConnectionLost(Sender: TObject; Component: TComponent; ConnLoseCouse: TConnLostCause; RetryMode: TRetryMode);
  public
    constructor Create(ConnectionItem: TConnectionItem); overload;
    destructor Destroy; override;
    class function open: Boolean; overload;
    class function open(ConnectionItem: TConnectionItem): Boolean; overload;
    class procedure Close;
    class property ConnectionList: TConnectionList read FConnectionList write SetConnectionList;
    class property Verbindungsname: string read FVerbindungsname write SetVerbindungsname;
    class procedure DoSendDBUpdateMessage(Msg: string; Append: Boolean = False);
    class property OnConnect: TOnConnect read FOnConnect write FOnConnect;
    class property OnDisconnect: TOnDisconnect read FOnDisconnect write FOnDisconnect;
    class property OnSendDBUpdateMessage: TOnSendDBUpdateMessage read FOnSendDBUpdatemessage write FOnSendDBUpdatemessage;
    class procedure GetTables(Strings: TStrings);
    class function ExecuteStatement(Statement: string): Variant; overload;
    class function ExecuteStatement(Statement: string; Params: array of Variant): Variant; overload;
    class function GetNewGUID: TGUID;
    class property Con: TUniConnection read FCon;
  end;

const
  NullGUID='{00000000-0000-0000-0000-000000000000}';

implementation

{ TDBAccess }

class constructor TDBAccess.Create;
begin
  inherited;
  FCon:=TUniConnection.Create(nil);
  FCon.AfterConnect:=AfterConnect;
  FCon.BeforeDisconnect:=BeforeDisconnect;
//  FCon.OnConnectionLost:=ConnectionLost;
  FConnectionList:=TConnectionList.Create(true);
end;

class procedure TDBAccess.AfterConnect(Sender: TObject);
begin
  DoConnect(FVerbindungsname);
end;

class procedure TDBAccess.BeforeDisconnect(Sender: TObject);
begin
  DoDisconnect;
end;

class procedure TDBAccess.Close;
begin
  FCon.Disconnect;
  FVerbindungsname:='';
end;

class procedure TDBAccess.ConnectionLost(Sender: TObject; Component: TComponent;
  ConnLoseCouse: TConnLostCause; RetryMode: TRetryMode);
begin
  RetryMode:=rmReconnect;
end;

constructor TDBAccess.Create(ConnectionItem: TConnectionItem);
begin
  self.Create;
  FCon.ProviderName:=TTPConnectionTypeStr[integer(ConnectionItem.ConnectionType)];
  FCon.Server:=ConnectionItem.Hostname;
  FCon.Port:=ConnectionItem.Port;
  FCon.Database:=ConnectionItem.Database;
  FCon.Username:=ConnectionItem.UserName;
  FCon.Password:=ConnectionItem.Password;
  FVerbindungsname:=ConnectionItem.ConnectionName;
  open;
end;

destructor TDBAccess.Destroy;
begin
  if FCon.Connected then FCon.Disconnect;
  FConnectionList.Free;
  FCon.Free;
  inherited;
end;

class procedure TDBAccess.DoConnect(Verbindungsname: string);
begin
  if Assigned(FOnConnect) then
    FOnConnect(Verbindungsname);
end;

class procedure TDBAccess.DoDisconnect;
begin
  if Assigned(FOnDisconnect) then
    FOnDisconnect;
end;

class procedure TDBAccess.DoSendDBUpdateMessage(Msg: string; Append: Boolean);
begin
  if Assigned(FOnSendDBUpdatemessage) then
    FOnSendDBUpdatemessage(Msg, Append);
end;

class function TDBAccess.ExecuteStatement(Statement: string;
  Params: array of Variant): Variant;
begin
  Result:=FCon.ExecSQL(Statement, Params);
end;

class function TDBAccess.ExecuteStatement(Statement: string): Variant;
begin
  Result:=FCon.ExecSQL(Statement);
end;

class function TDBAccess.GetNewGUID: TGUID;
begin
  createGUID(Result);
end;

class procedure TDBAccess.GetTables(Strings: TStrings);
begin
  FCon.GetTableNames(Strings);
end;

class function TDBAccess.open: Boolean;
begin
  try
    Try
      FCon.Connect;
    Except
      FVerbindungsname:='';
    End;
  finally
    Result:=FCon.Connected;
  end;
end;

class function TDBAccess.open(ConnectionItem: TConnectionItem): Boolean;
begin
  FCon.ProviderName:=TTPConnectionTypeStr[integer(ConnectionItem.ConnectionType)];
  FCon.Server:=ConnectionItem.Hostname;
  FCon.Port:=ConnectionItem.Port;
  FCon.Database:=ConnectionItem.Database;
  FCon.Username:=ConnectionItem.UserName;
  FCon.Password:=ConnectionItem.Password;
  FVerbindungsname:=ConnectionItem.ConnectionName;
  Result:=open;
end;

class procedure TDBAccess.SetConnectionList(const Value: TConnectionList);
begin
  FConnectionList := Value;
end;

class procedure TDBAccess.SetVerbindungsname(const Value: string);
begin
  FVerbindungsname := Value;
end;

end.

Diese wird im Create der Mainform erzeugt und in deren Destroy auch wieder freigegeben.
(Die Threads erzeugen sich natürlich eine eigene TUniConnection).

Bisher hat das auch recht gut funktioniert. Leider habe ich nicht von Anfang an mit ReportMemoryLeaksOnShutDown gearbeitet. Die größe des Projekt macht es jetzt natürlich umso schwieriger.

[Blup]

In vstTermineAfterCellPaint wird eine bmp-Variable verwendet, die nicht lokal deklariert ist.

[hoika]

Hallo,
zumindestens wird ja was angezeigt, aber leider keine Bitmaps.
Die "Ausrede", Projekt ist zu gross, lasse ich nicht gelten

Du kannst es ja abspecken (schrittweise ausklammern).

FastMM4 würde dir die Zeile zeigen, wo die jeweilige Klasse erzeugt wird, die nicht freigegeben wird.
Was schon mal komisch ist, dass er 2 Connections anzeigt.
Kann es sein, das Du deine globale Connection beim Programmende nicht freigibst?

Breakpoint auf destructor TDBAccess.Destroy; setzen und nachschauen

[Aviator]

Die zwei Connections wundern mich auch etwas. Das sollte eigentlich schon die Ursache für die ganzen nachfolgenden Memory Leaks sein.


Aber zurück zur eigentlichen Frage:

Kompiliert denn der SourceCode so überhaupt wie du ihn hier geschrieben hast? Mir fehlt zu dem zweiten try ein except .

Delphi-Quellcode:

      11: begin
          if t.RTFTextList.Items(ttArbeiten)<>Nil then
          begin
            top:=Trunc((CellRect.Height-t.RTFTextList.Items(ttArbeiten).pic.Bitmap.Height)/2);
            BitBlt(TargetCanvas.Handle, CellRect.Left, CellRect.Top+top, CellRect.Width, CellRect.Height, t.RTFTextList.Items(ttArbeiten).pic.Bitmap.Canvas.Handle, 0, 0, SRCAND); //<---- Manchmal aber auch hier
          end;
          bmp:=TBitmap.Create;
          bmp.Height:=ilInformation.Height;
          bmp.Width:=0;
          try
          try
            if t.TB then AddSymbol(SymTB, '', bmp);
            if t.TD then AddSymbol(SymTD, '', bmp);
            if t.FD then AddSymbol(SymFD, '', bmp);
            if t.HB then AddSymbol(SymHB, '', bmp);
            if t.PlainTextList.Items(ttBemerkung)<>nil then
              if t.PlainTextList.Items(ttBemerkung).text<>'' then
                AddSymbol(SymBemerkung, '', bmp);
            if t.REgeschrieben then AddSymbol(SymRE, '', bmp);
            if t.dmsAuftragNr<>'' then AddSymbol(SymAB, '', bmp);
            top:=Trunc((CellRect.Height-bmp.Height)/2);
            BitBlt(TargetCanvas.Handle, CellRect.Left+CellRect.Width-bmp.Width, CellRect.Top+top, bmp.Width, bmp.Height, bmp.Canvas.Handle, 0, 0, SRCCOPY);
          finally
            bmp.Free;
          end;
        end;

Dinge die du mal noch ausprobieren kannst:

Dann würde ich an deiner Stelle mal Teile der Paint Procedure auskommentieren und schauen, ob der Fehler immer noch auftritt.
Erkennst du den Fehler nur daran, dass die CPU Auslastung nach oben geht? Oder läuft dein RAM irgendwann voll? Kannst du mal testen was passiert, wenn du die AddSymbol Procedure direkt integrierst und das Kopieren des Bitmaps in den var Parameter auslässt und stattdessen direkt auf das Canvas malst?

[Hobbycoder]

Zitat von Blup:

In vstTermineAfterCellPaint wird eine bmp-Variable verwendet, die nicht lokal deklariert ist.

Oh, ja, sorry, ich hatte die Funktion leicht gekürzt (einige Case rausgeschissen). und damit es nicht verwirrt auch die Var-Declarationen, die mit dem Fehler nicht zu tun haben können.
Tatsächlich wird die bmp lokal deklariert. (Hab das oben korrigiert)

Zitat von hoika:

Hallo,
zumindestens wird ja was angezeigt, aber leider keine Bitmaps.

Doch. Der Fehler tritt ja nicht immer auf. Die Bitmap sehe ich im VST. Und ich kann auch nicht sagen, dass mir da was fehlt, wenn ich im MADExcept auf Continue Klicke. Zur Zeit habe ich das Gefühl, dass mehr Zeile den Fehler eher auftreten lassen. Das ist aber nur gefühlt. Ich bin gerade dabei, das ganze mal so zu ändern, dass ich nur mit 2-3 Zeilen arbeiten kann.

Zitat von hoika:

Die "Ausrede", Projekt ist zu gross, lasse ich nicht gelten

Du kannst es ja abspecken (schrittweise ausklammern).

Darauf wird wohl hinauslaufen. Wahrscheinlich muss ich noch back to the roots, und mir das mit der Connection / Globalen Klasse noch mal genau anschauen. Ich glaube fast das da im Constructor/Destructor irgendwas im argen liegt.

Zitat von hoika:

FastMM4 würde dir die Zeile zeigen, wo die jeweilige Klasse erzeugt wird, die nicht freigegeben wird.
Was schon mal komisch ist, dass er 2 Connections anzeigt.
Kann es sein, das Du deine globale Connection beim Programmende nicht freigibst?

FastMM werde ich auch noch mal ausprobieren.
Also im Mainthread verwende ich definitiv nur 1 Connection. Ich muss mal die Threads deaktivieren. Möglicherweise stammt die zweite Connection ja von einem der Threads (die eigentlich alle vor Programmende korrekt beendet werden).

Zitat von Aviator:

Die zwei Connections wundern mich auch etwas. Das sollte eigentlich schon die Ursache für die ganzen nachfolgenden Memory Leaks sein.


Aber zurück zur eigentlichen Frage:

Kompiliert denn der SourceCode so überhaupt wie du ihn hier geschrieben hast? Mir fehlt zu dem zweiten try ein except .

Das war ein Fehler beim zusammen kopieren. Es gibt nur ein Try. Ich hatte die Methode wie oben bereits erwähnt etwas eingekürzt, dass die restlichen Case-Fälle mit dem Fehler nichts zu tun haben können. Zwar wird auch da gezeichnet, aber nur in dieser Spalte tritt der Fehler auf. Das hatte ich durch Auskommentieren bereits getestet.

Zitat von Aviator:

Dinge die du mal noch ausprobieren kannst:

Dann würde ich an deiner Stelle mal Teile der Paint Procedure auskommentieren und schauen, ob der Fehler immer noch auftritt.
Erkennst du den Fehler nur daran, dass die CPU Auslastung nach oben geht? Oder läuft dein RAM irgendwann voll? Kannst du mal testen was passiert, wenn du die AddSymbol Procedure direkt integrierst und das Kopieren des Bitmaps in den var Parameter auslässt und stattdessen direkt auf das Canvas malst?

Auskommentieren habe ich bereits gemacht und somit auf diese Spalte reduziert. CPU-Auslastung ist normal 3-5 % und auch Ram wird nicht soviel belegt, dass es jetzt irgendwie auffällig wäre. Aber ich werde mal die AddSymbol-Methode ganz auskommentieren und mal schauen was sich verändert.

[HolgerX]

Hmm..

Zitat von Hobbycoder:

Die Connection halte in einer globalen Klasse, die beim Programmstart erzeugt wird und übergebe die halt immer an die Querys.
..
Und meine globale Klasse sieht so aus:
..
Diese wird im Create der Mainform erzeugt und in deren Destroy auch wieder freigegeben.
(Die Threads erzeugen sich natürlich eine eigene TUniConnection).

Wieso ist deine TDBAccess eigentlich komplett 'class xxx'.

Nimm doch mal hier das 'class' vor allen Funktionen weg und mach Dir ein 'echtes' Objecte im Create vom MainForm...

Vielleicht bringt dass das Speichermanagment etwas durcheinander und somit auch FMM..

(Nur so eine Idee von jemandem der 'class var .. ' nicht mag )