Fix potential memory corruption in TPythonVariantType.DispInvoke (freeing WideStrings twice)

Author: pyscripter

PythonForDelphi/Components/Sources/Core/VarPyth.pas

@@ -126,6 +126,7 @@ TNamedParamDesc = record
 
 {$IFDEF DELPHIXE2_OR_HIGHER}
  {$DEFINE USESYSTEMDISPINVOKE} //Delphi 2010 DispInvoke is buggy
+ {$DEFINE PATCHEDSYSTEMDISPINVOKE} //To correct memory leaks
 {$ENDIF}
 {.$IF DEFINED(FPC_FULLVERSION) and (FPC_FULLVERSION >= 20500)}
  {.$DEFINE USESYSTEMDISPINVOKE}
@@ -944,17 +945,40 @@ procedure TPythonVariantType.DispInvoke(Dest: PVarData;
  var Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
 {$ENDIF}
 {$IFDEF USESYSTEMDISPINVOKE}
-{$IFDEF DELPHIXE2_OR_HIGHER}
- // Modified to correct memory leak QC102387
+{$IFDEF PATCHEDSYSTEMDISPINVOKE}
+ // Modified to correct memory leak QC102387 / RSP-23093
+ procedure PatchedFinalizeDispatchInvokeArgs(CallDesc: PCallDesc; const Args: TVarDataArray; OrderLTR : Boolean);
+ const
+ atByRef = $80;
+ var
+ I: Integer;
+ ArgType: Byte;
+ PVarParm: PVarData;
+ VType: TVarType;
+ begin
+ for I := 0 to CallDesc^.ArgCount-1 do
+ begin
+ ArgType := CallDesc^.ArgTypes[I];
+
+ if OrderLTR then
+ PVarParm := @Args[I]
+ else
+ PVarParm := @Args[CallDesc^.ArgCount-I-1];
+
+ VType := PVarParm.VType;
+
+ // Only ByVal Variant or Array parameters have been copied and need to be released
+ // Strings have been released via the use of the TStringRefList parameter to GetDispatchInvokeArgs
+ // !!Modified to prevent memory leaks!! RSP-23093
+ if ((ArgType and atByRef) <> atByRef) and ((ArgType = varVariant) or ((VType and varArray) = varArray)) then
+ VarClear(PVariant(PVarParm)^);
+ end;
+ end;
+
  procedure PatchedDispInvoke(Dest: PVarData;
  const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
  type
- PParamRec = ^TParamRec;
- TParamRec = array[0..3] of LongInt;
- TStringDesc = record
- BStr: WideString;
- PStr: PAnsiString;
- end;
+ PStringRefList = ^TStringRefList;
  const
  CDoMethod = $01;
  CPropertyGet = $02;
@@ -964,67 +988,75 @@ TStringDesc = record
  LIdent: string;
  LTemp: TVarData;
  VarParams : TVarDataArray;
- Strings: TStringRefList;
+ Strings: array of TStringRef;
+ PIdent: PByte;
  begin
  // Grab the identifier
  LArgCount := CallDesc^.ArgCount;
- LIdent := FixupIdent(string(AnsiString(PAnsiChar(@CallDesc^.ArgTypes[LArgCount]))));
-
- FillChar(Strings, SizeOf(Strings), 0);
- VarParams := GetDispatchInvokeArgs(CallDesc, Params, Strings, true);
-
- // What type of invoke is this?
- case CallDesc^.CallType of
- CDoMethod:
- // procedure with N arguments
- if Dest = nil then
- begin
- if not DoProcedure(Source, LIdent, VarParams) then
+ PIdent := @CallDesc^.ArgTypes[LArgCount];
+ LIdent := FixupIdent( UTF8ToString(MarshaledAString(PIdent)) );
+ if LArgCount > 0 then begin
+ SetLength(Strings, LArgCount);
+ FillChar(Strings[0], SizeOf(TStringRef)*LArgCount, 0);
+ VarParams := GetDispatchInvokeArgs(CallDesc, Params, PStringRefList(Strings)^, true);
+ end;
+ try
+ // What type of invoke is this?
+ case CallDesc^.CallType of
+ CDoMethod:
+ // procedure with N arguments
+ if Dest = nil then
  begin
+ if not DoProcedure(Source, LIdent, VarParams) then
+ begin
+
+ // ok maybe its a function but first we must make room for a result
+ VarDataInit(LTemp);
+ try
+
+ // notate that the destination shouldn't be bothered with
+ // functions can still return stuff, we just do this so they
+ // can tell that they don't need to if they don't want to
+ SetClearVarToEmptyParam(LTemp);
+
+ // ok lets try for that function
+ if not DoFunction(LTemp, Source, LIdent, VarParams) then
+ RaiseDispError;
+ finally
+ VarDataClear(LTemp);
+ end;
+ end
+ end
 
- // ok maybe its a function but first we must make room for a result
- VarDataInit(LTemp);
- try
-
- // notate that the destination shouldn't be bothered with
- // functions can still return stuff, we just do this so they
- // can tell that they don't need to if they don't want to
- SetClearVarToEmptyParam(LTemp);
-
- // ok lets try for that function
- if not DoFunction(LTemp, Source, LIdent, VarParams) then
- RaiseDispError;
- finally
- VarDataClear(LTemp);
- end;
+ // property get or function with 0 argument
+ else if LArgCount = 0 then
+ begin
+ if not GetProperty(Dest^, Source, LIdent) and
+ not DoFunction(Dest^, Source, LIdent, VarParams) then
+ RaiseDispError;
  end
- end
 
- // property get or function with 0 argument
- else if LArgCount = 0 then
- begin
- if not GetProperty(Dest^, Source, LIdent) and
- not DoFunction(Dest^, Source, LIdent, VarParams) then
+ // function with N arguments
+ else if not DoFunction(Dest^, Source, LIdent, VarParams) then
  RaiseDispError;
- end
 
- // function with N arguments
- else if not DoFunction(Dest^, Source, LIdent, VarParams) then
- RaiseDispError;
+ CPropertyGet:
+ if not ((Dest <> nil) and // there must be a dest
+ (LArgCount = 0) and // only no args
+ GetProperty(Dest^, Source, LIdent)) then // get op be valid
+ RaiseDispError;
 
- CPropertyGet:
- if not ((Dest <> nil) and // there must be a dest
- (LArgCount = 0) and // only no args
- GetProperty(Dest^, Source, LIdent)) then // get op be valid
- RaiseDispError;
+ CPropertySet:
+ if not ((Dest = nil) and // there can't be a dest
+ (LArgCount = 1) and // can only be one arg
+ SetProperty(Source, LIdent, VarParams[0])) then // set op be valid
+ RaiseDispError;
+ else
+ RaiseDispError;
+ end;
 
- CPropertySet:
- if not ((Dest = nil) and // there can't be a dest
- (LArgCount = 1) and // can only be one arg
- SetProperty(Source, LIdent, VarParams[0])) then // set op be valid
- RaiseDispError;
- else
- RaiseDispError;
+ finally
+ PatchedFinalizeDispatchInvokeArgs(CallDesc, VarParams, true);
  end;
 
  for I := 0 to Length(Strings) - 1 do
@@ -1033,13 +1065,12 @@ TStringDesc = record
  Break;
  if Strings[I].Ansi <> nil then
  Strings[I].Ansi^ := AnsiString(Strings[I].Wide)
- else if Strings[I].Unicode <> nil then
- Strings[I].Unicode^ := UnicodeString(Strings[I].Wide)
+ else
+ if Strings[I].Unicode <> nil then
+ Strings[I].Unicode^ := UnicodeString(Strings[I].Wide)
  end;
- for I := Low(VarParams) to High(VarParams) do
- VarDataClear(VarParams[I]);
  end;
-{$ENDIF DELPHIXE2_OR_HIGHER}
+{$ENDIF PATCHEDSYSTEMDISPINVOKE}
 
  procedure GetNamedParams;
  var
@@ -1066,17 +1097,17 @@ TStringDesc = record
  if (CallDesc^.CallType = CPropertyGet) and (CallDesc^.ArgCount = 1) then begin
  NewCallDesc := CallDesc^;
  NewCallDesc.CallType := CDoMethod;
- {$IFDEF DELPHIXE2_OR_HIGHER}
+ {$IFDEF PATCHEDSYSTEMDISPINVOKE}
  PatchedDispInvoke(Dest, Source, @NewCallDesc, Params);
- {$ELSE DELPHIXE2_OR_HIGHER}
+ {$ELSE PATCHEDSYSTEMDISPINVOKE}
  inherited DispInvoke(Dest, Source, @NewCallDesc, Params);
- {$ENDIF DELPHIXE2_OR_HIGHER}
+ {$ENDIF PATCHEDSYSTEMDISPINVOKE}
  end else
- {$IFDEF DELPHIXE2_OR_HIGHER}
+ {$IFDEF PATCHEDSYSTEMDISPINVOKE}
  PatchedDispInvoke(Dest, Source, CallDesc, Params);
- {$ELSE DELPHIXE2_OR_HIGHER}
+ {$ELSE PATCHEDSYSTEMDISPINVOKE}
  inherited;
- {$ENDIF DELPHIXE2_OR_HIGHER}
+ {$ENDIF PATCHEDSYSTEMDISPINVOKE}
  finally
  if CallDesc^.NamedArgCount > 0 then SetLength(fNamedParams, 0);
  end;