From a34187ffdc81694673e38aee53c7d1d1907db2ee Mon Sep 17 00:00:00 2001
From: michael <michael@freepascal.org>
Date: Sun, 23 Aug 2020 10:36:22 +0000
Subject: [PATCH] * Merging revisions r45415 from trunk:
------------------------------------------------------------------------
r45415 | michael | 2020-05-18 10:28:14 +0200 (Mon, 18 May 2020) | 1 line
* Add OnComment
------------------------------------------------------------------------
git-svn-id: branches/fixes_3_2@46646 -
---
packages/fcl-passrc/src/pscanner.pp | 26 +++++++++++++++++++------
packages/fcl-passrc/tests/tcscanner.pas | 20 +++++++++++++++++++
2 files changed, 40 insertions(+), 6 deletions(-)
diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp
index c5a76477d0..38eec9e7be 100644
--- a/packages/fcl-passrc/src/pscanner.pp
+++ b/packages/fcl-passrc/src/pscanner.pp
@@ -684,8 +684,8 @@ type
TPScannerLogHandler = Procedure (Sender : TObject; Const Msg : String) of object;
TPScannerLogEvent = (sleFile,sleLineNumber,sleConditionals,sleDirective);
TPScannerLogEvents = Set of TPScannerLogEvent;
- TPScannerDirectiveEvent = procedure(Sender: TObject; Directive, Param: String;
- var Handled: boolean) of object;
+ TPScannerDirectiveEvent = procedure(Sender: TObject; Directive, Param: String; var Handled: boolean) of object;
+ TPScannerCommentEvent = procedure(Sender: TObject; aComment : String) of object;
TPScannerFormatPathEvent = function(const aPath: string): string of object;
TPScannerWarnEvent = procedure(Sender: TObject; Identifier: string; State: TWarnMsgState; var Handled: boolean) of object;
TPScannerModeDirective = procedure(Sender: TObject; NewMode: TModeSwitch; Before: boolean; var Handled: boolean) of object;
@@ -734,6 +734,7 @@ type
FMacros: TStrings; // Objects are TMacroDef
FDefines: TStrings;
FNonTokens: TTokens;
+ FOnComment: TPScannerCommentEvent;
FOnDirective: TPScannerDirectiveEvent;
FOnEvalFunction: TCEEvalFunctionEvent;
FOnEvalVariable: TCEEvalVarEvent;
@@ -799,6 +800,7 @@ type
function HandleDirective(const ADirectiveText: String): TToken; virtual;
function HandleLetterDirective(Letter: char; Enable: boolean): TToken; virtual;
procedure HandleBoolDirective(bs: TBoolSwitch; const Param: String); virtual;
+ procedure DoHandleComment(Sender: TObject; const aComment : string); virtual;
procedure DoHandleDirective(Sender: TObject; Directive, Param: String;
var Handled: boolean); virtual;
procedure HandleIFDEF(const AParam: String);
@@ -882,7 +884,6 @@ type
property Defines: TStrings read FDefines;
property Macros: TStrings read FMacros;
property MacrosOn: boolean read GetMacrosOn write SetMacrosOn;
- property OnDirective: TPScannerDirectiveEvent read FOnDirective write FOnDirective;
property AllowedModeSwitches: TModeSwitches read FAllowedModeSwitches Write SetAllowedModeSwitches;
property ReadOnlyModeSwitches: TModeSwitches read FReadOnlyModeSwitches Write SetReadOnlyModeSwitches;// always set, cannot be disabled
property CurrentModeSwitches: TModeSwitches read FCurrentModeSwitches Write SetCurrentModeSwitches;
@@ -908,6 +909,9 @@ type
property OnEvalFunction: TCEEvalFunctionEvent read FOnEvalFunction write FOnEvalFunction;
property OnWarnDirective: TPScannerWarnEvent read FOnWarnDirective write FOnWarnDirective;
property OnModeChanged: TPScannerModeDirective read FOnModeChanged write FOnModeChanged; // set by TPasParser
+ property OnDirective: TPScannerDirectiveEvent read FOnDirective write FOnDirective;
+ property OnComment: TPScannerCommentEvent read FOnComment write FOnComment;
+
property LastMsg: string read FLastMsg write FLastMsg;
property LastMsgNumber: integer read FLastMsgNumber write FLastMsgNumber;
@@ -4096,11 +4100,17 @@ begin
CurrentBoolSwitches:=CurrentBoolSwitches-[bs];
end;
+procedure TPascalScanner.DoHandleComment(Sender: TObject; const aComment: string);
+begin
+ if Assigned(OnComment) then
+ OnComment(Sender,aComment);
+end;
+
procedure TPascalScanner.DoHandleDirective(Sender: TObject; Directive,
Param: String; var Handled: boolean);
begin
if Assigned(OnDirective) then
- OnDirective(Self,Directive,Param,Handled);
+ OnDirective(Sender,Directive,Param,Handled);
end;
function TPascalScanner.DoFetchToken: TToken;
@@ -4301,7 +4311,9 @@ begin
Inc(FTokenPos, 2);
Result := tkComment;
if Copy(CurTokenString,1,1)='$' then
- Result := HandleDirective(CurTokenString);
+ Result := HandleDirective(CurTokenString)
+ else
+ DoHandleComment(Self,CurTokenString);
end;
end;
')':
@@ -4602,7 +4614,9 @@ begin
Inc(FTokenPos);
Result := tkComment;
if (Copy(CurTokenString,1,1)='$') then
- Result:=HandleDirective(CurTokenString);
+ Result:=HandleDirective(CurTokenString)
+ else
+ DoHandleComment(Self, CurTokenString)
end;
'A'..'Z', 'a'..'z', '_':
begin
diff --git a/packages/fcl-passrc/tests/tcscanner.pas b/packages/fcl-passrc/tests/tcscanner.pas
index e3fd8eb297..4a50306f65 100644
--- a/packages/fcl-passrc/tests/tcscanner.pas
+++ b/packages/fcl-passrc/tests/tcscanner.pas
@@ -55,7 +55,10 @@ type
FLI: String;
FScanner : TPascalScanner;
FResolver : TStreamResolver;
+ FDoCommentCalled : Boolean;
+ FComment: string;
protected
+ procedure DoComment(Sender: TObject; aComment: String);
procedure SetUp; override;
procedure TearDown; override;
Function TokenToString(tk : TToken) : string;
@@ -82,6 +85,7 @@ type
procedure TestNestedComment3;
procedure TestNestedComment4;
procedure TestNestedComment5;
+ procedure TestonComment;
procedure TestIdentifier;
procedure TestSelf;
procedure TestSelfNoToken;
@@ -369,8 +373,15 @@ end;
TTestScanner
---------------------------------------------------------------------}
+procedure TTestScanner.DoComment(Sender: TObject; aComment: String);
+begin
+ FDoCommentCalled:=True;
+ FComment:=aComment;
+end;
+
procedure TTestScanner.SetUp;
begin
+ FDoCommentCalled:=False;
FResolver:=TStreamResolver.Create;
FResolver.OwnsStreams:=True;
FScanner:=TTestingPascalScanner.Create(FResolver);
@@ -571,6 +582,15 @@ begin
TestToken(tkComment,'(* (* comment *) *)');
end;
+procedure TTestScanner.TestonComment;
+begin
+ FScanner.OnComment:=@DoComment;
+ DoTestToken(tkComment,'(* abc *)',False);
+ assertTrue('Comment called',FDoCommentCalled);
+ AssertEquals('Correct comment',' abc ',Scanner.CurTokenString);
+ AssertEquals('Correct comment token',' abc ',FComment);
+end;
+
procedure TTestScanner.TestIdentifier;