fcl-css: started skipping errors and collect as warnings

packages/fcl-css/src/fpcssparser.pp

@@ -291,9 +291,11 @@ end;
 procedure TCSSParser.DoWarn(const Msg: TCSSString);
 begin
   if Assigned(Scanner.OnWarn) then
-    Scanner.OnWarn(Self,Msg)
-  else
-    DoError(Msg);
+    begin
+    if Scanner.OnWarn(Self,Msg,Scanner.CurRow,Scanner.CurColumn) then
+      exit;
+    end;
+  DoError(Msg);
 end;
 
 procedure TCSSParser.DoWarn(const Fmt: TCSSString; const Args: array of const);

packages/fcl-css/src/fpcssresolver.pas

@@ -222,6 +222,7 @@ type
   { TCSSSharedRuleList - elements with same CSS rules share the base attributes }
 
   TCSSSharedRuleList = class
+  public
     AllDecl: TCSSDeclarationElement;
     AllSpecificity: TCSSSpecificity;
     Rules: TCSSSharedRuleArray; // sorted ascending for Specificity, secondary for source position
@@ -257,7 +258,6 @@ type
     AllValue: TCSSNumericalID;
     Values: TCSSAttributeValueArray; // the resolver sorts them ascending for AttrID, shorthands are already replaced with longhands
     procedure SortValues; virtual; // ascending AttrID
-    procedure SwapValues(Index1, Index2: integer);
     function IndexOf(AttrID: TCSSNumericalID): integer;
     procedure SetComputedValue(AttrID: TCSSNumericalID; const aValue: TCSSString);
     destructor Destroy; override;
@@ -686,6 +686,7 @@ procedure TCSSAttributeValues.SortValues;
 var
   l: SizeInt;
   i, j: Integer;
+  aValue: TCSSAttributeValue;
 begin
   l:=length(Values);
   if l<6 then
@@ -693,7 +694,11 @@ begin
     for i:=0 to l-2 do
       for j:=i+1 to l-1 do
         if Values[i].AttrID>Values[j].AttrID then
-          SwapValues(i,j);
+        begin
+          aValue:=Values[i];
+          Values[i]:=Values[j];
+          Values[j]:=aValue;
+        end;
   end else begin
     //for i:=0 to l-1 do
     //  writeln('TCSSAttributeValues.SortValues ',i,' ',Values[i]<>nil);
@@ -704,29 +709,6 @@ begin
   end;
 end;
 
-procedure TCSSAttributeValues.SwapValues(Index1, Index2: integer);
-var
-  A, B: TCSSAttributeValue;
-  AttrId: TCSSNumericalID;
-  Value: TCSSString;
-  aState: TCSSAttributeValue.TState;
-begin
-  A:=Values[Index1];
-  B:=Values[Index2];
-
-  AttrId:=A.AttrID;
-  A.AttrID:=B.AttrID;
-  B.AttrID:=AttrID;
-
-  Value:=A.Value;
-  A.Value:=B.Value;
-  B.Value:=Value;
-
-  aState:=A.State;
-  A.State:=B.State;
-  B.State:=aState;
-end;
-
 function TCSSAttributeValues.IndexOf(AttrID: TCSSNumericalID): integer;
 var
   l, r, m: Integer;

packages/fcl-css/src/fpcssresparser.pas

@@ -1807,6 +1807,7 @@ begin
   aComp.Kind:=rvkNone;
 
   p:=aComp.EndP;
+  if p=nil then exit(false);
 
   // skip whitespace
   while (p^ in Whitespace) do inc(p);
@@ -2464,7 +2465,7 @@ begin
       if Pos('var(',AttrData.Value)>0 then
       begin
         // cannot be parsed yet
-      end else if AttrID<Resolver.CSSRegistry.AttributeCount then
+      end else if AttrId<Resolver.CSSRegistry.AttributeCount then
       begin
         if Resolver.InitParseAttr(Desc,AttrData,AttrData.Value) then
         begin

packages/fcl-css/src/fpcssscanner.pp

@@ -33,6 +33,7 @@ Type
   TCSSToken =  (
     ctkUNKNOWN,
     ctkEOF,
+    ctkINVALID,
     ctkWHITESPACE,
     ctkCOMMENT,
     ctkSEMICOLON,
@@ -129,7 +130,8 @@ Type
 
   TCSSScannerOption = (csoExtendedIdentifiers,csoReturnComments,csoReturnWhiteSpace,csoDisablePseudo);
   TCSSScannerOptions = set of TCSSScannerOption;
-  TCSSScannerWarnEvent = procedure(Sender: TObject; Msg: TCSSString) of object;
+  TCSSScannerWarnEvent = function(Sender: TObject; Msg: TCSSString; aRow, aCol: integer
+    ): boolean of object; // returns true to continue, false to raise an exception
 
   TCSSScanner = class
   private
@@ -184,7 +186,7 @@ Type
     property CurToken: TCSSToken read FCurToken;
     property CurTokenString: TCSSString read FCurTokenString;
     property DisablePseudo : Boolean Index csoDisablePseudo Read GetOption Write SetOption;
-    property OnWarn: TCSSScannerWarnEvent read FOnWarn write FOnWarn;
+    property OnWarn: TCSSScannerWarnEvent read FOnWarn write FOnWarn; // if not set raise ECSSScanner
   end;
 
 function SafeFormat(const Fmt: TCSSString; const Args: array of const): TCSSString;
@@ -520,25 +522,42 @@ begin
               begin
               S:=UTF8Encode(ReadUniCodeEscape);
               end;
-        #0  : DoError(SErrOpenString);
+        #0  :
+          begin
+          DoError(SErrOpenString);
+          exit(ctkINVALID);
+          end
       else
         DoError(SErrInvalidCharacter, [TokenStr[0]]);
+        S:='';
       end;
       SetLength(FCurTokenString, OLen + Len+1+Length(S));
       if Len > 0 then
+        begin
         Move(TokenStart^, FCurTokenString[OLen + 1], Len);
-      Move(S[1],FCurTokenString[OLen + Len+1],Length(S));
-      Inc(OLen, Len+Length(S));
+        Inc(OLen, Len);
+        end;
+      if S>'' then
+        begin
+        Move(S[1],FCurTokenString[OLen + 1],Length(S));
+        Inc(OLen, Length(S));
+        end;
       // Next char
       // Inc(TokenStr);
       TokenStart := TokenStr+1;
       end;
     if TokenStr[0] = #0 then
+      begin
       DoError(SErrOpenString);
+      exit(ctkINVALID);
+      end;
     Inc(TokenStr);
     end;
   if TokenStr[0] = #0 then
+    begin
     DoError(SErrOpenString);
+    exit(ctkINVALID);
+    end;
   Len := TokenStr - TokenStart;
   SetLength(FCurTokenString, OLen + Len);
   if Len > 0 then
@@ -791,12 +810,16 @@ begin
     end
   else if (CurTokenString='url(') then
     begin
-    Result:=ctkURL;
     If TokenStr[0] in ['"',''''] then
-      DoStringLiteral
+      begin
+      Result:=DoStringLiteral;
+      if Result<>ctkSTRING then
+        exit;
+      Result:=ctkURL;
+      end
     else
       begin
-      result:=EatBadURL;
+      Result:=EatBadURL;
       end;
     If (result<>ctkEOF) and (TokenStr[0] in [')']) then
       Inc(TokenStr);
@@ -898,7 +921,7 @@ begin
     '/' :
       Result:=CommentDiv;
     #9, ' ':
-      Result := DoWhiteSpace;
+      Result:=DoWhiteSpace;
     '#':
       Result:=DoHash;
     '\':
@@ -1025,6 +1048,11 @@ Var
   S : TCSSString;
 
 begin
+  if Assigned(OnWarn) then
+    begin
+    if OnWarn(Self,Msg,CurRow,CurColumn) then
+      exit;
+    end;
   S:=Format('Error at (%d,%d): ',[CurRow,CurColumn])+Msg;
   Raise ECSSScanner.Create(S);
 end;

packages/fcl-css/tests/tccssparser.pp

@@ -35,7 +35,7 @@ type
     FToFree: TCSSElement;
     procedure Clear;
     function GetRule: TCSSRuleElement;
-    procedure OnScannerWarn(Sender: TObject; Msg: string);
+    function OnScannerWarn(Sender: TObject; Msg: string; aRow, aCol: integer): boolean;
   protected
     procedure SetUp; override;
     procedure TearDown; override;
@@ -840,12 +840,14 @@ begin
     Result:=TCSSRuleElement(CheckClass('First element is rule',TCSSRuleElement,L.Children[0]));
 end;
 
-procedure TTestBaseCSSParser.OnScannerWarn(Sender: TObject; Msg: string);
+function TTestBaseCSSParser.OnScannerWarn(Sender: TObject; Msg: string; aRow, aCol: integer
+  ): boolean;
 var
   aScanner: TCSSScanner;
 begin
+  Result:=false;
   aScanner:=FParser.Scanner;
-  writeln('TTestBaseCSSParser.OnScannerWarn ',aScanner.CurFilename+'('+IntToStr(aScanner.CurRow)+','+IntToStr(aScanner.CurColumn)+') ',Msg);
+  writeln('TTestBaseCSSParser.OnScannerWarn ',aScanner.CurFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+') ',Msg);
 end;
 
 procedure TTestBaseCSSParser.SetUp;

packages/fcl-css/tests/tccssscanner.pp

@@ -20,9 +20,12 @@ unit tcCSSScanner;
 interface
 
 uses
-  TypInfo, Classes, SysUtils, fpcunit, testregistry, fpcssscanner;
+  TypInfo, Classes, SysUtils, fpcunit, testregistry, fpcssscanner, fpCSSTree;
 
 type
+
+  { TTestLineReader }
+
   TTestLineReader = Class(TTestCase)
   Private
     FData: TStringStream;
@@ -42,28 +45,39 @@ type
     procedure TestReadEmptyLines101010;
   end;
 
+  TTestCSSWarning = record
+    Msg: string;
+    Row, Col: integer;
+  end;
+
   { TTestCSSScanner }
 
   TTestCSSScanner = class(TTestCase)
   Private
+    FCollectWarnings: boolean;
     FPSeudoDisabled,
     FNeedWhiteSpace : Boolean;
     FStream : TStream;
     FLineReader : TLineReader;
     FScanner : TCSSScanner;
     FErrorSource : String;
+    FWarnings: array of TTestCSSWarning;
     procedure AssertEquals(AMessage: String; AExpected, AActual : TCSSToken); overload;
     procedure CheckToken(AToken: TCSSToken; ASource: String);
     procedure CheckTokens(ASource: String; ATokens: array of TCSSToken);
+    procedure CheckWarning(Msg: string; Row, Col: integer);
     procedure DoTestFloat(F: Double);
     procedure DoTestFloat(F: Double; S: String);
     procedure DoTestString(S: String);
+    function OnScannerWarn(Sender: TObject; Msg: TCSSString; aRow, aCol: integer): boolean;
+    procedure SetCollectWarnings(const AValue: boolean);
   protected
     Function CreateScanner(AInput : String) : TCSSScanner;
     procedure FreeScanner;
     procedure SetUp; override;
     procedure TearDown; override;
-    Property Scanner : TCSSScanner Read FScanner;
+    property Scanner : TCSSScanner Read FScanner;
+    property CollectWarnings: boolean read FCollectWarnings write SetCollectWarnings;
   published
     procedure TestEmpty;
     Procedure TestEOF;
@@ -95,6 +109,7 @@ type
     Procedure TestLBRACKET;
     Procedure TestRBRACKET;
     Procedure TestSTR;
+    Procedure TestSTRExceedsLine;
     Procedure TestStrEscapeUnicode;
     procedure TestStrEscapeUnicode2;
     Procedure TestCOMMA;
@@ -143,6 +158,7 @@ begin
   Result:=FScanner;
   if FNeedWhiteSpace then
     FScanner.ReturnWhiteSpace:=True;
+  FScanner.OnWarn:=@OnScannerWarn;
 end;
 
 procedure TTestCSSScanner.FreeScanner;
@@ -155,12 +171,14 @@ end;
 procedure TTestCSSScanner.SetUp;
 begin
   inherited SetUp;
+  CollectWarnings:=false;
   FNeedWhiteSpace:=False;
   FPSeudoDisabled:=False;
 end;
 
 procedure TTestCSSScanner.TearDown;
 begin
+  FWarnings:=[];
   FreeScanner;
   Inherited;
 end;
@@ -224,6 +242,27 @@ begin
   end;
 end;
 
+function TTestCSSScanner.OnScannerWarn(Sender: TObject; Msg: TCSSString; aRow, aCol: integer
+  ): boolean;
+var
+  Item: TTestCSSWarning;
+begin
+  if not CollectWarnings then
+    exit(false); // raise exception
+  Result:=true;
+  Item.Msg:=Msg;
+  Item.Row:=aRow;
+  Item.Col:=aCol;
+  Insert(Item,FWarnings,length(FWarnings));
+end;
+
+procedure TTestCSSScanner.SetCollectWarnings(const AValue: boolean);
+begin
+  if FCollectWarnings=AValue then Exit;
+  FCollectWarnings:=AValue;
+  FWarnings:=[];
+end;
+
 procedure TTestCSSScanner.TestEmpty;
 
 Var
@@ -354,18 +393,24 @@ begin
   CheckToken(ctkSTRING,'"abc"');
 end;
 
+procedure TTestCSSScanner.TestSTRExceedsLine;
+begin
+  CollectWarnings:=true;
+  CheckToken(ctkINVALID,'"bla');
+  CheckWarning('String exceeds end of line',1,4);
+end;
+
 procedure TTestCSSScanner.TestStrEscapeUnicode;
 begin
- CheckToken(ctkSTRING,'"\00a0\00a0\00a0\00a0"');
- CheckToken(ctkSTRING,'"\2a"');
+  CheckToken(ctkSTRING,'"\00a0\00a0\00a0\00a0"');
+  CheckToken(ctkSTRING,'"\2a"');
 end;
 
 procedure TTestCSSScanner.TestStrEscapeUnicode2;
 begin
- CheckToken(ctkSTRING,'"\2a"');
+  CheckToken(ctkSTRING,'"\2a"');
 end;
 
-
 procedure TTestCSSScanner.TestCOMMA;
 begin
   CheckToken(ctkCOMMA,',');
@@ -633,6 +678,16 @@ begin
     end;
 end;
 
+procedure TTestCSSScanner.CheckWarning(Msg: string; Row, Col: integer);
+var
+  Actual, Expected: String;
+begin
+  AssertEquals('Expected one warning',1,length(FWarnings));
+  Actual:='('+IntToStr(FWarnings[0].Row)+','+IntToStr(FWarnings[0].Col)+'): '+FWarnings[0].Msg;
+  Expected:='('+IntToStr(Row)+','+IntToStr(Col)+'): '+Msg;
+  AssertEquals('Expected Warning',Expected,Actual);
+end;
+
 
 
 { TTestLineReader }