Alle Memory Leaks beseitigen

[milos]

Hallo,

ich arbeite ja an einem Json Parser.
Ich wollte nun die paar kleinen MemoryLeaks entfernen finde jedoch keinen mehr.

Könnte mir jemand Tipps geben wie ich die am besten finden und beseitigen kann?

Code und MemoryLeaks sind angehängt.

Delphi-Quellcode:

unit Unit1;

interface

uses
  SysUtils;

type
  TJsonType = ( jntArray,
                jntBoolean,
                jntInteger,
                jntFloat,
                jntNull,
                jntObject,
                jntString,
                jntUnknown );


  TStringArray = class
  private
  public
    Strings : array of string;
    procedure Add(AString : string);
    procedure Clear;
    function Count : integer;
  end;

  TJsonObject = class;

  TJsonArray = class;

  TJsonValue = class
  private
    FValue : string;
    function FGetType : TJsonType;
  public
    Key : string;

    procedure GetValue(var AOutput : TJsonArray); overload;
    procedure GetValue(var AOutput : boolean); overload;
    procedure GetValue(var AOutput : double); overload;
    procedure GetValue(var AOutput : integer); overload;
    procedure GetValue(var AOutput : string); overload;
    procedure GetValue(var AOutput : TJsonObject); overload;

    procedure Assign(AJsonText : string);
    property NativeValue : string read FValue;

    property ValueType : TJsonType read FGetType;

  end;

  TJsonArray = class
  protected
    FValues : array of TJsonValue;
    function FGetValue(Key : Integer) : TJsonValue;
  public
    procedure Add(AJsonValue : TJsonValue);
    function Count : integer;
    procedure Clear;
    property Value[Key : integer] : TJsonValue read FGetValue; default;
  public

  end;

  TJsonValues = class(TJsonArray)
  protected
    function FGetValue(Key : string) : TJsonValue;
  public
    procedure Add(AString : string; AJsonValue : TJsonValue);
    property Value[Key : string] : TJsonValue read FGetValue; default;
  end;


  TJsonObject = class
  protected
    FValues : TJsonValues;
    FKeys : TStringArray;

    function FGetValue(Key : string) : TJsonValue;
  public
    constructor Create;

    procedure AddValue(AKey : string; AJsonValue : TJsonValue);

    procedure Clear();
    procedure Parse(AJsonText : string);

    property Value[Key : string] : TJsonValue read FGetValue; default;
    property Keys : TStringArray read FKeys;
    destructor Destroy(); override;
  end;

    procedure Format(AJsonText : string; var AOutPut: string);

implementation


procedure Format(AJsonText : string; var AOutPut: string);
var
  CurrentCharIndex: Integer;
  CurrentChar : char;
  OutputString : string;
  InString : boolean;
begin
  InString := False;

  for CurrentCharIndex := 1 to Length(AJsonText) do
  begin
    CurrentChar := AJsonText[CurrentCharIndex];

    if (CurrentChar = '"') then
      InString := not InString;

    if ((CurrentChar = ' ') and (InString = false)) or
       ((CurrentChar = #10) or (CurrentChar = #13)) then
      Continue;

    OutputString := OutputString + CurrentChar;
  end;
  AOutPut := OutputString;
end;

{ TJsonObject }

procedure TJsonObject.AddValue(AKey: string; AJsonValue: TJsonValue);
begin
  FValues.Add(AKey, AJsonValue);
end;

procedure TJsonObject.Clear;
begin
  FValues.Clear;
end;

constructor TJsonObject.Create;
begin
  FKeys := TStringArray.Create;
  FValues := TJsonValues.Create;
end;

destructor TJsonObject.Destroy;
begin
  FValues.Free;
  FKeys.Free;
end;

function TJsonObject.FGetValue(Key: string): TJsonValue;
begin
  Result := FValues[Key];
end;


procedure TJsonObject.Parse(AJsonText: string);
var
  FormatedJsonText : string;

  CurrentCharIndex : integer;
  CurrentChar : Char;
  LastChar : Char;

  CurrentKey : string;

  StringBuffer : string;

  LineStarted : Boolean;

  InKey : Boolean;
  InValue : Boolean;

  KeyDone : Boolean;
  ValueDone : Boolean;

  ObjectStarted : Boolean;

  ObjCount : integer;

  InArray : Boolean;
  ArrCount : integer;
begin
  Format(AJsonText, FormatedJsonText);

  CurrentKey := '';
  StringBuffer := '';
  LineSTarted := false;
  InKey := false;
  InValue := false;
  KeyDone := false;
  ValueDone := false;
  ObjectStarted := false;
  ObjCount := 0;
  ArrCount := 0;

  for CurrentCharIndex := 1 to Length(FormatedJsonText) do
  begin
    CurrentChar := FormatedJsonText[CurrentCharIndex];
    LastChar := FormatedJsonText[CurrentCharIndex-1];

    if (CurrentCharIndex = 1) and
       (CurrentChar = '{') then
    begin
      ObjectStarted := true;
      Continue;
    end;

    if ObjectStarted then
    begin
      if not(InKey) and not(InValue) then
      begin
        if not(KeyDone) then
        begin
          if CurrentChar = '"' then
          begin
            InKey := True;
            Continue;
          end
          else
          begin
            raise Exception.Create('Key muss gestartet werden');
            Break;
          end;
        end
        else if KeyDone and not InKey then
        begin
          if CurrentChar = ':' then
          begin
            InValue := true;
            Continue;
          end
          else
          begin
            raise Exception.Create('String muss gestartet werden. ' + CurrentKey + ' ' + IntToStr(CurrentCharIndex));
            Break;
          end;
        end;
      end;

      if InKey then
      begin
        if CurrentChar = '"' then
        begin
          CurrentKey := StringBuffer;
          StringBuffer := '';
          AddValue(CurrentKey, TJsonValue.Create);
          Keys.Add(CurrentKey);
          InKey := false;
          KeyDone := true;
          Continue;
        end
        else
        begin
          StringBuffer := StringBuffer + CurrentChar;
        end;
      end;

      if InValue then
      begin
        if CurrentChar = '{' then
        begin
          ObjCount := ObjCount + 1;
        end
        else if CurrentChar = '[' then
        begin
          ArrCount := ArrCount + 1;
        end
        else if (CurrentChar = '}') and
                (not(ObjCount = 0)) then
        begin
          ObjCount := ObjCount - 1;
        end
        else if (CurrentChar = ']') and
                (not(ArrCount = 0)) then
        begin
          ArrCount := ArrCount - 1;
        end
        else if ((CurrentChar = ',') and (ObjCount + ArrCount = 0)) or
                ((CurrentChar = ']') and (ObjCount + ArrCount = 0)) or
                ((CurrentChar = '}') and (ObjCount + ArrCount = 0)) then
        begin
          FValues[CurrentKey].FValue := StringBuffer;
          StringBuffer := '';
          ValueDone := false;
          InValue := false;
          KeyDone := false;
          Continue;
        end;

        StringBuffer := StringBuffer + CurrentChar;
      end;
    end
    else
    begin
      raise Exception.Create('Objekt muss gestartet werden');
      Break;
    end;
  end;
end;

{ TJsonValue }

procedure TJsonValue.Assign(AJsonText: string);
begin
  FValue := AJsonText;
end;

function TJsonValue.FGetType: TJsonType;
var
  LJsonObject : TJsonObject;
  iCode : integer;
  LInteger : integer;
  LFLoat : Double;
begin
  if FValue = '' then
  begin
    Result := jntNull;
    Exit;
  end;

  if (LowerCase(FValue) = 'true') or
     (LowerCase(FValue) = 'false') then
     Result := jntBoolean
  else if (FValue[1] = '"') and
          (FValue[Length(FValue)] = '"') then
    Result := jntString
  else if (FValue[1] = '[') and
          (FValue[Length(FValue)] = ']') then
    Result := jntArray
  else if (FValue[1] = '{') and
          (FValue[Length(FValue)] = '}') then
    Result := jntObject
  else if LowerCase(FValue) = 'null' then
    Result := jntNull
  else
  begin
    Val(FValue,LInteger,iCode);
    if iCode = 0 then
      Result := jntInteger
    else if TryStrToFloat(FValue,LFloat) then
      Result := jntFloat;
  end;
end;


procedure TJsonValue.GetValue(var AOutput: TJsonArray);
var
  InKey : Boolean;
  InValue : Boolean;

  LJsonArray : TJsonArray;

  CurrentCharIndex: Integer;
  CurrentChar : Char;

  StringBuffer : string;

  ArrCount : integer;
  ObjCount : integer;
begin
  ObjCount := 0;
  ArrCount := 0;

  InKey := False;
  InValue := false;

  StringBuffer := '';

  LJsonArray := TJsonArray.Create;

  for CurrentCharIndex := 2 to Length(FValue)-1 do
  begin
    CurrentChar := FValue[CurrentCharIndex];

    if CurrentChar = '{' then
      ObjCount := ObjCount + 1
    else if CurrentChar = '}' then
      ObjCount := ObjCount - 1
    else if CurrentChar = '[' then
      ArrCount := ArrCount + 1
    else if CurrentChar = ']' then
      ArrCount := ArrCount - 1;

    if (not(CurrentChar = ',')) or (ArrCount + ObjCount >= 1) then
    begin
      StringBuffer := StringBuffer + CurrentChar;
    end;

    if ((CurrentChar = ',') and
       (ArrCount + ObjCount = 0)) or
       (CurrentCharIndex = Length(FValue)-1) then
    begin
      if StringBuffer = '' then
      begin
        raise Exception.Create('No Input to array field');
        Exit;
      end;
      LJsonArray.Add(TJsonValue.Create);
      LJsonArray[LJsonArray.Count-1].Assign(StringBuffer);
      StringBuffer := '';
    end;
  end;

  AOutput := LJsonArray;
end;

procedure TJsonValue.GetValue(var AOutput: integer);
begin
  try
    AOutput := StrToInt(FValue);
  except
    raise Exception.Create('Inhalt ist kein Integer. "' + FValue + '"');
  end;
end;

procedure TJsonValue.GetValue(var AOutput: boolean);
begin
  if LowerCase(FValue) = 'true' then
    AOutput := true
  else if LowerCase(FValue) = 'false' then
    AOutput := False
  else
    raise Exception.Create('Inhalt ist kein Boolean. "' + FValue + '"');
end;

procedure TJsonValue.GetValue(var AOutput: TJsonObject);
begin
  AOutput.Parse(FValue);
end;

procedure TJsonValue.GetValue(var AOutput: double);
begin
  try
    AOutput := StrToFloat(FValue);
  except
    raise Exception.Create('Inhalt ist kein Float. "' + FValue + '"');
  end;
end;

procedure TJsonValue.GetValue(var AOutput: string);
begin
  if (FValue[1] = '"') and
     (FValue[Length(FValue)] = '"') then
    AOutput := Copy(FValue, 2, Length(FValue)-2)
  else
    raise Exception.Create('Inhalt ist kein String. "' + FValue + '"');
end;

{ TStringArray }

procedure TStringArray.Add(AString: string);
begin
  SetLength(Strings, Length(Strings)+1);
  Strings[Length(Strings)-1] := AString;
end;

procedure TStringArray.Clear;
begin

end;

function TStringArray.Count: integer;
begin
  Result := Length(Strings);
end;

{ TJsonArray }

procedure TJsonArray.Add(AJsonValue: TJsonValue);
begin
  SetLength(FValues, Count+1);
  FValues[Count-1] := AJsonValue;
end;

procedure TJsonArray.Clear;
begin

end;

function TJsonArray.Count: integer;
begin
  Result := Length(FValues);
end;


function TJsonArray.FGetValue(Key: Integer): TJsonValue;
begin

end;

{ TJsonValues }

procedure TJsonValues.Add(AString: string; AJsonValue: TJsonValue);
begin
  inherited Add(AJsonValue);
  FValues[Count-1].Key := AString;
end;

function TJsonValues.FGetValue(Key: string): TJsonValue;
var
  c: Integer;
begin
  for c := 0 to Count-1 do
  begin
    if FValues[c].Key = Key then
      Result := FValues[c];
  end;
end;

end.

Delphi-Quellcode:

procedure TForm2.btn1Click(Sender: TObject);
var
  json : TJsonObject;
begin
  json := TJsonObject.Create;
  json.Parse(mmo1.text);
  json.Free;
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutdown := true;
end;

Freundliche Grüsse

[Dalai]

Deine Klasse TStringArray hat zwar eine Methode Clear, aber die tut nix (die will noch nicht einmal spielen ), daher auch die Speicherlecks. Ob das alle Lecks verursacht, weiß ich nicht, denn das untersuche ich zu dieser Stunde nicht mehr.

Übrigens ist es immer gut, je ein inherited; im Konstruktor und Destruktor stehen zu haben. Warum? Nun, zum Zeitpunkt X leitet man vielleicht von TObject ab (dessen Kon- und Destruktoren leer sind), aber vielleicht will/muss man die Ableitung zu Zeitpunkt X+X mal ändern auf eine Klasse, dessen Kon- und Destruktoren etwas tun und schon hat man ohne inherited; wunderschöne Lecks; ich hatte das heute selbst bei einer von TStringList abgeleiteten Klasse.

Davon abgesehen frage ich mich, warum du nicht gleich TStringList benutzt und stattdessen das Rad (die Strings) neu erfindest.

MfG Dalai

[Insider2004]

Nimm doch was Gscheides: https://github.com/ahausladen/JsonDataObjects

[himitsu]

Das große FastMM benutzen und dort das erweiterte Reporting (Logging) aktivieren.

Da du aber weißt, daß da irgendwo 9x TJsonValue zurück bleiben, kannst du dort anfangen.

• in Create und Destroy ein Logging einbauen
• entweder erstellen und löschen loggen und selber nachsehn
• oder im Create das Objekt in eine globale TList eintragen und beim Destroy wieder entfernen
  so kann man am Ende nachhsehn was noch zurückgeblieben ist und kann davon Name+Value ausgeben

Die restlichen Leaks könnten darauf zurückzuführen seinen und sind vielleich weg, wenn du die Objekte alle freigibst.
Also erstmal das Eine beseitigen und dann schauen was sonst noch übrig ist.
(Meine JSON-Klassen hab ich gerade dswegen gebastelt, wegen der neuen/exotischen Speicherverwaltung, um diese zu Testen. Und dort hab ich via IFDEF die Variante mit der Liste eingebaut, samt einer Funktion für zum Ausgeben dieser Liste)

[himitsu]

Zitat von Insider2004:

Nimm doch was Gscheides: https://github.com/ahausladen/JsonDataObjects

Wenn selbst Andreas an swas bastelt, dann muß es ja doch einen Markt für neue JSON-projekte geben.
PS: Siehe seine Quellcodes ... er hat auch extra einen Unit-Test eingebaut, um einfach zu prüfen, ob da alles richtig läuft.

Erschreckend ist aber, daß er scheinbar etwa zur selben Zeit angefangen hat.

[Popov]

Wie schon erwähnt, inherited ist an der Stelle nicht wirklich wichtig, aber ich erkenne daran immer ganz schnelle die Konstruktoren und Destruktoren.

Delphi-Quellcode:

constructor TJsonObject.Create;
begin
  inherited;
  FKeys := TStringArray.Create;
  FValues := TJsonValues.Create;
end;

destructor TJsonObject.Destroy;
begin
  FValues.Free;
  FKeys.Free;
  inherited;
end;

Ich muss zugeben, dass ich gerade erst aufgestanden bin und erst meinen Kaffee trinke. Was wird hier noch mal gemacht?

Delphi-Quellcode:

procedure TJsonObject.Parse(AJsonText: string);
...
begin
...
          AddValue(CurrentKey, TJsonValue.Create);                             //<<<<<<<<<<<<<<<<<<<<<<<

Ich will nicht behaupten, dass das etwas ist, ich kenne nur diese Technik nicht. Die geibt es hier noch mal:

Delphi-Quellcode:

procedure TJsonValue.GetValue(var AOutput: TJsonArray);
...
begin
...
      LJsonArray.Add(TJsonValue.Create);                                        //<<<<<<<<<<<<<<<<<<

Dann hier noch was:

Delphi-Quellcode:

procedure TJsonValue.GetValue(var AOutput: TJsonArray);
...
begin
...
  LJsonArray := TJsonArray.Create;                                              //<<<<<<<<<<<<<<<<<<<<<<<<<

Ich hab mir angewöhnt immer mit try finally zu arbeiten. Erstelle ich ein Objekt, ist die nächste Zeile ein try . Der Rest ergibt sich dann automatisch. Vergesse ich finally , gibt es Krach. Schreibe ich es, gebe ich auch alles wieder frei.

Hier gibst du etwas ein. Gibst du es wieder frei?

Delphi-Quellcode:

procedure TJsonArray.Add(AJsonValue: TJsonValue);
begin
  SetLength(FValues, Count+1);
  FValues[Count-1] := AJsonValue;
end;

procedure TJsonArray.Clear;
begin

end;

Wie gesagt, das auf die Schnelle ohne den Code genauer zu studieren.

[himitsu]

Zitat:

Delphi-Quellcode:

procedure TJsonArray.Clear;
begin

end;

destructor TJsonObject.Destroy;
begin
  FValues.Free;

Und wann werden die Items in dieser Liste freigegen?
-> nie

Entweder du machst das selber oder du nimmst eine TObjectList / TObjectList<T> mit OwnsObjects=True.

Ich würde auch eines der vielen Tutorials bezüglich Fehlerbehandlung empfehlen.
Wenn ich z.B. ein "neues" Objekt zurückgebe und zwischen der Erstellung und dem Methodenende Fehler auftreten könnten, dann wird das immer via Try-Except abgesichert.

Delphi-Quellcode:

function Test: TObject;
begin
  Result := TObject.Create;
  ...  // hier irgendwas "Gefährliches" machen
end;  // bei einer Exception kümmert sich keiner mehr um die Freigabe des Objektes

function Test: TObject;
begin
  Result := TObject.Create;
  try
    ...  // hier irgendwas "Gefährliches" machen
  except
    Result.Free;  // bei Fehler wieder Freigeben
    raise;  // und abgefangenen Fehler weiterreichen
  end;
end;

[Popov]

Jep. TObjectList ist eine feine Sache. Im Gegensatz zu anderen Klassen die Objekte aufnehmen (zumindest in D7, später, habe ich mir sagen lassen, können das auch andere Klassen), kann man TObjectList mit Objekten bis oben hin vollknallen. Beim richtigen Parameter wird dann alles automatisch wieder freigegeben.

[himitsu]

Ja, aber leider hat z.B. schainbar irgendein Idiot nicht richtig mitgedacht.
CrossPlattform-Entwicklung ist einfach nur bähhhh.

In den Schnittstellen der LiveBindings wird TList<T> verwendet.
Im NextGen ist TList<T> und TObjectList<T> quasi das Selbe, da dort praktisch alle Objekte über das ARC automatisch freigegeben werden, sobald es nirgendwo mehr eine Referenz gibt,
aber in den notmalen Compilern fehlt dort plötlich das OwnsObjects.