paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-22 02:39:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

FpDebug: add intrinsics "Pos(SubStr, SearchStr)" and "SubStr(Str, Start, Len, DoPtr)

Browse Source
This commit is contained in:
Martin 2022-09-18 23:42:16 +02:00
parent 4bdc8f2702
commit 753799d887
4 changed files with 221 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
components/fpdebug/fpdmemorytools.pas
View File

@ -441,7 +441,7 @@ type
function SetLength(var ADest: AnsiString; ALength: Int64): Boolean; overload;
function SetLength(var ADest: WideString; ALength: Int64): Boolean; overload;
function CheckDataSize(ASize: Int64): Boolean;
function ReadPChar(const ALocation: TFpDbgMemLocation; AMaxChars: Int64; out AValue: AnsiString): Boolean;
function ReadPChar(const ALocation: TFpDbgMemLocation; AMaxChars: Int64; out AValue: AnsiString; NoTrimToZero: Boolean = False): Boolean;
function ReadPWChar(const ALocation: TFpDbgMemLocation; AMaxChars: Int64; out AValue: WideString): Boolean;
property TargetMemConvertor: TFpDbgMemConvertor read FTargetMemConvertor;
@ -1922,7 +1922,7 @@ begin
end;
function TFpDbgMemManager.ReadPChar(const ALocation: TFpDbgMemLocation;
AMaxChars: Int64; out AValue: AnsiString): Boolean;
AMaxChars: Int64; out AValue: AnsiString; NoTrimToZero: Boolean): Boolean;
var
i: QWord;
begin
@ -1945,9 +1945,11 @@ begin
Result := True;
i := PartialReadResultLenght;
SetLength(AValue, i);
i := pos(#0, AValue);
if i > 0 then
SetLength(AValue, i-1);
if not NoTrimToZero then begin
i := pos(#0, AValue);
if i > 0 then
SetLength(AValue, i-1);
end;
exit;
end
end;

197
components/fpdebug/fppascalparser.pas
View File

@ -50,7 +50,7 @@ type
TSeparatorType = (ppstComma);
TFpIntrinsicPrefix = (ipColon, ipExclamation, ipNoPrefix);
TFpIntrinsicFunc = (ifErrorNotFound, ifLength, ifChildClass, ifRefCount);
TFpIntrinsicFunc = (ifErrorNotFound, ifLength, ifChildClass, ifRefCount, ifPos, ifSubStr);
TFpPascalParserCallFunctionProc = function (AnExpressionPart: TFpPascalExpressionPart;
AFunctionValue: TFpValue; ASelfValue: TFpValue; AParams: TFpPascalExpressionPartList;
@ -218,11 +218,16 @@ type
FIntrinsic: TFpIntrinsicFunc;
FChildClassCastType: TFpValue;
function CheckArgumentCount(AParams: TFpPascalExpressionPartBracketArgumentList; ARequiredCount: Integer): Boolean;
function CheckArgumentCount(AParams: TFpPascalExpressionPartBracketArgumentList; ARequiredCount: Integer; AMaxAccepted: Integer = -1): Boolean;
// GetArg; ANum is 1 based
function GetArg(AParams: TFpPascalExpressionPartBracketArgumentList; ANum: Integer; out AValue: TFpValue;
AnErr: String = ''): Boolean;
protected
function DoLength(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
function DoChildClass(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
function DoRefCnt(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
function DoPos(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
function DoSubStr(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
function DoGetResultValue: TFpValue; override;
function DoGetResultValue(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
@ -1790,12 +1795,16 @@ end;
{ TFpPascalExpressionPartIntrinsic }
function TFpPascalExpressionPartIntrinsic.CheckArgumentCount(
AParams: TFpPascalExpressionPartBracketArgumentList; ARequiredCount: Integer
): Boolean;
AParams: TFpPascalExpressionPartBracketArgumentList; ARequiredCount: Integer;
AMaxAccepted: Integer): Boolean;
var
i: Integer;
begin
Result := AParams.Count - 1 = ARequiredCount;
if AMaxAccepted < 0 then
Result := AParams.Count - 1 = ARequiredCount
else
Result := (AParams.Count - 1 >= ARequiredCount) and
(AParams.Count - 1 <= AMaxAccepted);
if not Result then begin
SetError('wrong argument count');
exit;
@ -1809,6 +1818,26 @@ begin
end;
end;
function TFpPascalExpressionPartIntrinsic.GetArg(
AParams: TFpPascalExpressionPartBracketArgumentList; ANum: Integer; out
AValue: TFpValue; AnErr: String): Boolean;
begin
AValue := nil;
Result := ANum < AParams.Count;
if not Result then begin
if AnErr <> '' then
SetError(AnErr);
exit;
end;
AValue := AParams.Items[ANum].ResultValue;
Result := (AValue <> nil) and (not IsError(Expression.Error)) and (not IsError(AValue.LastError));
if not Result then begin
if AnErr <> '' then
SetError(AnErr);
end;
end;
function TFpPascalExpressionPartIntrinsic.DoLength(
AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
var
@ -1819,11 +1848,8 @@ begin
if not CheckArgumentCount(AParams, 1) then
exit;
Arg := AParams.Items[1].ResultValue;
if (Arg = nil) then begin
SetError('argument not supported');
if not GetArg(AParams, 1, Arg, 'argument required') then
exit;
end;
ResLen := 0;
case Arg.Kind of
@ -1846,18 +1872,17 @@ function TFpPascalExpressionPartIntrinsic.DoChildClass(
AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
var
CastName: String;
NewResult: TFpValue;
NewResult, Arg: TFpValue;
begin
Result := nil;
if not CheckArgumentCount(AParams, 1) then
exit;
Result := AParams.Items[1].ResultValue;
if Result = nil then
if not GetArg(AParams, 1, Arg, 'argument required') then
exit;
Result := Arg;
Result.AddReference;
if IsError(Expression.Error) or IsError(Result.LastError) or
(Result.Kind <> skClass) or (Result.AsCardinal = 0)
if (Result.Kind <> skClass) or (Result.AsCardinal = 0)
then
exit;
@ -1892,16 +1917,150 @@ begin
if not CheckArgumentCount(AParams, 1) then
exit;
Tmp := AParams.Items[1].ResultValue;
if (Tmp = nil) or IsError(Expression.Error) or IsError(Tmp.LastError) then
if not GetArg(AParams, 1, Tmp, 'argument required') then
exit;
if not Tmp.GetFpcRefCount(rcnt) then
if not Tmp.GetFpcRefCount(rcnt) then begin
SetError('argument not supported');
exit;
end;
Result := TFpValueConstNumber.Create(QWord(rcnt), True)
end;
function TFpPascalExpressionPartIntrinsic.DoPos(
AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
var
Tmp, Tmp2, CmpCase: TFpValue;
s1, s2: String;
begin
Result := nil;
if not CheckArgumentCount(AParams, 2, 3) then
exit;
if not GetArg(AParams, 1, Tmp, 'argument required') then exit;
if not GetArg(AParams, 2, Tmp2, 'argument required') then exit;
CmpCase := nil;
if AParams.Count = 4 then begin
if not GetArg(AParams, 3, Tmp, 'argument required') then
exit;
if (CmpCase.Kind <> skBoolean) then begin
SetError('bool argument expected');
exit;
end;
end;
s1 := Tmp.AsString;
s2 := Tmp2.AsString;
if (CmpCase <> nil) and (CmpCase.AsBool) then begin
s1 := LowerCase(s1);
s2 := LowerCase(s2);
end;
if (s1 = '') or (s2 = '') then
Result := TFpValueConstNumber.Create(0, True)
else
Result := TFpValueConstNumber.Create(pos(s1, s2), True);
end;
function TFpPascalExpressionPartIntrinsic.DoSubStr(
AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue;
var
Tmp, Tmp2, Tmp3, Tmp4: TFpValue;
s1, s2: String;
p1, p2: Int64;
UsePtr: Boolean;
Addr: QWord;
begin
Result := nil;
if not CheckArgumentCount(AParams, 3,4) then
exit;
if not GetArg(AParams, 1, Tmp, 'argument required') then exit;
if not GetArg(AParams, 2, Tmp2, 'argument required') then exit;
if not GetArg(AParams, 3, Tmp3, 'argument required') then exit;
UsePtr := False;
if AParams.Count = 5 then begin
if not GetArg(AParams, 4, Tmp4, 'argument required') then
exit;
if (Tmp4.Kind <> skBoolean) then begin
SetError('bool argument expected');
exit;
end;
UsePtr := Tmp4.AsBool;
end;
s1 := Tmp.AsString;
if (s1 = '') and (Tmp.Kind in [skPointer, skAddress]) then begin
if (AParams.Count = 5) and not UsePtr then begin
SetError('expected true for argument 4');
exit;
end;
UsePtr := True;
end;
if svfInteger in Tmp2.FieldFlags then
p1 := Tmp2.AsInteger
else
if svfCardinal in Tmp2.FieldFlags then
{$PUSH}{$R-}{$Q-}
p1 := Int64(Tmp2.AsCardinal)
{$POP}
else begin
SetError('int argument expected');
exit;
end;
if (p1 < 1) and (not UsePtr) then begin
SetError('argument >= 1 expected');
exit;
end;
if svfInteger in Tmp3.FieldFlags then
p2 := Tmp3.AsInteger
else
if svfCardinal in Tmp3.FieldFlags then
{$PUSH}{$R-}{$Q-}
p2 := Int64(Tmp3.AsCardinal)
{$POP}
else begin
SetError('int argument expected');
exit;
end;
if (p2 < 1) and (not UsePtr) then begin
SetError('argument >= 1 expected');
exit;
end;
if UsePtr then begin
if not (Tmp.Kind in [skPointer, skString, skAnsiString, skWideString, skAddress]) then begin
SetError('argument 1 not supported');
end;
Addr := Tmp.AsCardinal;
if Addr = 0 then begin
Result := TFpValueConstString.Create('');
exit;
end;
{$PUSH}{$R-}{$Q-}
Expression.Context.MemManager.ReadPChar(TargetLoc(Addr+QWord(p1)), p2, s1, True);
{$POP}
Result := TFpValueConstString.Create(s1);
exit;
end;
if (s1 = '') then begin
Result := TFpValueConstString.Create('');
exit;
end;
{$PUSH}{$R-}{$Q-}
Result := TFpValueConstString.Create(copy(s1, p1, p2));
{$POP}
end;
function TFpPascalExpressionPartIntrinsic.DoGetResultValue: TFpValue;
begin
Result := nil;
@ -1922,6 +2081,8 @@ begin
ifLength: Result := DoLength(AParams);
ifChildClass: Result := DoChildClass(AParams);
ifRefCount: Result := DoRefCnt(AParams);
ifPos: Result := DoPos(AParams);
ifSubStr: Result := DoSubStr(AParams);
end;
{$IFDEF WITH_REFCOUNT_DEBUG}
if Result <> nil then
@ -2452,9 +2613,11 @@ begin
Result := ifErrorNotFound;
case ALen of
2: if strlicomp(AStart, 'CC', 2) = 0 then Result := ifChildClass;
3: if strlicomp(AStart, 'POS', 3) = 0 then Result := ifPos;
6: case AStart^ of
'l', 'L': if strlicomp(AStart, 'LENGTH', 6) = 0 then Result := ifLength;
'r', 'R': if strlicomp(AStart, 'REFCNT', 6) = 0 then Result := ifRefCount;
's', 'S': if strlicomp(AStart, 'SUBSTR', 6) = 0 then Result := ifSubStr;
end;
end;
end;

21
components/lazdebuggers/lazdebuggerfp/test/testwatches.pas
View File

@ -1582,6 +1582,27 @@ begin
t.Add('refcnt', PREFIX+'refcnt(ARef3)', weInteger( 2, #1, 0)).IgnTypeName();
t.Add('refcnt', PREFIX+'refcnt(ARef4)', weInteger( 2, #1, 0)).IgnTypeName();
t.Add('pos', PREFIX+'pos(''c'', SRef1)', weInteger( 3, #1, 0)).IgnTypeName();
t.Add('pos', PREFIX+'pos(''d'', PCRef1)', weInteger( 4, #1, 0)).IgnTypeName();
t.Add('pos', PREFIX+'pos(''e'', Short0)', weInteger( 5, #1, 0)).IgnTypeName();
t.Add('pos', PREFIX+'pos(''e'', ''1e'')', weInteger( 2, #1, 0)).IgnTypeName();
t.Add('substr', PREFIX+'substr(SRef1, 2,3)', weAnsiStr('bcd', #1)).IgnTypeName();
t.Add('substr', PREFIX+'substr(Short0, 4,3)', weAnsiStr('def', #1)).IgnTypeName();
t.Add('substr', PREFIX+'substr(SRef1, 2,3, false)', weAnsiStr('bcd', #1)).IgnTypeName();
t.Add('substr', PREFIX+'substr(Short0, 4,3, false)', weAnsiStr('def', #1)).IgnTypeName();
// 0 based
t.Add('substr', PREFIX+'substr(SRef1, 2,3, true)', weAnsiStr('cde', #1)).IgnTypeName();
t.Add('substr', PREFIX+'substr(Short0, 4,3, true)', weAnsiStr('ef1', #1)).IgnTypeName();
// cut off
t.Add('substr', PREFIX+'substr(SRef1, 10, 30)', weAnsiStr('456', #1)).IgnTypeName();
t.Add('substr', PREFIX+'substr(SHORT1[1], -4, 2, true)', weAnsiStr('23', #1)).IgnTypeName();
t.Add('substr', PREFIX+'PtrRef1, 2, 4, true)', weAnsiStr('cdef', #1)).IgnTypeName();
t.Add('substr', PREFIX+'PCRef1, 2, 4, true)', weAnsiStr('cdef', #1)).IgnTypeName();
AddWatches(t, 'glob var', 'gv', 001, 'B');
AddWatches(t, 'glob MyClass1', 'MyClass1.mc', 002, 'C');
t.EvaluateWatches;

14
components/lazdebuggers/lazdebugtestbase/testapps/WatchesValuePrg.pas
View File

@ -84,6 +84,10 @@ var
v_array: array [3..4] of variant;
SRef0, SRef1, SRef2, SRef3, SRef4: String;
PCRef1: PChar;
PtrRef1: Pointer;
Short0: Shortstring;
Short1: array [0..2] of ShortString[10];
ARef0, ARef1, ARef2, ARef3, ARef4: array of byte;
type
@ -1072,11 +1076,19 @@ begin
RecursePtrC18 := @RecursePtrC1;
SRef0 := '';
SRef1 := 'abc';
SRef1 := 'abcdef123456';
SRef1 := inttostr(random(9))+SRef1;
SRef2 := inttostr(random(9))+SRef1;
SRef3 := SRef2;
PCRef1 := @SRef1[1];
PtrRef1 := PCRef1;
Short0 := 'abcdef1234';
Short1[0] := 'abcdef1234';
Short1[1] := 'ABCDEF7890';
Short1[2] := 'mnopqrstuv';
ARef0 := nil;
SetLength(ARef1, 10);
SetLength(ARef2, 10);