← Back to branch summary

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

« back to all changes in this revision

Viewing changes to converter/convcodetool.pas

  • 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
http://bugs.debian.org/708695
[ 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:
converter/convcodetool.pas
54
54
    fCodeTool: TCodeTool;
55
55
    fCode: TCodeBuffer;
56
56
    fSrcCache: TSourceChangeCache;
57
 
    fIsMainFile: Boolean;                 // Main project / package file.
58
 
    fIsConsoleApp: Boolean;
59
57
    fAskAboutError: Boolean;
60
58
    fSettings: TConvertSettings;          // Conversion settings.
61
59
    procedure InitCodeTool;
68
66
    property CodeTool: TCodeTool read fCodeTool;
69
67
    property Code: TCodeBuffer read fCode;
70
68
    property SrcCache: TSourceChangeCache read fSrcCache;
71
 
    property IsMainFile: Boolean read fIsMainFile write fIsMainFile;
72
 
    property IsConsoleApp: Boolean read fIsConsoleApp write fIsConsoleApp;
73
69
    property AskAboutError: Boolean read fAskAboutError write fAskAboutError;
74
70
    property Settings: TConvertSettings read fSettings write fSettings;
75
71
  end;
79
75
  TConvDelphiCodeTool = class
80
76
  private
81
77
    fCTLink: TCodeToolLink;
 
78
    fCTLinkCreated: boolean;
 
79
    fIsConsoleApp: Boolean;
82
80
    fHasFormFile: boolean;
83
81
    fLowerCaseRes: boolean;
84
 
    fDfmDirectiveStart: integer;
85
 
    fDfmDirectiveEnd: integer;
 
82
    fAddUnitEvent: TAddUnitEvent;
86
83
    // Delphi Function names to replace with FCL/LCL functions.
87
84
    fDefinedProcNames: TStringList;
88
85
    // List of TFuncReplacement.
89
86
    fFuncsToReplace: TObjectList;
90
87
 
91
88
    function AddModeDelphiDirective: boolean;
92
 
    function RenameResourceDirectives: boolean;
93
89
    function ReplaceFuncsInSource: boolean;
94
90
    function RememberProcDefinition(aNode: TCodeTreeNode): TCodeTreeNode;
95
91
    function ReplaceFuncCalls(aIsConsoleApp: boolean): boolean;
96
92
  public
 
93
    constructor Create(APascalBuffer: TCodeBuffer);
97
94
    constructor Create(ACTLink: TCodeToolLink);
98
95
    destructor Destroy; override;
99
96
    function Convert: TModalResult;
100
97
    function FindApptypeConsole: boolean;
 
98
    function RenameResourceDirectives: boolean;
101
99
    function FixMainClassAncestor(const AClassName: string;
102
100
                                  AReplaceTypes: TStringToStringTree): boolean;
103
 
    function CheckTopOffsets(LFMBuf: TCodeBuffer; LFMTree: TLFMTree;
104
 
               VisOffsets: TVisualOffsets; ValueNodes: TObjectList): boolean;
105
101
  public
 
102
    property IsConsoleApp: Boolean read fIsConsoleApp write fIsConsoleApp;
106
103
    property HasFormFile: boolean read fHasFormFile write fHasFormFile;
107
104
    property LowerCaseRes: boolean read fLowerCaseRes write fLowerCaseRes;
 
105
    property AddUnitEvent: TAddUnitEvent read fAddUnitEvent write fAddUnitEvent;
108
106
  end;
109
107
 
110
108
 
116
114
begin
117
115
  inherited Create;
118
116
  fCode:=ACode;
119
 
  fIsConsoleApp:=False;
120
117
  fAskAboutError:=True;
121
118
  InitCodeTool;
122
119
end;
129
126
procedure TCodeToolLink.InitCodeTool;
130
127
begin
131
128
  // Initialize codetools. (Copied from TCodeToolManager.)
 
129
  fCodeTool:=nil;
 
130
  fSrcCache:=nil;
132
131
  if not CodeToolBoss.InitCurCodeTool(fCode) then exit;
133
132
  try
134
133
    fCodeTool:=CodeToolBoss.CurCodeTool;
166
165
 
167
166
{ TConvDelphiCodeTool }
168
167
 
 
168
constructor TConvDelphiCodeTool.Create(APascalBuffer: TCodeBuffer);
 
169
begin
 
170
  debugln(['TConvDelphiCodeTool.Create ',DbgSName(APascalBuffer)]);
 
171
  debugln(['TConvDelphiCodeTool.Create ',APascalBuffer.Filename]);
 
172
  inherited Create;
 
173
  fCTLink:=TCodeToolLink.Create(APascalBuffer);
 
174
  fCTLink.AskAboutError:=False;
 
175
  fLowerCaseRes:=True;
 
176
  fIsConsoleApp:=False;
 
177
  fCTLinkCreated:=True;
 
178
  if fCTLink.CodeTool=nil then exit;
 
179
  try
 
180
    fCTLink.CodeTool.BuildTree(lsrInitializationStart);
 
181
  except
 
182
    on e: Exception do
 
183
      CodeToolBoss.HandleException(e);
 
184
  end;
 
185
end;
 
186
 
169
187
constructor TConvDelphiCodeTool.Create(ACTLink: TCodeToolLink);
170
188
begin
171
189
  inherited Create;
172
190
  fCTLink:=ACTLink;
173
 
  fLowerCaseRes:=false;
 
191
  fLowerCaseRes:=False;
 
192
  fIsConsoleApp:=False;
 
193
  fCTLinkCreated:=False;
174
194
end;
175
195
 
176
196
destructor TConvDelphiCodeTool.Destroy;
177
197
begin
 
198
  if fCTLinkCreated and (fCTLink.SrcCache<>nil) and (fCTLink.CodeTool<>nil)
 
199
  and (fCTLink.SrcCache.MainScanner=fCTLink.CodeTool.Scanner) then begin
 
200
    fCTLink.SrcCache.Apply;
 
201
    FreeAndNil(fCTLink);
 
202
  end;
178
203
  inherited Destroy;
179
204
end;
180
205
 
185
210
// TODO: fix delphi ambiguouties like incomplete proc implementation headers
186
211
begin
187
212
  Result:=mrCancel;
 
213
  if fCTLink.CodeTool=nil then exit;
188
214
  try
189
215
    fCTLink.SrcCache.BeginUpdate;
190
216
    try
192
218
      if not AddModeDelphiDirective then exit;
193
219
      if not RenameResourceDirectives then exit;
194
220
      if fCTLink.Settings.FuncReplaceMode=rsEnabled then
195
 
        if not ReplaceFuncCalls(fCTLink.IsConsoleApp) then exit;
196
 
//      if not fSrcCache.Apply then exit;
 
221
        if not ReplaceFuncCalls(fIsConsoleApp) then exit;
197
222
    finally
198
223
      fCTLink.SrcCache.EndUpdate;
199
224
    end;
200
 
//    if not fCTLink.SrcCache.Apply then exit;
201
225
    Result:=mrOK;
202
226
  except
203
227
    on e: Exception do begin
213
237
  ParamPos, ACleanPos: Integer;
214
238
begin
215
239
  Result:=false;
 
240
  if fCTLink.CodeTool=nil then exit;
216
241
  ACleanPos:=0;
217
242
  with fCTLink.CodeTool do begin
218
 
    BuildTree(true);
 
243
    if Scanner=nil then exit;
 
244
    BuildTree(lsrImplementationStart);
219
245
    ACleanPos:=FindNextCompilerDirectiveWithName(Src, 1, 'Apptype',
220
246
                                                 Scanner.NestedComments, ParamPos);
221
247
    if (ACleanPos>0) and (ACleanPos<=SrcLen) and (ParamPos>0) then
231
257
begin
232
258
  Result:=false;
233
259
  with fCTLink.CodeTool do begin
234
 
    BuildTree(true);
235
 
    if not FindModeDirective(false,ModeDirectivePos) then begin
 
260
    if not FindModeDirective(true,ModeDirectivePos) then begin
236
261
      // add {$MODE Delphi} behind source type
237
262
      if Tree.Root=nil then exit;
238
263
      MoveCursorToNodeStart(Tree.Root);
240
265
      ReadNextAtom; // name
241
266
      ReadNextAtom; // semicolon
242
267
      InsertPos:=CurPos.EndPos;
243
 
      if fCTLink.Settings.Target in [ctLazarusDelphi, ctLazarusDelphiSameDfm] then
 
268
      if fCTLink.Settings.SupportDelphi then
244
269
        s:='{$IFDEF FPC}'+LineEnding+'  {$MODE Delphi}'+LineEnding+'{$ENDIF}'
245
270
      else
246
271
        s:='{$MODE Delphi}';
247
272
      fCTLink.SrcCache.Replace(gtEmptyLine,gtEmptyLine,InsertPos,InsertPos,s);
248
273
    end;
249
274
    // changing mode requires rescan
250
 
    BuildTree(false);
 
275
    BuildTree(lsrEnd);
251
276
  end;
252
277
  Result:=true;
253
278
end;
259
284
  ParamPos, ACleanPos: Integer;
260
285
  Key, LowKey, NewKey: String;
261
286
  s: string;
262
 
  AlreadyIsLfm: Boolean;
263
287
begin
264
288
  Result:=false;
265
 
  AlreadyIsLfm:=false;
266
 
  fDfmDirectiveStart:=-1;
267
 
  fDfmDirectiveEnd:=-1;
 
289
  if fCTLink.CodeTool=nil then exit;
268
290
  ACleanPos:=1;
269
291
  // find $R directive
270
 
  with fCTLink.CodeTool do
 
292
  with fCTLink.CodeTool do begin
 
293
    if Scanner=nil then exit;
271
294
    repeat
272
295
      ACleanPos:=FindNextCompilerDirectiveWithName(Src, ACleanPos, 'R',
273
296
                                                   Scanner.NestedComments, ParamPos);
280
303
        LowKey:=LowerCase(Key);
281
304
        // Form file resource rename or lowercase:
282
305
        if (LowKey='dfm') or (LowKey='xfm') then begin
283
 
          if fCTLink.Settings.Target in [ctLazarusDelphi, ctLazarusDelphiSameDfm] then begin
 
306
          if Assigned(fCTLink.Settings) and fCTLink.Settings.SupportDelphi then begin
284
307
            // Use the same dfm file. Lowercase existing key.
285
 
            if (fCTLink.Settings.Target=ctLazarusDelphiSameDfm) and (Key<>LowKey) then
286
 
              NewKey:=LowKey;
287
 
            // Later IFDEF will be added so that Delphi can still use .dfm.
288
 
            fDfmDirectiveStart:=ACleanPos;
289
 
            fDfmDirectiveEnd:=ParamPos+6;
 
308
            if fCTLink.Settings.SameDfmFile then begin
 
309
              if Key<>LowKey then
 
310
                NewKey:=LowKey;
 
311
            end
 
312
            else begin
 
313
              // Add IFDEF for .lfm and .dfm allowing Delphi to use .dfm.
 
314
              s:='{$IFNDEF FPC}'+LineEnding+
 
315
                 '  {$R *.dfm}'+LineEnding+
 
316
                 '{$ELSE}'+LineEnding+
 
317
                 '  {$R *.lfm}'+LineEnding+
 
318
                 '{$ENDIF}';
 
319
              Result:=fCTLink.SrcCache.Replace(gtNone,gtNone,ACleanPos,ParamPos+6,s);
 
320
            end;
290
321
          end
291
322
          else       // Change .dfm to .lfm.
292
323
            NewKey:='lfm';
293
324
        end
294
 
        // If there already is .lfm, prevent adding IFDEF for .dfm / .lfm.
295
 
        else if LowKey='lfm' then
296
 
          AlreadyIsLfm:=true
297
325
        // lowercase {$R *.RES} to {$R *.res}
298
326
        else if (Key='RES') and fLowerCaseRes then
299
327
          NewKey:=LowKey;
300
 
        // Now change code.
301
 
        if NewKey<>'' then
302
 
          if not fCTLink.SrcCache.Replace(gtNone,gtNone,ParamPos+2,ParamPos+5,NewKey) then exit;
 
328
        // Change a single resource name.
 
329
        if NewKey<>'' then begin
 
330
          if not fCTLink.SrcCache.Replace(gtNone,gtNone,ParamPos+2,ParamPos+5,NewKey) then
 
331
            exit;
 
332
        end;
303
333
      end;
304
334
      ACleanPos:=FindCommentEnd(Src, ACleanPos, Scanner.NestedComments);
305
335
    until false;
306
 
  // if there is already .lfm file, don't add IFDEF for .dfm / .lfm.
307
 
  if (fCTLink.Settings.Target=ctLazarusDelphi) and (fDfmDirectiveStart<>-1)
308
 
  and not AlreadyIsLfm then begin
309
 
    // Add IFDEF for .lfm and .dfm allowing Delphi to use .dfm.
310
 
    s:='{$IFNDEF FPC}'+LineEnding+
311
 
       '  {$R *.dfm}'+LineEnding+
312
 
       '{$ELSE}'+LineEnding+
313
 
       '  {$R *.lfm}'+LineEnding+
314
 
       '{$ENDIF}';
315
 
    Result:=fCTLink.SrcCache.Replace(gtNone,gtNone,fDfmDirectiveStart,fDfmDirectiveEnd,s);
316
336
  end;
317
337
  Result:=true;
318
338
end;
326
346
  OldType, NewType: String;
327
347
begin
328
348
  Result:=false;
 
349
  if fCTLink.CodeTool=nil then exit;
329
350
  with fCTLink.CodeTool do begin
330
 
    BuildTree(true);
 
351
    if Scanner=nil then exit;
 
352
    BuildTree(lsrImplementationStart);
331
353
    // Find the class name that the main class inherits from.
332
354
    ANode:=FindClassNodeInUnit(AClassName,true,false,false,false);
333
355
    if ANode=nil then exit;
334
 
    BuildSubTreeForClass(ANode);
335
356
    InheritanceNode:=FindInheritanceNode(ANode);
336
357
    if InheritanceNode=nil then exit;
337
358
    ANode:=InheritanceNode.FirstChild;
357
378
  Result:=true;
358
379
end;
359
380
 
360
 
procedure SplitParam(const aStr: string; aDelimiter: Char; ResultList: TStringList);
361
 
// A modified split function. Removes '$' in front of every token.
362
 
 
363
 
  procedure SetItem(Start, Len: integer); // Add the item.
364
 
  begin
365
 
    while (aStr[Start]=' ') do begin      // Trim leading space.
366
 
      Inc(Start);
367
 
      Dec(Len);
368
 
    end;
369
 
    while (aStr[Start+Len-1]=' ') do      // Trim trailing space.
370
 
      Dec(Len);
371
 
    if (aStr[Start]='$') then begin       // Parameters must begin with '$'.
372
 
      Inc(Start);
373
 
      Dec(Len);
374
 
    end
375
 
    else
376
 
      raise EDelphiConverterError.Create('Replacement function parameter should start with "$".');
377
 
    ResultList.Add(Copy(aStr, Start, Len));
378
 
  end;
379
 
 
380
 
var
381
 
  i, Start, EndPlus1: Integer;
382
 
begin
383
 
  ResultList.Clear;
384
 
  Start:=1;
385
 
  repeat
386
 
    i:=Start;
387
 
    while (i<Length(aStr)) and (aStr[i]<>aDelimiter) do
388
 
      Inc(i);                             // Next delimiter.
389
 
    EndPlus1:=i;
390
 
    if i<Length(aStr) then
391
 
    begin
392
 
      SetItem(Start, EndPlus1-Start);
393
 
      Start:=i+1;                         // Start of next item.
394
 
    end
395
 
    else begin
396
 
      EndPlus1:=i+1;
397
 
      if EndPlus1>=Start then
398
 
        SetItem(Start, EndPlus1-Start);   // Copy the rest to last item.
399
 
      Break;                              // Out of the loop.
400
 
    end;
401
 
  until False;
402
 
end;
403
 
 
404
381
function TConvDelphiCodeTool.ReplaceFuncsInSource: boolean;
405
382
// Replace the function names and parameters in source.
406
383
var
407
 
  // Replacement parameter positions, will be converted to integers.
408
 
  ParamList: TStringList;
409
 
  BodyEnd: Integer;                     // End of function body.
 
384
  ReplacementParams: TObjectList;           // Replacement parameters.
410
385
 
411
386
  function ParseReplacementParams(const aStr: string): integer;
412
387
  // Parse replacement params. They show which original params are copied where.
413
388
  // Returns the first position where comments can be searched from.
414
389
  var
415
 
    ParamBeg, ParamEnd: Integer;        // Start and end of parameters.
416
 
    s: String;
 
390
    i, xNum, xStart, xLen: Integer;
417
391
  begin
418
 
    Result:=1;
419
 
    ParamBeg:=Pos('(', aStr);
420
 
    if ParamBeg>0 then begin
421
 
      ParamEnd:=PosEx(')', aStr, ParamBeg+1);
422
 
      if ParamEnd=0 then
423
 
        raise EDelphiConverterError.Create('")" is missing from replacement function.');
424
 
      s:=Copy(aStr, ParamBeg+1, ParamEnd-ParamBeg-1);
425
 
      SplitParam(s, ',', ParamList);    // The actual parameter list.
426
 
      BodyEnd:=ParamBeg-1;
427
 
      Result:=ParamEnd+1;
 
392
    i:=0;
 
393
    while i<Length(aStr) do begin
 
394
      Inc(i);
 
395
      if aStr[i]='$' then begin
 
396
        xStart:=i;
 
397
        Inc(i);                           // Skip '$'
 
398
        while (i<Length(aStr)) and (aStr[i] in ['0'..'9']) do
 
399
          Inc(i);                         // Get the number after '$'
 
400
        xLen:=i-xStart;
 
401
        if xLen<2 then
 
402
          raise EDelphiConverterError.Create('"$" should be followed by a number.');
 
403
        xNum:=StrToInt(copy(aStr, xStart+1, xLen-1)); // Leave out '$', convert number.
 
404
        if xNum < 1 then
 
405
          raise EDelphiConverterError.Create(
 
406
                           'Replacement function parameter number should be >= 1.');
 
407
        ReplacementParams.Add(TReplacementParam.Create(xNum, xLen, xStart));
 
408
      end;
428
409
    end;
 
410
    if aStr[i]<>')' then
 
411
      raise EDelphiConverterError.Create('")" is missing from replacement function.');
 
412
    Result:=i+1;
429
413
  end;
430
414
 
431
 
  function CollectParams(aParams: TStringList): string;
432
 
  // Collect parameters from original call. Construct and return a new parameter list.
433
 
  //  aParams - parameters from the original function call.
 
415
  function InsertParams2Replacement(FuncInfo: TFuncReplacement): string;
 
416
  // Construct a new funcion call, inserting original parameters to replacement str.
 
417
  //  FuncInfo - Replacement string + parameters from the original function call.
434
418
  var
435
 
    Param: String;
436
 
    ParamPos: Integer;             // Position of parameter in the original call.
437
 
    i: Integer;
 
419
    RP: TReplacementParam;
 
420
    ss, se: String;
 
421
    i: integer;
438
422
  begin
439
 
    Result:='';
440
 
    for i:=0 to ParamList.Count-1 do begin
441
 
      ParamPos:=StrToInt(ParamList[i]);
442
 
      if ParamPos < 1 then
443
 
        raise EDelphiConverterError.Create('Replacement function parameter number should be >= 1.');
444
 
      Param:='nil';                // Default value if not found from original code.
445
 
      if ParamPos<=aParams.Count then
446
 
        Param:=aParams[ParamPos-1];
447
 
      if Result<>'' then
448
 
        Result:=Result+', ';
449
 
      Result:=Result+Param;
 
423
    Result:=FuncInfo.ReplFunc;
 
424
    for i:=ReplacementParams.Count-1 downto 0 do begin
 
425
      RP:=TReplacementParam(ReplacementParams[i]);
 
426
      if RP.ParamNum<=FuncInfo.Params.Count then begin
 
427
        ss:=copy(Result, 1, RP.StrPosition-1);        // String before the param
 
428
        se:=copy(Result, RP.StrPosition+RP.ParamLen, MaxInt); // and after it.
 
429
        Result:=ss+FuncInfo.Params[RP.ParamNum-1]+se;
 
430
      end;
450
431
    end;
451
432
  end;
452
433
 
463
444
    else begin
464
445
      CommChBeg:=PosEx('{', aStr, aPossibleStartPos);
465
446
      if CommChBeg<>0 then begin
466
 
      CommBeg:=CommChBeg+1;
 
447
        CommBeg:=CommChBeg+1;
467
448
        i:=PosEx('}', aStr, CommBeg);
468
449
        if i<>0 then
469
450
          CommEnd:=i-1;
470
451
      end;
471
452
    end;
472
 
    if CommChBeg<>0 then begin
473
 
      if BodyEnd=-1 then
474
 
        BodyEnd:=CommChBeg-1;
 
453
    if CommChBeg<>0 then
475
454
      Result:=Trim(Copy(aStr, CommBeg, CommEnd-CommBeg+1));
476
 
    end;
477
455
  end;
478
456
 
479
457
var
480
458
  FuncInfo: TFuncReplacement;
481
459
  PossibleCommentPos: Integer;               // Start looking for comments here.
482
460
  i: Integer;
483
 
  s, NewFunc, NewParamStr, Comment: String;
 
461
  s, NewFunc, Comment: String;
484
462
begin
485
463
  Result:=false;
486
 
  ParamList:=TStringList.Create;
 
464
  ReplacementParams:=TObjectList.Create;
487
465
  try
488
466
    // Replace from bottom to top.
489
467
    for i:=fFuncsToReplace.Count-1 downto 0 do begin
490
468
      FuncInfo:=TFuncReplacement(fFuncsToReplace[i]);
491
 
      BodyEnd:=-1;
492
 
      // Update ParamList.
 
469
      // Update ReplacementParams.
 
470
      ReplacementParams.Clear;
493
471
      PossibleCommentPos:=ParseReplacementParams(FuncInfo.ReplFunc);
494
472
      // Replace only if the params match somehow, so eg. a variable is not replaced.
495
 
      if (FuncInfo.Params.Count>0) or (ParamList.Count=0) then begin
496
 
        NewParamStr:=CollectParams(FuncInfo.Params);
 
473
      if (FuncInfo.Params.Count>0) or (ReplacementParams.Count=0) then begin
 
474
        NewFunc:=InsertParams2Replacement(FuncInfo);
497
475
        Comment:=GetComment(FuncInfo.ReplFunc, PossibleCommentPos);
498
476
        // Separate function body
499
 
        if BodyEnd=-1 then
500
 
          BodyEnd:=Length(FuncInfo.ReplFunc);
501
 
        NewFunc:=Trim(Copy(FuncInfo.ReplFunc, 1, BodyEnd));
502
 
        NewFunc:=Format('%s(%s)%s { *Converted from %s* %s }',
503
 
          [NewFunc, NewParamStr, FuncInfo.InclSemiColon, FuncInfo.FuncName, Comment]);
 
477
        NewFunc:=Format('%s%s { *Converted from %s* %s }',
 
478
          [NewFunc, FuncInfo.InclSemiColon, FuncInfo.FuncName, Comment]);
504
479
        // Old function call with params for IDE message output.
505
480
        s:=copy(fCTLink.CodeTool.Src, FuncInfo.StartPos, FuncInfo.EndPos-FuncInfo.StartPos);
506
 
        s:=StringReplace(s, sLineBreak, '', [rfReplaceAll]);
 
481
        s:=StringReplace(s, LineEnding, '', [rfReplaceAll]);
507
482
        // Now replace it.
508
483
        fCTLink.ResetMainScanner;
509
484
        if not fCTLink.SrcCache.Replace(gtNone, gtNone,
510
485
                            FuncInfo.StartPos, FuncInfo.EndPos, NewFunc) then exit;
511
486
        IDEMessagesWindow.AddMsg('Replaced call '+s, '', -1);
512
487
        IDEMessagesWindow.AddMsg('                  with '+NewFunc, '', -1);
 
488
        // Add the required unit name to uses section if needed.
 
489
        if Assigned(AddUnitEvent) and (FuncInfo.UnitName<>'') then
 
490
          AddUnitEvent(FuncInfo.UnitName);
513
491
      end;
514
492
    end;
515
493
  finally
516
 
    ParamList.Free;
 
494
    ReplacementParams.Free;
517
495
  end;
518
496
  Result:=true;
519
497
end;
574
552
              ReadNextAtom;
575
553
              if (CurPos.StartPos>SrcLen) or (CurPos.Flag=cafComma) then
576
554
                break;
577
 
              if (CurPos.Flag=cafRoundBracketOpen) then
 
555
              if CurPos.Flag=cafRoundBracketOpen then
578
556
                Inc(BracketCount)
579
 
              else if (CurPos.Flag=cafRoundBracketClose) then begin
 
557
              else if CurPos.Flag=cafRoundBracketClose then begin
580
558
                if BracketCount=0 then
581
559
                  break;
582
560
                Dec(BracketCount);
629
607
          and Assigned(ReplaceFuncs.Categories.Objects[x])
630
608
          // UTF8 funcs are in LCL which console apps don't have -> don't change.
631
609
          and not (aIsConsoleApp and (FuncDefInfo.Category='UTF8Names'))
 
610
          // Keep Windows funcs in a Windows application.
 
611
          and (fCTLink.Settings.MultiPlatform or (FuncDefInfo.Category<>'WindowsAPI'))
632
612
          then begin
633
613
            // Create a new replacement object for params, position and other info.
634
614
            FuncCallInfo:=TFuncReplacement.Create(FuncDefInfo);
747
727
    fDefinedProcNames.Duplicates:=dupIgnore;
748
728
    ActivateGlobalWriteLock;
749
729
    try
750
 
      BuildTree(false);
 
730
      BuildTree(lsrEnd);
751
731
      // Only convert identifiers in ctnBeginBlock nodes
752
732
      Node:=fCTLink.CodeTool.Tree.Root;
753
733
      while Node<>nil do begin
768
748
  Result:=true;
769
749
end;  // ReplaceFuncCalls
770
750
 
771
 
function TConvDelphiCodeTool.CheckTopOffsets(LFMBuf: TCodeBuffer; LFMTree: TLFMTree;
772
 
                     VisOffsets: TVisualOffsets; ValueNodes: TObjectList): boolean;
773
 
// Collect a list of coord attributes for components that are inside
774
 
//  a visual container component. An offset will be added to those attributes.
775
 
// Parameters: VisOffsets has names of parent container types.
776
 
//   ValueNodes - the found coord attributes are added here as TSrcPropOffset objects.
777
 
// Based on function CheckLFM.
778
 
var
779
 
  RootContext: TFindContext;
780
 
 
781
 
  function CheckLFMObjectValues(LFMObject: TLFMObjectNode;
782
 
    const ClassContext: TFindContext; GrandClassName: string): boolean; forward;
783
 
 
784
 
  function FindLFMIdentifier(LFMNode: TLFMTreeNode; const IdentName: string;
785
 
    const ClassContext: TFindContext; out IdentContext: TFindContext): boolean;
786
 
  var
787
 
    Params: TFindDeclarationParams;
788
 
    IsPublished: Boolean;
789
 
  begin
790
 
    Result:=false;
791
 
    IdentContext:=CleanFindContext;
792
 
    IsPublished:=false;
793
 
    if (ClassContext.Node=nil) or (not (ClassContext.Node.Desc in AllClasses)) then
794
 
      exit;
795
 
    Params:=TFindDeclarationParams.Create;
796
 
    try
797
 
      Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound,
798
 
                     fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
799
 
                     fdfIgnoreOverloadedProcs];
800
 
      Params.ContextNode:=ClassContext.Node;
801
 
      Params.SetIdentifier(ClassContext.Tool,PChar(Pointer(IdentName)),nil);
802
 
      try
803
 
        if ClassContext.Tool.FindIdentifierInContext(Params) then begin
804
 
          Result:=true;
805
 
          repeat
806
 
            IdentContext:=CreateFindContext(Params);
807
 
            if (not IsPublished)
808
 
            and (IdentContext.Node.HasParentOfType(ctnClassPublished)) then
809
 
              IsPublished:=true;
810
 
            if (IdentContext.Node<>nil)
811
 
            and (IdentContext.Node.Desc=ctnProperty)
812
 
            and (IdentContext.Tool.PropNodeIsTypeLess(IdentContext.Node)) then
813
 
            begin
814
 
              // this is a typeless property -> search further
815
 
              Params.Clear;
816
 
              Params.Flags:=[fdfSearchInAncestors, fdfIgnoreMissingParams,
817
 
                             fdfIgnoreCurContextNode, fdfIgnoreOverloadedProcs];
818
 
              Params.ContextNode:=IdentContext.Node.Parent;
819
 
              while (Params.ContextNode<>nil)
820
 
              and (not (Params.ContextNode.Desc in AllClasses)) do
821
 
                Params.ContextNode:=Params.ContextNode.Parent;
822
 
              if Params.ContextNode<>nil then begin
823
 
                Params.SetIdentifier(ClassContext.Tool,PChar(Pointer(IdentName)),nil);
824
 
                if not IdentContext.Tool.FindIdentifierInContext(Params) then
825
 
                  break;
826
 
              end;
827
 
            end else
828
 
              break;
829
 
          until false;
830
 
        end;
831
 
      except
832
 
        on E: ECodeToolError do ;        // ignore search/parse errors
833
 
      end;
834
 
    finally
835
 
      Params.Free;
836
 
    end;
837
 
  end;
838
 
 
839
 
  function FindClassNodeForLFMObject(LFMNode: TLFMTreeNode;
840
 
    StartTool: TFindDeclarationTool; DefinitionNode: TCodeTreeNode): TFindContext;
841
 
  var
842
 
    Params: TFindDeclarationParams;
843
 
    Identifier: PChar;
844
 
    OldInput: TFindDeclarationInput;
845
 
  begin
846
 
    Result:=CleanFindContext;
847
 
    if (DefinitionNode.Desc=ctnIdentifier) then
848
 
      Identifier:=@StartTool.Src[DefinitionNode.StartPos]
849
 
    else if DefinitionNode.Desc=ctnProperty then
850
 
      Identifier:=StartTool.GetPropertyTypeIdentifier(DefinitionNode)
851
 
    else
852
 
      Identifier:=nil;
853
 
    if Identifier=nil then exit;
854
 
    Params:=TFindDeclarationParams.Create;
855
 
    try
856
 
      Params.Flags:=[fdfSearchInAncestors, fdfExceptionOnNotFound,
857
 
                     fdfSearchInParentNodes, fdfExceptionOnPredefinedIdent,
858
 
                     fdfIgnoreMissingParams, fdfIgnoreOverloadedProcs];
859
 
      Params.ContextNode:=DefinitionNode;
860
 
      Params.SetIdentifier(StartTool,Identifier,nil);
861
 
      try
862
 
        Params.Save(OldInput);
863
 
        if StartTool.FindIdentifierInContext(Params) then begin
864
 
          Params.Load(OldInput,true);
865
 
          Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode);
866
 
          if (Result.Node=nil)
867
 
          or (not (Result.Node.Desc in AllClasses)) then
868
 
            Result:=CleanFindContext;
869
 
        end;
870
 
      except
871
 
        on E: ECodeToolError do ;        // ignore search/parse errors
872
 
      end;
873
 
    finally
874
 
      Params.Free;
875
 
    end;
876
 
  end;
877
 
 
878
 
  function FindClassContext(const ClassName: string): TFindContext;
879
 
  var
880
 
    Params: TFindDeclarationParams;
881
 
    Identifier: PChar;
882
 
    OldInput: TFindDeclarationInput;
883
 
    StartTool: TStandardCodeTool;
884
 
  begin
885
 
    Result:=CleanFindContext;
886
 
    Params:=TFindDeclarationParams.Create;
887
 
    StartTool:=fCTLink.CodeTool;
888
 
    Identifier:=PChar(Pointer(ClassName));
889
 
    try
890
 
      Params.Flags:=[fdfExceptionOnNotFound, fdfSearchInParentNodes,
891
 
                     fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
892
 
                     fdfIgnoreOverloadedProcs];
893
 
      with fCTLink.CodeTool do begin
894
 
        Params.ContextNode:=FindInterfaceNode;
895
 
        if Params.ContextNode=nil then
896
 
          Params.ContextNode:=FindMainUsesSection;
897
 
        Params.SetIdentifier(StartTool,Identifier,nil);
898
 
        try
899
 
          Params.Save(OldInput);
900
 
          if FindIdentifierInContext(Params) then begin
901
 
            Params.Load(OldInput,true);
902
 
            Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode);
903
 
            if (Result.Node=nil)
904
 
            or (not (Result.Node.Desc in AllClasses)) then
905
 
              Result:=CleanFindContext;
906
 
          end;
907
 
        except
908
 
          on E: ECodeToolError do ;          // ignore search/parse errors
909
 
        end;
910
 
      end;
911
 
    finally
912
 
      Params.Free;
913
 
    end;
914
 
  end;
915
 
 
916
 
  procedure CheckLFMChildObject(LFMObject: TLFMObjectNode; const ParentName: string);
917
 
  var
918
 
    VarTypeName: String;
919
 
    ChildContext: TFindContext;
920
 
    ClassContext: TFindContext;
921
 
    DefinitionNode: TCodeTreeNode;
922
 
  begin
923
 
    // find variable for object
924
 
    if LFMObject.Name='' then exit;
925
 
    if FindLFMIdentifier(LFMObject, LFMObject.Name, RootContext, ChildContext) then begin
926
 
      if ChildContext.Node=nil then exit;
927
 
      // check if identifier is a variable or property
928
 
      VarTypeName:='';
929
 
      if (ChildContext.Node.Desc=ctnVarDefinition) then begin
930
 
        DefinitionNode:=ChildContext.Tool.FindTypeNodeOfDefinition(ChildContext.Node);
931
 
        if DefinitionNode=nil then exit;
932
 
        VarTypeName:=ChildContext.Tool.ExtractDefinitionNodeType(ChildContext.Node);
933
 
      end else if (ChildContext.Node.Desc=ctnProperty) then begin
934
 
        DefinitionNode:=ChildContext.Node;
935
 
        VarTypeName:=ChildContext.Tool.ExtractPropType(ChildContext.Node,false,false);
936
 
      end else
937
 
        exit;
938
 
      // check if variable/property has a compatible type
939
 
      if (VarTypeName<>'') and (LFMObject.TypeName<>'')
940
 
          and (CompareIdentifiers(PChar(VarTypeName),
941
 
                                  PChar(LFMObject.TypeName))<>0) then  exit;
942
 
      // find class node
943
 
      ClassContext:=FindClassNodeForLFMObject(LFMObject, ChildContext.Tool, DefinitionNode);
944
 
    end else
945
 
      ClassContext:=FindClassContext(LFMObject.TypeName);  // try the object type
946
 
    // check child LFM nodes
947
 
    // ClassContext.Node=nil when the parent class is not found in source.
948
 
    if ClassContext.Node<>nil then
949
 
      CheckLFMObjectValues(LFMObject, ClassContext, ParentName);
950
 
  end;
951
 
 
952
 
  function FindClassNodeForPropertyType(LFMProperty: TLFMPropertyNode;
953
 
    const PropertyContext: TFindContext): TFindContext;
954
 
  var
955
 
    Params: TFindDeclarationParams;
956
 
  begin
957
 
    Result:=CleanFindContext;
958
 
    Params:=TFindDeclarationParams.Create;
959
 
    try
960
 
      Params.Flags:=[fdfSearchInAncestors,  fdfExceptionOnNotFound,
961
 
                     fdfSearchInParentNodes,fdfExceptionOnPredefinedIdent,
962
 
                     fdfIgnoreMissingParams,fdfIgnoreOverloadedProcs];
963
 
      Params.ContextNode:=PropertyContext.Node;
964
 
      Params.SetIdentifier(PropertyContext.Tool,nil,nil);
965
 
      try
966
 
        Result:=PropertyContext.Tool.FindBaseTypeOfNode(Params, PropertyContext.Node);
967
 
      except
968
 
        on E: ECodeToolError do ;              // ignore search/parse errors
969
 
      end;
970
 
    finally
971
 
      Params.Free;
972
 
    end;
973
 
  end;
974
 
 
975
 
  procedure CheckLFMProperty(LFMProperty: TLFMPropertyNode; const ParentContext: TFindContext;
976
 
    const GrandClassName, ParentClassName: string);
977
 
  // Check properties. Stores info about Top and Left properties for later adjustment.
978
 
  // Parameters: LFMProperty is the property node
979
 
  //   ParentContext is the context, where properties are searched (class or property).
980
 
  //   GrandClassName and ParentClassName are the class type names.
981
 
  var
982
 
    i, ind: Integer;
983
 
    ValNode: TLFMValueNode;
984
 
    CurName, Prop: string;
985
 
    CurPropContext: TFindContext;
986
 
    SearchContext: TFindContext;
987
 
  begin
988
 
    // find complete property name
989
 
    Prop:=LFMProperty.CompleteName;
990
 
    if Prop='' then exit;
991
 
    if (Prop='Top') or (Prop='Left') then begin
992
 
      if (GrandClassName<>'') and VisOffsets.Find(GrandClassName, ind) then begin
993
 
        if LFMProperty.FirstChild is TLFMValueNode then begin
994
 
          ValNode:=LFMProperty.FirstChild as TLFMValueNode;
995
 
          ValueNodes.Add(TSrcPropOffset.Create(GrandClassName,ParentClassName,
996
 
                                               Prop,ValNode.StartPos));
997
 
        end;
998
 
      end;
999
 
    end;
1000
 
    // find every part of the property name
1001
 
    SearchContext:=ParentContext;
1002
 
    for i:=0 to LFMProperty.NameParts.Count-1 do begin
1003
 
      if SearchContext.Node.Desc=ctnProperty then begin
1004
 
        // get the type of the property and search the class node
1005
 
        SearchContext:=FindClassNodeForPropertyType(LFMProperty, SearchContext);
1006
 
        if SearchContext.Node=nil then exit;
1007
 
      end;
1008
 
      CurName:=LFMProperty.NameParts.Names[i];
1009
 
      if not FindLFMIdentifier(LFMProperty, CurName, SearchContext, CurPropContext) then
1010
 
        break;
1011
 
      if CurPropContext.Node=nil then break;
1012
 
      SearchContext:=CurPropContext;
1013
 
    end;
1014
 
  end;
1015
 
 
1016
 
  function CheckLFMObjectValues(LFMObject: TLFMObjectNode;
1017
 
    const ClassContext: TFindContext; GrandClassName: string): boolean;
1018
 
  var
1019
 
    CurLFMNode: TLFMTreeNode;
1020
 
    ParentName: string;
1021
 
  begin
1022
 
    ParentName:=ClassContext.Tool.ExtractClassName(ClassContext.Node, False);
1023
 
    CurLFMNode:=LFMObject.FirstChild;
1024
 
    while CurLFMNode<>nil do begin
1025
 
      case CurLFMNode.TheType of
1026
 
      lfmnObject:
1027
 
        CheckLFMChildObject(TLFMObjectNode(CurLFMNode), ParentName);
1028
 
      lfmnProperty:
1029
 
        CheckLFMProperty(TLFMPropertyNode(CurLFMNode), ClassContext,
1030
 
                         GrandClassName, ParentName);
1031
 
      end;
1032
 
      CurLFMNode:=CurLFMNode.NextSibling;
1033
 
    end;
1034
 
    Result:=true;
1035
 
  end;
1036
 
 
1037
 
  function CheckLFMRoot(RootLFMNode: TLFMTreeNode): boolean;
1038
 
  var
1039
 
    LookupRootLFMNode: TLFMObjectNode;
1040
 
    LookupRootTypeName: String;
1041
 
    RootClassNode: TCodeTreeNode;
1042
 
  begin
1043
 
    Result:=false;
1044
 
    // get root object node
1045
 
    if (RootLFMNode=nil) or (not (RootLFMNode is TLFMObjectNode)) then exit;
1046
 
    LookupRootLFMNode:=TLFMObjectNode(RootLFMNode);
1047
 
 
1048
 
    // get type name of root object
1049
 
    LookupRootTypeName:=UpperCaseStr(LookupRootLFMNode.TypeName);
1050
 
    if LookupRootTypeName='' then exit;
1051
 
 
1052
 
    // find root type
1053
 
    RootClassNode:=fCTLink.CodeTool.FindClassNodeInUnit(LookupRootTypeName,
1054
 
                                                        true,false,false,false);
1055
 
    RootContext:=CleanFindContext;
1056
 
    RootContext.Node:=RootClassNode;
1057
 
    RootContext.Tool:=fCTLink.CodeTool;
1058
 
    if RootClassNode=nil then exit;
1059
 
    Result:=CheckLFMObjectValues(LookupRootLFMNode, RootContext, '');
1060
 
  end;
1061
 
 
1062
 
var
1063
 
  CurRootLFMNode: TLFMTreeNode;
1064
 
begin
1065
 
  Result:=false;
1066
 
  // create tree from LFM file
1067
 
  LFMTree:=DefaultLFMTrees.GetLFMTree(LFMBuf,true);
1068
 
  fCTLink.CodeTool.ActivateGlobalWriteLock;
1069
 
  try
1070
 
    if not LFMTree.ParseIfNeeded then exit;
1071
 
    // parse unit and find LookupRoot
1072
 
    fCTLink.CodeTool.BuildTree(true);
1073
 
    // find every identifier
1074
 
    CurRootLFMNode:=LFMTree.Root;
1075
 
    while CurRootLFMNode<>nil do begin
1076
 
      if not CheckLFMRoot(CurRootLFMNode) then exit;
1077
 
      CurRootLFMNode:=CurRootLFMNode.NextSibling;
1078
 
    end;
1079
 
  finally
1080
 
    fCTLink.CodeTool.DeactivateGlobalWriteLock;
1081
 
  end;
1082
 
  Result:=LFMTree.FirstError=nil;
1083
 
end;  // CheckTopOffsets
1084
 
 
1085
 
 
1086
751
end.
1087
752