~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to lcl/lresources.pp

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
40
40
  FPCAdds, TypInfo, DynQueue, LCLProc, LCLStrConsts, LazConfigStorage;
41
41
 
42
42
{$DEFINE UseLRS}
43
 
{$ifndef ver2_2}
44
43
{$DEFINE UseRES}
45
 
{$endif}
46
44
 
47
45
const
48
46
  LRSComment =  // do not translate this!
112
110
 
113
111
 
114
112
var LRSTranslator: TAbstractTranslator;
 
113
 
115
114
type
 
115
  TLRSItemType = (
 
116
    lrsitCollection,
 
117
    lrsitComponent,
 
118
    lrsitList,
 
119
    lrsitProperty
 
120
  );
 
121
 
 
122
  TLRSORStackItem = record
 
123
    Name: string;
 
124
    ItemType: TLRSItemType;
 
125
    Root: TComponent;
 
126
    PushCount: integer; // waiting for this number of Pop
 
127
    ItemNr: integer; // nr in a collection or list
 
128
  end;
 
129
  PLRSORStackItem = ^TLRSORStackItem;
 
130
 
116
131
  { TLRSObjectReader }
117
132
 
118
133
  TLRSObjectReader = class(TAbstractObjectReader)
122
137
    FBufSize: Integer;
123
138
    FBufPos: Integer;
124
139
    FBufEnd: Integer;
 
140
    FStack: PLRSORStackItem;
 
141
    FStackPointer: integer;
 
142
    FStackCapacity: integer;
 
143
    FReader: TReader;
125
144
    procedure SkipProperty;
126
145
    procedure SkipSetBody;
 
146
    procedure Push(ItemType: TLRSItemType; const AName: string = '';
 
147
                   Root: TComponent = nil; PushCount: integer = 1);
 
148
    procedure Pop;
 
149
    procedure ClearStack;
 
150
    function InternalReadValue: TValueType;
 
151
    procedure EndPropertyIfOpen;
127
152
  protected
128
153
    function ReadIntegerContent: integer;
129
154
  public
136
161
    procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
137
162
      var CompClassName, CompName: String); override;
138
163
    function BeginProperty: String; override;
 
164
    function GetStackPath: string;
139
165
 
140
166
    procedure Read(var Buf; Count: LongInt); override;
141
167
    procedure ReadBinary(const DestData: TMemoryStream); override;
152
178
    function ReadStr: String; override;
153
179
    function ReadString(StringType: TValueType): String; override;
154
180
    function ReadWideString: WideString; override;
155
 
    {$ifndef VER2_2}
156
181
    function ReadUnicodeString: UnicodeString; override;
157
 
    {$endif}
158
182
    procedure SkipComponent(SkipComponentInfos: Boolean); override;
159
183
    procedure SkipValue; override;
160
184
  public
161
185
    property Stream: TStream read FStream;
 
186
    property Reader: TReader read FReader write FReader;
162
187
  end;
163
188
  TLRSObjectReaderClass = class of TLRSObjectReader;
164
189
 
176
201
      WriteEmptyInheritedChilds = false (default).
177
202
 
178
203
    Reason:
179
 
      This allows to delete/rename controls in ancestors without the need
 
204
      This allows one to delete/rename controls in ancestors without the need
180
205
      to update all descendants.
181
206
  }
182
207
 
188
213
 
189
214
  TLRSOWStackItem = record
190
215
    Name: string;
191
 
    Instance: TPersistent;
 
216
    ItemType: TLRSItemType;
 
217
    Root: TComponent;
192
218
    PushCount: integer; // waiting for this number of Pop
 
219
    ItemNr: integer; // nr in a collection or list
193
220
    SkipIfEmpty: boolean;
194
221
    State: TLRSOWStackItemState;
195
222
    Buffer: Pointer;
211
238
    FStackPointer: integer;
212
239
    FStackCapacity: integer;
213
240
    FWriteEmptyInheritedChilds: boolean;
214
 
    function GetInstanceStack(Index: integer): TPersistent;
215
 
    procedure Push(const AName: string = ''; Instance: TPersistent = nil;
216
 
                   PushCount: integer = 1; SkipIfEmpty: boolean = false);
 
241
    FWriter: TWriter;
 
242
    procedure Push(ItemType: TLRSItemType; const AName: string = '';
 
243
                   Root: TComponent = nil; PushCount: integer = 1;
 
244
                   SkipIfEmpty: boolean = false);
217
245
    procedure EndHeader;
218
246
    procedure Pop(WriteNull: boolean);
219
247
    procedure ClearStack;
248
276
    procedure EndList; override;
249
277
    procedure BeginProperty(const PropName: String); override;
250
278
    procedure EndProperty; override;
251
 
    function GetStackPath(Root: TComponent): string;
 
279
    function GetStackPath: string;
252
280
 
253
281
    procedure Write(const Buffer; Count: Longint); override;
254
282
    procedure WriteBinary(const Buffer; Count: LongInt); override;
263
291
    procedure WriteSet(Value: LongInt; SetType: Pointer); override;
264
292
    procedure WriteString(const Value: String); override;
265
293
    procedure WriteWideString(const Value: WideString); override;
266
 
    {$ifndef VER2_2}
267
294
    procedure WriteUnicodeString(const Value: UnicodeString); override;
268
 
    {$endif}
269
295
 
270
 
    property InstanceStackPointer: integer read FStackPointer;
271
 
    property InstanceStack[Index: integer]: TPersistent read GetInstanceStack;
272
296
    property WriteEmptyInheritedChilds: boolean read FWriteEmptyInheritedChilds write FWriteEmptyInheritedChilds;
 
297
    property Writer: TWriter read FWriter write FWriter;
273
298
  end;
274
299
  TLRSObjectWriterClass = class of TLRSObjectWriter;
275
 
  
 
300
 
276
301
  TLRPositionLink = record
277
302
    LFMPosition: int64;
278
303
    LRSPosition: int64;
311
336
    property Count: integer read FCount write SetCount;
312
337
  end;
313
338
  
 
339
  { TUTF8Parser }
 
340
 
314
341
  TUTF8Parser = class(TObject)
315
342
  private
316
343
    fStream : TStream;
317
344
    fBuf : pchar;
318
 
    fBufLen : integer;
 
345
    fBufLen : integer; // read
319
346
    fPos : integer;
320
 
    fDeltaPos : integer;
 
347
    fLineStart : integer; // column = fPos - fLineStart + 1
321
348
    fFloatType : char;
322
349
    fSourceLine : integer;
323
350
    fToken : char;
363
390
    function TokenSymbolIs(const S: string): Boolean;
364
391
    property FloatType: Char read fFloatType;
365
392
    property SourceLine: Integer read fSourceLine;
 
393
    function SourceColumn: integer;
366
394
    property Token: Char read fToken;
367
395
  end;
368
396
 
456
484
                           var RootComponent: TComponent;
457
485
                           OnFindComponentClass: TFindComponentClassEvent;
458
486
                           TheOwner: TComponent = nil;
459
 
                           Parent: TComponent = nil);
 
487
                           Parent: TComponent = nil;
 
488
                           ReaderRoot: TComponent = nil);
460
489
procedure WriteComponentAsTextToStream(AStream: TStream;
461
490
                                       AComponent: TComponent);
462
491
procedure ReadComponentFromTextStream(AStream: TStream;
882
911
procedure ReadComponentFromBinaryStream(AStream: TStream;
883
912
  var RootComponent: TComponent;
884
913
  OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
885
 
  Parent: TComponent);
 
914
  Parent: TComponent; ReaderRoot: TComponent);
886
915
var
887
916
  DestroyDriver: Boolean;
888
917
  Reader: TReader;
925
954
  try
926
955
    UniqueNamer:=TReaderUniqueNamer.Create;
927
956
    Reader:=CreateLRSReader(AStream,DestroyDriver);
928
 
    Reader.Root:=RootComponent;
 
957
    if ReaderRoot = nil then
 
958
      Reader.Root:=RootComponent
 
959
    else
 
960
      Reader.Root:=ReaderRoot;
929
961
    Reader.Owner:=TheOwner;
930
962
    Reader.Parent:=Parent;
931
963
    Reader.OnFindComponentClass:=OnFindComponentClass;
946
978
  end;
947
979
end;
948
980
 
949
 
procedure WriteComponentAsTextToStream(AStream: TStream; AComponent: TComponent
950
 
  );
 
981
procedure WriteComponentAsTextToStream(AStream: TStream; AComponent: TComponent);
951
982
var
952
983
  BinStream: TMemoryStream;
953
984
begin
1363
1394
    try
1364
1395
      LRSObjectTextToBinary(LFMStream,BinStream);
1365
1396
      BinStream.Position:=0;
1366
 
      BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName
1367
 
        ,'FORMDATA');
 
1397
      BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName,'FORMDATA');
1368
1398
    finally
1369
1399
      BinStream.Free;
1370
1400
    end;
1540
1570
    r1:=TLResource(FList[i]);
1541
1571
    r2:=TLResource(FList[i+1]);
1542
1572
    if (AnsiCompareText(r1.Name,r2.Name)=0) and (r1.ValueType=r2.ValueType) then
 
1573
    begin
1543
1574
      DebugLn(['TLResourceList.Sort ',i,' DUPLICATE RESOURCE FOUND: ',r1.Name,':',r1.ValueType]);
 
1575
      //DumpStack;
 
1576
    end;
1544
1577
  end;
1545
1578
  {$ENDIF}
1546
1579
end;
2204
2237
        else begin
2205
2238
          // normal char
2206
2239
          NewInString := True;
2207
 
          NewStr := s[i];
 
2240
          NewStr := AnsiString(s[i]);
2208
2241
        end;
2209
2242
        if NewInString <> InString then begin
2210
2243
          NewStr := '''' + NewStr;
2292
2325
        vaWString: Result:='vaWString';
2293
2326
        vaInt64: Result:='vaInt64';
2294
2327
        vaUTF8String: Result:='vaUTF8String';
2295
 
        {$IFNDEF VER2_2}
2296
2328
        vaUString: Result:='vaUString';
2297
2329
        vaQWord : Result:='vaQWord';
2298
 
        {$ENDIF}
2299
2330
        else Result:='Unknown ValueType='+dbgs(Ord(ValueType));
2300
2331
        end;
2301
2332
      end;
2452
2483
            ACurrency:=ReadLRSCurrency(Input);
2453
2484
            OutLn(FloatToStr(ACurrency));
2454
2485
          end;
2455
 
        vaWString{$IFNDEF VER2_2},vaUString{$ENDIF}: begin
 
2486
        vaWString,vaUString: begin
2456
2487
            AWideString:=ReadLRSWideString(Input);
2457
2488
            OutWideString(AWideString);
2458
2489
            OutLn('');
2644
2675
      Output.Write(s[1], Length(s));
2645
2676
  end;
2646
2677
 
 
2678
  procedure WriteWideString(const s: WideString);
 
2679
  begin
 
2680
    WriteLRSInteger(Output,Length(s));
 
2681
    if Length(s) > 0 then
 
2682
      Output.Write(s[1], Length(s)*2);
 
2683
  end;
 
2684
 
2647
2685
  procedure WriteInteger(value: LongInt);
2648
2686
  begin
2649
2687
    if (value >= -128) and (value <= 127) then begin
2748
2786
          WriteLRSExtended(Output,flt);
2749
2787
          ParserNextToken;
2750
2788
        end;
2751
 
      toString,toWString:
 
2789
      toString:
2752
2790
        begin
2753
2791
          toStringBuf := parser.TokenString;
2754
2792
          //DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
2769
2807
            WriteLongString(toStringBuf);
2770
2808
          end;
2771
2809
        end;
 
2810
      toWString:
 
2811
        begin
 
2812
          toStringBuf := parser.TokenString;
 
2813
          //DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
 
2814
          while ParserNextToken = '+' do
 
2815
          begin
 
2816
            ParserNextToken;   // Get next string fragment
 
2817
            if not (parser.Token in [toString,toWString]) then
 
2818
              parser.CheckToken(toString);
 
2819
            toStringBuf := toStringBuf + parser.TokenString;
 
2820
          end;
 
2821
          Output.WriteByte(Ord(vaWString));
 
2822
          WriteWideString(UTF8Decode(toStringBuf));
 
2823
        end;
2772
2824
      toSymbol:
2773
2825
        begin
2774
2826
          if CompareText(parser.TokenString, 'True') = 0 then
2882
2934
  begin
2883
2935
    if parser.TokenSymbolIs('OBJECT') then
2884
2936
      Flags :=0  { IsInherited := False }
 
2937
    else if parser.TokenSymbolIs('INHERITED') then
 
2938
      Flags := 1 { IsInherited := True; }
2885
2939
    else begin
2886
 
      if parser.TokenSymbolIs('INHERITED') then
2887
 
        Flags := 1 { IsInherited := True; }
2888
 
      else begin
2889
 
        parser.CheckTokenSymbol('INLINE');
2890
 
        Flags := 4;
2891
 
      end;
 
2940
      parser.CheckTokenSymbol('INLINE');
 
2941
      Flags := 4;
2892
2942
    end;
2893
2943
    ParserNextToken;
2894
2944
    parser.CheckToken(toSymbol);
2938
2988
    Output.WriteByte(0);        // Terminate property list
2939
2989
  end;
2940
2990
 
 
2991
var
 
2992
  Count: Integer;
2941
2993
begin
2942
2994
  if Links<>nil then begin
2943
2995
    // sort links for LFM positions
2949
3001
  OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
2950
3002
  DefaultFormatSettings.ThousandSeparator:=',';
2951
3003
  try
2952
 
    Output.Write(FilerSignature[1], length(FilerSignature));
2953
 
    ProcessObject;
 
3004
    Count:=0;
 
3005
    repeat
 
3006
      Output.Write(FilerSignature[1], length(FilerSignature));
 
3007
      ProcessObject;
 
3008
      inc(Count);
 
3009
    until parser.TokenString='';
 
3010
    if Count>1 then
 
3011
      Output.WriteByte(0);        // Terminate object list
2954
3012
  finally
2955
3013
    parser.Free;
2956
3014
    DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
3084
3142
  Result.OnPropertyNotFound := @(PropertiesToSkip.DoPropertyNotFound);
3085
3143
 
3086
3144
  DestroyDriver:=false;
3087
 
  if Result.Driver.ClassType=LRSObjectReaderClass then exit;
 
3145
  if Result.Driver.ClassType=LRSObjectReaderClass then
 
3146
  begin
 
3147
    TLRSObjectReader(Result.Driver).Reader:=Result;
 
3148
    exit;
 
3149
  end;
3088
3150
  // hack to set a write protected variable.
3089
3151
  // DestroyDriver:=true; TReader will free it
3090
3152
  Driver:=LRSObjectReaderClass.Create(s,4096);
3091
3153
  p:=@Result.Driver;
3092
3154
  Result.Driver.Free;
3093
3155
  TAbstractObjectReader(p^):=Driver;
 
3156
  TLRSObjectReader(Driver).Reader:=Result;
3094
3157
end;
3095
3158
 
3096
3159
function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;
3100
3163
  Driver:=LRSObjectWriterClass.Create(s,4096);
3101
3164
  DestroyDriver:=true;
3102
3165
  Result:=TWriter.Create(Driver);
 
3166
  TLRSObjectWriter(Driver).Writer:=Result;
3103
3167
end;
3104
3168
 
3105
3169
{ LRS format converter functions }
3749
3813
  while Length(ReadStr) > 0 do;
3750
3814
end;
3751
3815
 
 
3816
procedure TLRSObjectReader.Push(ItemType: TLRSItemType; const AName: string;
 
3817
                                Root: TComponent; PushCount: integer);
 
3818
begin
 
3819
  if FStackPointer=FStackCapacity then begin
 
3820
    FStackCapacity:=FStackCapacity*2+10;
 
3821
    ReAllocMem(FStack,SizeOf(TLRSORStackItem)*FStackCapacity);
 
3822
    FillByte(FStack[FStackPointer],SizeOf(TLRSORStackItem)*(FStackCapacity-FStackPointer),0);
 
3823
  end;
 
3824
  //DebugLn(['TLRSObjectReader.Push AName=',AName,' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount]);
 
3825
  FStack[FStackPointer].Name:=AName;
 
3826
  FStack[FStackPointer].ItemType:=ItemType;
 
3827
  FStack[FStackPointer].Root:=Root;
 
3828
  FStack[FStackPointer].PushCount:=PushCount;
 
3829
  FStack[FStackPointer].ItemNr:=-1;
 
3830
  inc(FStackPointer);
 
3831
end;
 
3832
 
 
3833
procedure TLRSObjectReader.Pop;
 
3834
var
 
3835
  Item: PLRSORStackItem;
 
3836
begin
 
3837
  if FStackPointer=0 then
 
3838
    raise Exception.Create('Error: TLRSObjectReader.Pop stack is empty');
 
3839
  Item:=@FStack[FStackPointer-1];
 
3840
  //DebugLn(['TLRSObjectReader.Pop AName=',Item^.Name,
 
3841
  //        ' Type=',GetEnumName(TypeInfo(TLRSItemType), Integer(item^.ItemType)),
 
3842
  //        ' PushCount=',item^.PushCount,' StackPtr=', FStackPointer]);
 
3843
  if Item^.PushCount>1 then begin
 
3844
    // stack item still needs more EndList
 
3845
    dec(Item^.PushCount);
 
3846
  end else begin
 
3847
    // stack item is complete
 
3848
    dec(FStackPointer);
 
3849
  end;
 
3850
end;
 
3851
 
 
3852
procedure TLRSObjectReader.ClearStack;
 
3853
var
 
3854
  i: Integer;
 
3855
begin
 
3856
  for i:=0 to FStackCapacity-1 do begin
 
3857
    FStack[i].Name:='';
 
3858
  end;
 
3859
  ReAllocMem(FStack,0);
 
3860
end;
 
3861
 
 
3862
function TLRSObjectReader.InternalReadValue: TValueType;
 
3863
var
 
3864
  b: byte;
 
3865
begin
 
3866
  Result := vaNull; { Necessary in FPC as TValueType is larger than 1 byte! }
 
3867
  Read(b,1);
 
3868
  Result:=TValueType(b);
 
3869
end;
 
3870
 
3752
3871
function TLRSObjectReader.ReadIntegerContent: integer;
3753
3872
begin
3754
3873
  Result:=0;
3775
3894
  if Assigned(FBuffer) then
3776
3895
    FreeMem(FBuffer, FBufSize);
3777
3896
 
 
3897
  ClearStack;
 
3898
 
3778
3899
  inherited Destroy;
3779
3900
end;
3780
3901
 
3781
3902
function TLRSObjectReader.ReadValue: TValueType;
3782
 
var
3783
 
  b: byte;
3784
3903
begin
3785
 
  Result := vaNull; { Necessary in FPC as TValueType is larger than 1 byte! }
3786
 
  Read(b,1);
3787
 
  Result:=TValueType(b);
 
3904
  Result := InternalReadValue;
 
3905
  case Result of
 
3906
    vaNull:
 
3907
      begin
 
3908
        EndPropertyIfOpen;
 
3909
        // End previous element collection, list or component.
 
3910
        if FStackPointer > 0 then
 
3911
          Pop;
 
3912
      end;
 
3913
    vaCollection:
 
3914
      begin
 
3915
        Push(lrsitCollection);
 
3916
      end;
 
3917
    vaList:
 
3918
      begin
 
3919
        // Increase counter for next collection item.
 
3920
        if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
 
3921
          Inc(FStack[FStackPointer-1].ItemNr);
 
3922
        Push(lrsitList);
 
3923
      end;
 
3924
  end;
3788
3925
end;
3789
3926
 
3790
3927
function TLRSObjectReader.NextValue: TValueType;
3791
3928
begin
3792
 
  Result := ReadValue;
 
3929
  Result := InternalReadValue;
3793
3930
  { We only 'peek' at the next value, so seek back to unget the read value: }
3794
3931
  Dec(FBufPos);
3795
3932
end;
3810
3947
var
3811
3948
  Prefix: Byte;
3812
3949
  ValueType: TValueType;
 
3950
  ItemName: String;
 
3951
  ItemRoot: TComponent;
3813
3952
begin
3814
3953
  { Every component can start with a special prefix: }
3815
3954
  Flags := [];
3839
3978
 
3840
3979
  CompClassName := ReadStr;
3841
3980
  CompName := ReadStr;
 
3981
 
 
3982
  // Top component is addressed by ClassName.
 
3983
  if FStackPointer = 0 then
 
3984
  begin
 
3985
    ItemName := CompClassName;
 
3986
    ItemRoot := nil;
 
3987
  end
 
3988
  else
 
3989
  begin
 
3990
    ItemName := CompName;
 
3991
    if Assigned(Reader) then
 
3992
      // Reader.LookupRoot is the current Root component.
 
3993
      ItemRoot := Reader.LookupRoot
 
3994
    else
 
3995
      ItemRoot := nil;
 
3996
  end;
 
3997
 
 
3998
  // A component has two lists: properties and childs, hence PopCount=2.
 
3999
  Push(lrsitComponent, ItemName, ItemRoot, 2);
3842
4000
end;
3843
4001
 
3844
4002
function TLRSObjectReader.BeginProperty: String;
3845
4003
begin
 
4004
  EndPropertyIfOpen;
3846
4005
  Result := ReadStr;
 
4006
  Push(lrsitProperty, Result);
 
4007
end;
 
4008
 
 
4009
procedure TLRSObjectReader.EndPropertyIfOpen;
 
4010
begin
 
4011
  // End previous property.
 
4012
  if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitProperty) then
 
4013
    Pop;
 
4014
end;
 
4015
 
 
4016
function TLRSObjectReader.GetStackPath: string;
 
4017
var
 
4018
  i: Integer;
 
4019
  CurName: string;
 
4020
  Item: PLRSORStackItem;
 
4021
begin
 
4022
  Result:='';
 
4023
 
 
4024
  for i:=0 to FStackPointer-1 do
 
4025
  begin
 
4026
    Item := @FStack[i];
 
4027
 
 
4028
    // Reader.Root is the top component in the module.
 
4029
    if Assigned(Reader) and
 
4030
       (Item^.ItemType = lrsitComponent) and
 
4031
       (Item^.Root = Reader.Root) and
 
4032
       (Item^.Root <> nil) then
 
4033
    begin
 
4034
      // Restart path from top component.
 
4035
      Result := Item^.Root.ClassName;
 
4036
    end;
 
4037
 
 
4038
    CurName:=Item^.Name;
 
4039
    if CurName<>'' then begin
 
4040
      if Result<>'' then Result:=Result+'.';
 
4041
      Result:=Result+CurName;
 
4042
    end;
 
4043
    if Item^.ItemNr >= 0 then
 
4044
      Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
 
4045
  end;
3847
4046
end;
3848
4047
 
3849
4048
procedure TLRSObjectReader.ReadBinary(const DestData: TMemoryStream);
3976
4175
      Value := GetEnumValue(PTypeInfo(EnumType), Name);
3977
4176
      if Value = -1 then
3978
4177
        PropValueError;
3979
 
      {$IFNDEF VER2_2_0}
3980
4178
      include(tset(result),Value);
3981
 
      {$ELSE}
3982
 
      Result := Result or (1 shl Value);
3983
 
      {$ENDIF}
3984
4179
    end;
3985
4180
  except
3986
4181
    SkipSetBody;
4030
4225
  //debugln('TLRSObjectReader.ReadWideString ',Result);
4031
4226
end;
4032
4227
 
4033
 
{$ifndef VER2_2}
4034
4228
function TLRSObjectReader.ReadUnicodeString: UnicodeString;
4035
4229
var
4036
4230
  i: Integer;
4041
4235
    Read(Pointer(@Result[1])^, i*2);
4042
4236
  //debugln('TLRSObjectReader.ReadWideString ',Result);
4043
4237
end;
4044
 
{$endif}
4045
4238
 
4046
4239
procedure TLRSObjectReader.SkipComponent(SkipComponentInfos: Boolean);
4047
4240
var
4103
4296
      SkipBytes(10);
4104
4297
    vaString, vaIdent:
4105
4298
      ReadStr;
4106
 
    vaBinary, vaLString, vaWString{$IFNDEF VER2_2}, vaUString{$ENDIF}:
 
4299
    vaBinary, vaLString:
4107
4300
      begin
4108
4301
        Count:=ReadIntegerContent;
4109
4302
        SkipBytes(Count);
4110
4303
      end;
 
4304
    vaWString, vaUString:
 
4305
      begin
 
4306
        Count:=ReadIntegerContent;
 
4307
        SkipBytes(Count*2);
 
4308
      end;
4111
4309
    vaSet:
4112
4310
      SkipSetBody;
4113
4311
    vaCollection:
4139
4337
 
4140
4338
{ TLRSObjectWriter }
4141
4339
 
4142
 
function TLRSObjectWriter.GetInstanceStack(Index: integer): TPersistent;
4143
 
begin
4144
 
  Result:=FStack[Index].Instance;
4145
 
end;
4146
 
 
4147
 
procedure TLRSObjectWriter.Push(const AName: string; Instance: TPersistent;
4148
 
  PushCount: integer; SkipIfEmpty: boolean);
 
4340
procedure TLRSObjectWriter.Push(ItemType: TLRSItemType; const AName: string;
 
4341
                                Root: TComponent; PushCount: integer;
 
4342
                                SkipIfEmpty: boolean);
4149
4343
begin
4150
4344
  if FStackPointer=FStackCapacity then begin
4151
4345
    FStackCapacity:=FStackCapacity*2+10;
4152
4346
    ReAllocMem(FStack,SizeOf(TLRSOWStackItem)*FStackCapacity);
4153
4347
    FillByte(FStack[FStackPointer],SizeOf(TLRSOWStackItem)*(FStackCapacity-FStackPointer),0);
4154
4348
  end;
4155
 
  //if AName<>'' then DebugLn(['TLRSObjectWriter.Push AName=',AName,' Instance=',DbgsName(Instance),' PushCount=',PushCount,' SkipIfEmpty=',SkipIfEmpty]);
 
4349
  //if AName<>'' then DebugLn(['TLRSObjectWriter.Push AName=',AName, ' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount,' SkipIfEmpty=',SkipIfEmpty]);
4156
4350
  FStack[FStackPointer].Name:=AName;
4157
 
  FStack[FStackPointer].Instance:=Instance;
 
4351
  FStack[FStackPointer].ItemType:=ItemType;
 
4352
  FStack[FStackPointer].Root:=Root;
4158
4353
  FStack[FStackPointer].PushCount:=PushCount;
 
4354
  FStack[FStackPointer].ItemNr:=-1;
4159
4355
  FStack[FStackPointer].SkipIfEmpty:=SkipIfEmpty;
4160
4356
  FStack[FStackPointer].BufCount:=0;
4161
4357
  if SkipIfEmpty then
4451
4647
procedure TLRSObjectWriter.BeginCollection;
4452
4648
begin
4453
4649
  //DebugLn(['TLRSObjectWriter.BeginCollection ',FStackPointer]);
4454
 
  Push;
 
4650
  Push(lrsitCollection);
4455
4651
  WriteValue(vaCollection);
4456
4652
end;
4457
4653
 
4460
4656
var
4461
4657
  Prefix: Byte;
4462
4658
  CanBeOmitted: boolean;
 
4659
  ItemName: String;
 
4660
  ItemRoot: TComponent;
4463
4661
begin
4464
4662
  //DebugLn(['TLRSObjectWriter.BeginComponent ',FStackPointer]);
4465
4663
  // an inherited child component can be omitted if empty
4466
4664
  CanBeOmitted:=(not WriteEmptyInheritedChilds)
4467
4665
            and (FStackPointer>0) and (ffInherited in Flags)
4468
4666
            and (not (ffChildPos in Flags));
4469
 
  // a component has two lists: properties and childs
4470
 
  Push(Component.Name,Component,2,CanBeOmitted);
 
4667
 
 
4668
  // Top component is addressed by ClassName.
 
4669
  if FStackPointer = 0 then
 
4670
  begin
 
4671
    ItemName := Component.ClassName;
 
4672
    ItemRoot := nil;
 
4673
  end
 
4674
  else
 
4675
  begin
 
4676
    ItemName := Component.Name;
 
4677
    if Assigned(Writer) then
 
4678
      // Writer.Root is the current Root component.
 
4679
      ItemRoot := Writer.Root
 
4680
    else
 
4681
      ItemRoot := nil;
 
4682
  end;
 
4683
 
 
4684
  // A component has two lists: properties and childs, hence PopCount=2.
 
4685
  Push(lrsitComponent, ItemName, ItemRoot, 2, CanBeOmitted);
4471
4686
 
4472
4687
  if not FSignatureWritten then
4473
4688
  begin
4498
4713
 
4499
4714
procedure TLRSObjectWriter.BeginList;
4500
4715
begin
 
4716
  // Increase counter for next collection item.
 
4717
  if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
 
4718
    Inc(FStack[FStackPointer-1].ItemNr);
4501
4719
  //DebugLn(['TLRSObjectWriter.BeginList ',FStackPointer]);
4502
 
  Push;
 
4720
  Push(lrsitList);
4503
4721
  WriteValue(vaList);
4504
4722
end;
4505
4723
 
4507
4725
begin
4508
4726
  //DebugLn(['TLRSObjectWriter.EndList ',FStackPointer]);
4509
4727
  Pop(true);
4510
 
  //WriteValue(vaNull);
4511
4728
end;
4512
4729
 
4513
4730
procedure TLRSObjectWriter.BeginProperty(const PropName: String);
4514
4731
begin
4515
4732
  //DebugLn(['TLRSObjectWriter.BeginProperty ',FStackPointer,' ',PropName]);
4516
 
  Push(PropName);
 
4733
  Push(lrsitProperty, PropName);
4517
4734
  WriteStr(PropName);
4518
4735
end;
4519
4736
 
4523
4740
  Pop(false);
4524
4741
end;
4525
4742
 
4526
 
function TLRSObjectWriter.GetStackPath(Root: TComponent): string;
 
4743
function TLRSObjectWriter.GetStackPath: string;
4527
4744
var
4528
4745
  i: Integer;
4529
 
  CurInstance: TPersistent;
4530
 
  CurComponent: TComponent;
4531
4746
  CurName: string;
 
4747
  Item: PLRSOWStackItem;
4532
4748
begin
4533
4749
  Result:='';
4534
 
  for i:=0 to FStackPointer-1 do begin
4535
 
    CurInstance:=FStack[i].Instance;
4536
 
    if (CurInstance is TComponent) and (Root<>nil) then begin
4537
 
      CurComponent:=TComponent(CurInstance);
4538
 
      if CurComponent=Root then begin
4539
 
        Result:=CurComponent.ClassName;
4540
 
        continue;
4541
 
      end;
4542
 
      if CurComponent.Owner=Root then begin
4543
 
        Result:=CurComponent.Owner.ClassName+'.'+CurComponent.Name;
4544
 
        continue;
4545
 
      end;
 
4750
 
 
4751
  for i:=0 to FStackPointer-1 do
 
4752
  begin
 
4753
    Item := @FStack[i];
 
4754
 
 
4755
    // Writer.LookupRoot is the top component in the module.
 
4756
    if Assigned(Writer) and
 
4757
       (Item^.ItemType = lrsitComponent) and
 
4758
       (Item^.Root = Writer.LookupRoot) and
 
4759
       (Item^.Root <> nil) then
 
4760
    begin
 
4761
      // Restart path from top component.
 
4762
      Result := Item^.Root.ClassName;
4546
4763
    end;
4547
 
    CurName:=FStack[i].Name;
 
4764
 
 
4765
    CurName:=Item^.Name;
4548
4766
    if CurName<>'' then begin
4549
4767
      if Result<>'' then Result:=Result+'.';
4550
4768
      Result:=Result+CurName;
4551
4769
    end;
 
4770
    if Item^.ItemNr >= 0 then
 
4771
      Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
4552
4772
  end;
4553
4773
end;
4554
4774
 
4654
4874
  tset = set of 0..31;
4655
4875
var
4656
4876
  i: Integer;
4657
 
  {$IFDEF VER2_2_0}
4658
 
  Mask: LongInt;
4659
 
  {$ENDIF}
4660
4877
begin
4661
4878
  WriteValue(vaSet);
4662
 
  {$IFDEF VER2_2_0}
4663
 
  Mask := 1;
4664
 
  {$ENDIF}
4665
4879
  for i := 0 to 31 do
4666
4880
  begin
4667
 
    {$IFNDEF VER2_2_0}
4668
4881
    if (i in tset(Value)) then
4669
4882
      WriteStr(GetEnumName(PTypeInfo(SetType), i));
4670
 
    {$ELSE}
4671
 
    if (Value and Mask) <> 0 then
4672
 
      WriteStr(GetEnumName(PTypeInfo(SetType), i));
4673
 
    Mask := Mask shl 1;
4674
 
    {$ENDIF}
4675
4883
  end;
4676
4884
  WriteStr('');
4677
4885
end;
4706
4914
  WriteWideStringContent(Value);
4707
4915
end;
4708
4916
 
4709
 
{$ifndef VER2_2}
4710
4917
procedure TLRSObjectWriter.WriteUnicodeString(const Value: UnicodeString);
4711
4918
var
4712
4919
  i: Integer;
4716
4923
  WriteIntegerContent(i);
4717
4924
  WriteWideStringContent(Value);
4718
4925
end;
4719
 
{$endif}
4720
4926
 
4721
4927
{ TLRPositionLinks }
4722
4928
 
4993
5199
  ComponentSize, SizeLength: int64;
4994
5200
  AStream: TMemoryStream;
4995
5201
begin
4996
 
  if not ReadComponentSize(ComponentSize,SizeLength) then exit(false);
4997
 
  if (FQueue.Size-SizeLength<ComponentSize) then exit(false);
 
5202
  Result:=false;
 
5203
  if not ReadComponentSize(ComponentSize,SizeLength) then exit;
 
5204
  if (FQueue.Size-SizeLength<ComponentSize) then exit;
4998
5205
  // a complete component is in the buffer -> copy it to a stream
4999
5206
  AStream:=TMemoryStream.Create;
5000
5207
  try
5008
5215
  finally
5009
5216
    AStream.Free;
5010
5217
  end;
 
5218
  Result:=true;
5011
5219
end;
5012
5220
 
5013
5221
function TCustomLazComponentQueue.ConvertComponentAsString(AComponent: TComponent
5122
5330
end;
5123
5331
 
5124
5332
procedure TUTF8Parser.LoadBuffer;
5125
 
var toread : integer;
 
5333
var newread : integer;
5126
5334
begin
5127
 
  toread:=fStream.Size-fStream.Position;
5128
 
  if toread>ParseBufSize then toread:=ParseBufSize;
5129
 
  if toread=0 then
5130
 
  begin
5131
 
    fEofReached:=true;
5132
 
    exit;
5133
 
  end;
5134
 
  fStream.ReadBuffer(fBuf[0],toread);
5135
 
  fBuf[toread]:=#0;
5136
 
  inc(fDeltaPos,fPos);
 
5335
  newread:=fStream.Read(fBuf[0],ParseBufSize);
 
5336
  fBuf[newread]:=#0;
 
5337
  fLineStart:=fLineStart-fPos; // column = fPos - fLineStart + 1
5137
5338
  fPos:=0;
5138
 
  fBufLen:=toread;
 
5339
  fBufLen:=newread;
 
5340
  fEofReached:=newread=0;
5139
5341
end;
5140
5342
 
5141
5343
procedure TUTF8Parser.CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5142
5344
begin
5143
 
  if fBuf[fPos]=#0 then LoadBuffer;
 
5345
  if fBuf[fPos]<>#0 then exit;
 
5346
  if fPos<fBufLen then begin
 
5347
    // skip #0
 
5348
    repeat
 
5349
      inc(fPos);
 
5350
      if fBuf[fPos]<>#0 then exit;
 
5351
    until (fPos=fBufLen);
 
5352
  end;
 
5353
  LoadBuffer;
5144
5354
end;
5145
5355
 
5146
5356
procedure TUTF8Parser.ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5200
5410
    CheckLoadBuffer;
5201
5411
    if fBuf[fPos]=#10 then inc(fPos); //CR LF
5202
5412
  end
5203
 
  else inc(fPos); //LF
 
5413
  else
 
5414
    inc(fPos); //LF
 
5415
  CheckLoadBuffer;
5204
5416
  inc(fSourceLine);
5205
 
  fDeltaPos:=-(fPos-1);
 
5417
  fLineStart:=fPos;
5206
5418
end;
5207
5419
 
5208
5420
procedure TUTF8Parser.SkipSpaces;
5209
5421
begin
5210
 
  while fBuf[fPos] in [' ',#9] do
 
5422
  while fBuf[fPos] in [' ',#9] do begin
5211
5423
    inc(fPos);
 
5424
    CheckLoadBuffer;
 
5425
  end;
5212
5426
end;
5213
5427
 
5214
5428
procedure TUTF8Parser.SkipWhitespace;
5215
5429
begin
5216
5430
  while true do
5217
5431
  begin
5218
 
    CheckLoadBuffer;
5219
5432
    case fBuf[fPos] of
5220
5433
      ' ',#9  : SkipSpaces;
5221
5434
      #10,#13 : HandleNewLine
5272
5485
  begin
5273
5486
    fFloatType:=fBuf[fPos];
5274
5487
    inc(fPos);
 
5488
    CheckLoadBuffer;
5275
5489
    fToken:=toFloat;
5276
5490
  end
5277
5491
  else fFloatType:=#0;
5350
5564
  if ascii then
5351
5565
    fToken:=Classes.toString
5352
5566
  else
5353
 
    {$ifdef ver2_2_0}
5354
 
    fToken:=Classes.toString
5355
 
    {$else}
5356
5567
    fToken:=toWString;
5357
 
    {$endif}
5358
5568
end;
5359
5569
 
5360
5570
procedure TUTF8Parser.HandleMinus;
5378
5588
  fToken:=fBuf[fPos];
5379
5589
  fLastTokenStr:=fToken;
5380
5590
  inc(fPos);
 
5591
  CheckLoadBuffer;
5381
5592
end;
5382
5593
 
5383
5594
constructor TUTF8Parser.Create(Stream: TStream);
5386
5597
  fBuf:=GetMem(ParseBufSize+1);
5387
5598
  fBufLen:=0;
5388
5599
  fPos:=0;
5389
 
  fDeltaPos:=1;
 
5600
  fLineStart:=0;
5390
5601
  fSourceLine:=1;
5391
5602
  fEofReached:=false;
5392
5603
  fLastTokenStr:='';
5427
5638
 
5428
5639
procedure TUTF8Parser.ErrorStr(const Message: string);
5429
5640
begin
5430
 
  raise EParserError.CreateFmt(Message+SParLocInfo,[SourceLine,fPos+fDeltaPos,SourcePos]);
 
5641
  debugln(['TUTF8Parser.ErrorStr Message="',Message,'" at y=',SourceLine,',x=',SourceColumn]);
 
5642
  raise EParserError.CreateFmt(Message+SParLocInfo,[SourceLine,SourceColumn,SourcePos]);
5431
5643
end;
5432
5644
 
5433
5645
procedure TUTF8Parser.HexToBinary(Stream: TStream);
5446
5658
      Error(SParUnterminatedBinValue);
5447
5659
    b:=b or GetHexValue(fBuf[fPos]);
5448
5660
    inc(fPos);
 
5661
    CheckLoadBuffer;
5449
5662
    outbuf[i]:=b;
5450
5663
    inc(i);
5451
5664
    if i>=ParseBufSize then
5529
5742
  Result:=(fToken=toSymbol) and (CompareText(fLastTokenStr,S)=0);
5530
5743
end;
5531
5744
 
 
5745
function TUTF8Parser.SourceColumn: integer;
 
5746
begin
 
5747
  Result:=fPos-fLineStart+1;
 
5748
end;
 
5749
 
5532
5750
//------------------------------------------------------------------------------
5533
5751
procedure InternalInit;
5534
5752
begin
5546
5764
 
5547
5765
end.
5548
5766
 
 
5767
 
 
5768