improved some lfm error handling

git-svn-id: trunk@7679 -

components/codetools/lfmtrees.pas

@@ -137,6 +137,7 @@ type
   { TLFMValueNodeSymbol - a LFM value of type symbol }
   
   TLFMSymbolType = (
+    lfmsNone,
     lfmsTrue,
     lfmsFalse,
     lfmsNil,
@@ -201,7 +202,8 @@ type
     lfmeObjectIncompatible,
     lfmePropertyNameMissing,
     lfmePropertyHasNoSubProperties,
-    lfmeIdentifierNotPublished
+    lfmeIdentifierNotPublished,
+    lfmeEndNotFound
     );
   TLFMErrorTypes = set of TLFMErrorType;
 
@@ -273,7 +275,8 @@ const
     'ObjectIncompatible',
     'PropertyNameMissing',
     'PropertyHasNoSubProperties',
-    'IdentifierNotPublished'
+    'IdentifierNotPublished',
+    'EndNotFound'
     );
     
 procedure FreeListOfPInstancePropInfo(List: TFPList);
@@ -442,7 +445,9 @@ begin
       SymbolNode:=TLFMValueNodeSymbol(CurNode);
       if SymbolNode=nil then ;
       s := Parser.TokenString;
-      if CompareText(s, 'True') = 0 then
+      if CompareText(s, 'End') = 0 then
+        SymbolNode.SymbolType:=lfmsNone
+      else if CompareText(s, 'True') = 0 then
         SymbolNode.SymbolType:=lfmsTrue
       else if CompareText(s, 'False') = 0 then
         SymbolNode.SymbolType:=lfmsFalse
@@ -453,7 +458,8 @@ begin
         SymbolNode.SymbolType:=lfmsIdentifier;
         Parser.TokenComponentIdent;
       end;
-      Parser.NextToken;
+      if SymbolNode.SymbolType<>lfmsNone then
+        Parser.NextToken;
       CloseChildNode;
     end;
     
@@ -553,6 +559,7 @@ end;
 procedure TLFMTree.ProcessObject;
 var
   ObjectNode: TLFMObjectNode;
+  ObjectStartLine: LongInt;
 begin
   CreateChildNode(TLFMObjectNode);
   ObjectNode:=TLFMObjectNode(CurNode);
@@ -565,6 +572,7 @@ begin
   end;
   Parser.NextToken;
   Parser.CheckToken(toSymbol);
+  ObjectStartLine:=Parser.SourceLine;
   ObjectNode.Name := '';
   ObjectNode.TypeName := Parser.TokenString;
   ObjectNode.TypeNamePosition:=Parser.SourcePos+1;
@@ -586,7 +594,14 @@ begin
     ProcessProperty;
 
   // read child objects
-  while not Parser.TokenSymbolIs('END') do ProcessObject;
+  while not Parser.TokenSymbolIs('END') do begin
+    if Parser.Token=toEOF then begin
+      Parser.Error('END not found for'
+        +' object='+ObjectNode.Name+':'+ObjectNode.TypeName
+        +' starting at line '+IntToStr(ObjectStartLine));
+    end;
+    ProcessObject;
+  end;
   Parser.NextToken; // Skip 'END' token
   
   CloseChildNode;

designer/jitforms.pp

@@ -80,6 +80,7 @@ type
     FComponentPrefix: string;
     FCurUnknownClass: string;
     FCurUnknownProperty: string;
+    FErrors: TLRPositionLinks;
     FOnPropertyNotFound: TJITPropertyNotFoundEvent;
     procedure SetComponentPrefix(const AValue: string);
   protected
@@ -164,8 +165,8 @@ type
                                        read FOnReaderError write FOnReaderError;
     property OnPropertyNotFound: TJITPropertyNotFoundEvent
                              read FOnPropertyNotFound write FOnPropertyNotFound;
-    property CurReadJITComponent:TComponent read FCurReadJITComponent;
+    property CurReadJITComponent: TComponent read FCurReadJITComponent;
-    property CurReadClass:TClass read FCurReadClass;
+    property CurReadClass: TClass read FCurReadClass;
     property CurReadChild: TComponent read FCurReadChild;
     property CurReadChildClass: TComponentClass read FCurReadChildClass;
     property CurReadErrorMsg: string read FCurReadErrorMsg;
@@ -173,6 +174,7 @@ type
     property CurUnknownClass: string read FCurUnknownClass;
     property ComponentPrefix: string read FComponentPrefix
                                      write SetComponentPrefix;
+    property Errors: TLRPositionLinks read FErrors;
   end;
 
 
@@ -501,12 +503,14 @@ begin
   inherited Create;
   FComponentPrefix:='Form';
   FJITComponents:=TList.Create;
+  FErrors:=TLRPositionLinks.Create;
 end;
 
 destructor TJITComponentList.Destroy;
 begin
   while FJITComponents.Count>0 do DestroyJITComponent(FJITComponents.Count-1);
   FJITComponents.Free;
+  FErrors.Free;
   inherited Destroy;
 end;
 
@@ -548,7 +552,13 @@ var
   OldClass: TClass;
 begin
   OldClass:=Items[Index].ClassType;
-  Items[Index].Free;
+  try
+    Items[Index].Free;
+  except
+    on E: Exception do begin
+      DebugLn('[TJITComponentList.DestroyJITComponent] ERROR destroying component ',E.Message);
+    end;
+  end;
   FreeJITClass(OldClass);
   FJITComponents.Delete(Index);
 end;
@@ -558,7 +568,7 @@ function TJITComponentList.FindComponentByClassName(
 begin
   Result:=FJITComponents.Count-1;
   while (Result>=0)
-  and (AnsiCompareText(Items[Result].ClassName,AClassName)<>0) do
+  and (CompareText(Items[Result].ClassName,AClassName)<>0) do
     dec(Result);
 end;
 
@@ -566,7 +576,7 @@ function TJITComponentList.FindComponentByName(const AName:shortstring):integer;
 begin
   Result:=FJITComponents.Count-1;
   while (Result>=0)
-  and (AnsiCompareText(Items[Result].Name,AName)<>0) do
+  and (CompareText(Items[Result].Name,AName)<>0) do
     dec(Result);
 end;
 
@@ -680,17 +690,11 @@ begin
     on E: Exception do begin
       DebugLn('[TJITComponentList.AddJITChildComponentFromStream] ERROR reading form stream'
          +' of Class ''',NewClassName,''' Error: ',E.Message);
-      Result:=-1;
+      if Result>=0 then begin
-      if FCurReadJITComponent<>nil then begin
         // try freeing the unfinished thing
-        try
-          FCurReadJITComponent.Free;
-        except
-          on E: Exception do begin
-            DebugLn('[TJITComponentList.AddJITChildComponentFromStream] ERROR destroying component ',E.Message);
-          end;
-        end;
         FCurReadJITComponent:=nil;
+        DestroyJITComponent(Result);
+        Result:=-1;
       end;
     end;
   end;
@@ -1299,6 +1303,7 @@ const
 var
   ErrorType: TJITFormError;
   Action: TModalResult;
+  ErrorBinPos: Int64;
 begin
   ErrorType:=jfeReaderError;
   Action:=mrCancel;
@@ -1309,10 +1314,16 @@ begin
     ErrorType:=jfeUnknownProperty;
     Action:=mrIgnore;
   end;
+  if Reader.Driver is TLRSObjectReader then begin
+    // save error position
+    ErrorBinPos:=TLRSObjectReader(Reader.Driver).Stream.Position;
+    FErrors.Add(-1,ErrorBinPos,nil);
+  end;
   if Assigned(OnReaderError) then
     OnReaderError(Self,ErrorType,Action);
   Handled:=Action in [mrIgnore];
   FCurUnknownProperty:='';
+  
   DebugLn('>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>');
   DebugLn('[TJITComponentList.ReaderError] "'+ErrorMsg+'" ignoring=',BoolToStr(Handled));
   DebugLn('<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<');

lcl/lresources.pp

@@ -117,6 +117,8 @@ type
     function ReadWideString: WideString;override;
     procedure SkipComponent(SkipComponentInfos: Boolean); override;
     procedure SkipValue; override;
+  public
+    property Stream: TStream read FStream;
   end;
   TLRSObjectReaderClass = class of TLRSObjectReader;
   
@@ -172,6 +174,43 @@ type
   end;
   TLRSObjectWriterClass = class of TLRSObjectWriter;
   
+  TLRPositionLink = record
+    LFMPosition: int64;
+    LRSPosition: int64;
+    Data: Pointer;
+  end;
+  PLRPositionLink = ^TLRPositionLink;
+  
+  { TLRPositionLinks }
+
+  TLRPositionLinks = class
+  private
+    FItems: TFPList;
+    FCount: integer;
+    function GetData(Index: integer): Pointer;
+    function GetLFM(Index: integer): Int64;
+    function GetLRS(Index: integer): Int64;
+    procedure SetCount(const AValue: integer);
+    procedure SetData(Index: integer; const AValue: Pointer);
+    procedure SetLFM(Index: integer; const AValue: Int64);
+    procedure SetLRS(Index: integer; const AValue: Int64);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure Sort(LFMPositions: Boolean);
+    function IndexOf(const Position: int64; LFMPositions: Boolean): integer;
+    function IndexOfRange(const FromPos, ToPos: int64;
+                          LFMPositions: Boolean): integer;
+    procedure SetPosition(const FromPos, ToPos, MappedPos: int64;
+                          LFMtoLRSPositions: Boolean);
+    procedure Add(const LFMPos, LRSPos: Int64; Data: Pointer);
+  public
+    property LFM[Index: integer]: int64 read GetLFM write SetLFM;
+    property LRS[Index: integer]: int64 read GetLRS write SetLRS;
+    property Data[Index: integer]: Pointer read GetData write SetData;
+    property Count: integer read FCount write SetCount;
+  end;
+  
 var
   LazarusResources: TLResourceList;
 
@@ -185,10 +224,8 @@ function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;
 
 procedure BinaryToLazarusResourceCode(BinStream, ResStream: TStream;
   const ResourceName, ResourceType: String);
-function LFMtoLRSfile(const LFMfilename: string): boolean;
+function LFMtoLRSfile(const LFMfilename: string): boolean;// true on success
- // returns true if successful
+function LFMtoLRSstream(LFMStream, LRSStream: TStream): boolean;// true on success
-function LFMtoLRSstream(LFMStream, LRSStream: TStream): boolean;
- // returns true if successful
 function FindLFMClassName(LFMStream: TStream):AnsiString;
 function CreateLFMFile(AComponent: TComponent; LFMStream: TStream): integer;
 
@@ -196,7 +233,8 @@ type
   TLRSStreamOriginalFormat = (sofUnknown, sofBinary, sofText);
   
 procedure LRSObjectBinaryToText(Input, Output: TStream);
-procedure LRSObjectTextToBinary(Input, Output: TStream);
+procedure LRSObjectTextToBinary(Input, Output: TStream;
+                                Links: TLRPositionLinks = nil);
 procedure LRSObjectToText(Input, Output: TStream;
   var OriginalFormat: TLRSStreamOriginalFormat);
 
@@ -245,6 +283,10 @@ procedure WriteLRSEndianBigDoubleAsEndianLittleExtended(s: TStream;
 procedure WriteLRSReversedWords(s: TStream; p: Pointer; Count: integer);
 
 
+function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer;
+function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer;
+
+
 implementation
 
 
@@ -1568,7 +1610,8 @@ begin
   end;
 end;
 
-procedure LRSObjectTextToBinary(Input, Output: TStream);
+procedure LRSObjectTextToBinary(Input, Output: TStream;
+  Links: TLRPositionLinks);
 var
   parser: TParser;
   OldDecimalSeparator: Char;
@@ -1657,6 +1700,16 @@ var
     for i:=1 to length(Result) do
       Result[i]:=chr(ord(s[i]));
   end;
+  
+  procedure ParserNextToken;
+  var
+    OldSourcePos: LongInt;
+  begin
+    OldSourcePos:=Parser.SourcePos;
+    Parser.NextToken;
+    if Links<>nil then
+      Links.SetPosition(OldSourcePos,Parser.SourcePos,Output.Position,true);
+  end;
 
   procedure ProcessProperty; forward;
 
@@ -1860,6 +1913,10 @@ var
   end;
 
 begin
+  if Links<>nil then begin
+    // sort links for LFM positions
+    Links.Sort(true);
+  end;
   parser := TParser.Create(Input);
   OldDecimalSeparator:=DecimalSeparator;
   DecimalSeparator:='.';
@@ -1971,7 +2028,7 @@ begin
   Result:=TReader.Create(s,4096);
   {$IFDEF TRANSLATESTRING}
   if Assigned(LRSTranslator) then
-   Result.OnReadStringProperty:=@(LRSTranslator.TranslateStringProperty);
+    Result.OnReadStringProperty:=@(LRSTranslator.TranslateStringProperty);
   {$ENDIF}
   DestroyDriver:=false;
   if Result.Driver.ClassType=LRSObjectReaderClass then exit;
@@ -2256,6 +2313,36 @@ begin
   end;
 end;
 
+function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer;
+var
+  p1: Int64;
+  p2: Int64;
+begin
+  p1:=PLRPositionLink(Item1)^.LFMPosition;
+  p2:=PLRPositionLink(Item2)^.LFMPosition;
+  if p1<p2 then
+    Result:=1
+  else if p1>p2 then
+    Result:=-1
+  else
+    Result:=0;
+end;
+
+function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer;
+var
+  p1: Int64;
+  p2: Int64;
+begin
+  p1:=PLRPositionLink(Item1)^.LRSPosition;
+  p2:=PLRPositionLink(Item2)^.LRSPosition;
+  if p1<p2 then
+    Result:=1
+  else if p1>p2 then
+    Result:=-1
+  else
+    Result:=0;
+end;
+
 procedure WriteLRSNull(s: TStream; Count: integer);
 var
   c: char;
@@ -3133,6 +3220,167 @@ begin
   LazarusResources:=TLResourceList.Create;
 end;
 
+{ TLRPositionLinks }
+
+function TLRPositionLinks.GetLFM(Index: integer): Int64;
+begin
+  Result:=PLRPositionLink(FItems[Index])^.LFMPosition;
+end;
+
+function TLRPositionLinks.GetData(Index: integer): Pointer;
+begin
+  Result:=PLRPositionLink(FItems[Index])^.Data;
+end;
+
+function TLRPositionLinks.GetLRS(Index: integer): Int64;
+begin
+  Result:=PLRPositionLink(FItems[Index])^.LRSPosition;
+end;
+
+procedure TLRPositionLinks.SetCount(const AValue: integer);
+var
+  i: LongInt;
+  Item: PLRPositionLink;
+begin
+  if FCount=AValue then exit;
+  // free old items
+  for i:=AValue to FCount-1 do begin
+    Item:=PLRPositionLink(FItems[i]);
+    Dispose(Item);
+  end;
+  // create new items
+  FItems.Count:=AValue;
+  for i:=FCount to AValue-1 do begin
+    New(Item);
+    Item^.LFMPosition:=-1;
+    Item^.LRSPosition:=-1;
+    Item^.Data:=nil;
+    FItems[i]:=Item;
+  end;
+  FCount:=AValue;
+end;
+
+procedure TLRPositionLinks.SetData(Index: integer; const AValue: Pointer);
+begin
+  PLRPositionLink(FItems[Index])^.Data:=AValue;
+end;
+
+procedure TLRPositionLinks.SetLFM(Index: integer; const AValue: Int64);
+begin
+  PLRPositionLink(FItems[Index])^.LFMPosition:=AValue;
+end;
+
+procedure TLRPositionLinks.SetLRS(Index: integer; const AValue: Int64);
+begin
+  PLRPositionLink(FItems[Index])^.LRSPosition:=AValue;
+end;
+
+constructor TLRPositionLinks.Create;
+begin
+  FItems:=TFPList.Create;
+end;
+
+destructor TLRPositionLinks.Destroy;
+begin
+  Count:=0;
+  FItems.Free;
+  inherited Destroy;
+end;
+
+procedure TLRPositionLinks.Sort(LFMPositions: Boolean);
+begin
+  if LFMPositions then
+    FItems.Sort(@CompareLRPositionLinkWithLFMPosition)
+  else
+    FItems.Sort(@CompareLRPositionLinkWithLRSPosition)
+end;
+
+function TLRPositionLinks.IndexOf(const Position: int64; LFMPositions: Boolean
+  ): integer;
+var
+  l, r, m: integer;
+  p: Int64;
+begin
+  // binary search for the line
+  l:=0;
+  r:=FCount-1;
+  while r>=l do begin
+    m:=(l+r) shr 1;
+    if LFMPositions then
+      p:=PLRPositionLink(FItems[m])^.LFMPosition
+    else
+      p:=PLRPositionLink(FItems[m])^.LRSPosition;
+    if p>Position then begin
+      // too high, search lower
+      r:=m-1;
+    end else if p<Position then begin
+      // too low, search higher
+      l:=m+1;
+    end else begin
+      // position found
+      Result:=m;
+      exit;
+    end;
+  end;
+  Result:=-1;
+end;
+
+function TLRPositionLinks.IndexOfRange(const FromPos, ToPos: int64;
+  LFMPositions: Boolean): integer;
+var
+  l, r, m: integer;
+  p: Int64;
+  Item: PLRPositionLink;
+begin
+  // binary search for the line
+  l:=0;
+  r:=FCount-1;
+  while r>=l do begin
+    m:=(l+r) shr 1;
+    Item:=PLRPositionLink(FItems[m]);
+    if LFMPositions then
+      p:=Item^.LFMPosition
+    else
+      p:=Item^.LRSPosition;
+    if p>=ToPos then begin
+      // too high, search lower
+      r:=m-1;
+    end else if p<FromPos then begin
+      // too low, search higher
+      l:=m+1;
+    end else begin
+      // position found
+      Result:=m;
+      exit;
+    end;
+  end;
+  Result:=-1;
+end;
+
+procedure TLRPositionLinks.SetPosition(const FromPos, ToPos, MappedPos: int64;
+  LFMtoLRSPositions: Boolean);
+var
+  i: LongInt;
+begin
+  i:=IndexOfRange(FromPos,ToPos,LFMtoLRSPositions);
+  if i>=0 then
+    if LFMtoLRSPositions then
+      PLRPositionLink(FItems[i])^.LRSPosition:=MappedPos
+    else
+      PLRPositionLink(FItems[i])^.LFMPosition:=MappedPos;
+end;
+
+procedure TLRPositionLinks.Add(const LFMPos, LRSPos: Int64; Data: Pointer);
+var
+  Item: PLRPositionLink;
+begin
+  Count:=Count+1;
+  Item:=PLRPositionLink(FItems[Count-1]);
+  Item^.LFMPosition:=LFMPos;
+  Item^.LRSPosition:=LRSPos;
+  Item^.Data:=Data;
+end;
+
 initialization
   InternalInit;