1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Author: Mattias Gaertner
22
23 Abstract:
24 TStandardCodeTool enhances TIdentCompletionTool with many standard code
25 editing functions for the following categories:
26 - source name
27 - uses sections
28 - lazarus resources
29 - Application.CreateForm statements
30 - published variables
31 - resource strings
32 - compiler and IDE directives
33 - code exploring
34 - code blocks
35 }
36 unit StdCodeTools;
37
38 {$ifdef FPC}{$mode objfpc}{$endif}{$H+}
39
40 interface
41
42 {$I codetools.inc}
43
44 { $DEFINE VerboseGetStringConstBounds}
45 { $DEFINE VerboseCompleteBlock}
46 { $DEFINE VerboseCheckLFM}
47 { $DEFINE VerboseFindUnusedUnits}
48
49 uses
50 {$IFDEF MEM_CHECK}
51 MemCheck,
52 {$ENDIF}
53 Classes, SysUtils, TypInfo, Laz_AVL_Tree,
54 // Codetools
55 CodeToolsStrConsts, FileProcs, CodeTree, CodeAtom,
56 FindDeclarationTool, IdentCompletionTool, PascalReaderTool, PascalParserTool,
57 ExprEval, KeywordFuncLists, BasicCodeTools, LinkScanner,
58 CodeCache, LFMTrees, SourceChanger, CustomCodeTool, CodeToolsStructs,
59 // LazUtils
60 LazFileUtils, LazFileCache, AvgLvlTree;
61
62 type
63 TStandardCodeTool = class;
64
65 TInsertStatementPosDescription = class
66 public
67 InsertPos: integer;
68 Indent: integer;
69 CodeXYPos: TCodeXYPosition;
70 FrontGap, AfterGap: TGapTyp;
71 Description: string;
72 end;
73
74 TUsesSection = (usMain, usImplementation);
75
76 TOnFindDefinePropertyForContext = procedure(Sender: TObject;
77 const ClassContext, AncestorClassContext: TFindContext;
78 LFMNode: TLFMTreeNode;
79 const IdentName: string; var IsDefined: boolean) of object;
oolnull80 TOnIDEDirectiveFilter = function(Tool: TStandardCodeTool;
81 StartPos, EndPos: integer): boolean of object; // true = use
82
83 { TStandardCodeTool }
84
85 TStandardCodeTool = class(TIdentCompletionTool)
86 private
ReadTilGuessedUnclosedBlocknull87 function ReadTilGuessedUnclosedBlock(MinCleanPos: integer;
88 ReadOnlyOneBlock: boolean): boolean;
ReadForwardTilAnyBracketClosenull89 function ReadForwardTilAnyBracketClose: boolean;
ReadBackwardTilAnyBracketClosenull90 function ReadBackwardTilAnyBracketClose: boolean;
FindApplicationStatementnull91 function FindApplicationStatement(const APropertyUpCase: string;
92 out StartPos, ConstStartPos, EndPos: integer): boolean;
SetApplicationStatementnull93 function SetApplicationStatement(const APropertyName, NewCode: string;
94 SourceChangeCache: TSourceChangeCache): boolean;
RemoveApplicationStatementnull95 function RemoveApplicationStatement(const APropertyUpCase: string;
96 SourceChangeCache: TSourceChangeCache): boolean;
97 public
98 // explore the code
Explorenull99 function Explore(WithStatements: boolean; Range: TLinkScannerRange): boolean;
Explorenull100 function Explore(WithStatements: boolean;
101 OnlyInterface: boolean = false): boolean;
102
103 // source name e.g. 'unit UnitName;'
GetCachedSourceNamenull104 function GetCachedSourceName: string;
RenameSourcenull105 function RenameSource(const NewName: string;
106 SourceChangeCache: TSourceChangeCache): boolean;
107
108 // uses sections
RenameUsedUnitnull109 function RenameUsedUnit(const OldUnitName, NewUnitName,
110 NewUnitInFile: string;
111 SourceChangeCache: TSourceChangeCache): boolean;
ReplaceUsedUnitsnull112 function ReplaceUsedUnits(UnitNamePairs: TStringToStringTree; // ToDo: dotted
113 SourceChangeCache: TSourceChangeCache): boolean;
AddUnitToUsesSectionnull114 function AddUnitToUsesSection(UsesNode: TCodeTreeNode;
115 const NewUnitName, NewUnitInFile: string;
116 SourceChangeCache: TSourceChangeCache;
117 AsLast: boolean = false; CheckSpecialUnits: boolean = true): boolean;
AddUnitToSpecificUsesSectionnull118 function AddUnitToSpecificUsesSection(UsesSection: TUsesSection;
119 const NewUnitName, NewUnitInFile: string;
120 SourceChangeCache: TSourceChangeCache;
121 AsLast: boolean = false; CheckSpecialUnits: boolean = true): boolean;
AddUnitToMainUsesSectionnull122 function AddUnitToMainUsesSection(const NewUnitName, NewUnitInFile: string;
123 SourceChangeCache: TSourceChangeCache;
124 AsLast: boolean = false; CheckSpecialUnits: boolean = true): boolean;
AddUnitToImplementationUsesSectionnull125 function AddUnitToImplementationUsesSection(const NewUnitName,
126 NewUnitInFile: string;
127 SourceChangeCache: TSourceChangeCache;
128 AsLast: boolean = false; CheckSpecialUnits: boolean = true): boolean;
UnitExistsInUsesSectionnull129 function UnitExistsInUsesSection(UsesSection: TUsesSection;
130 const AnUnitName: string): boolean;
UnitExistsInUsesSectionnull131 function UnitExistsInUsesSection(UsesNode: TCodeTreeNode;
132 const AnUnitName: string): boolean;
RemoveUnitFromUsesSectionnull133 function RemoveUnitFromUsesSection(UsesNode: TCodeTreeNode;
134 const AnUnitName: string;
135 SourceChangeCache: TSourceChangeCache): boolean;
RemoveUnitFromAllUsesSectionsnull136 function RemoveUnitFromAllUsesSections(const AnUnitName: string;
137 SourceChangeCache: TSourceChangeCache): boolean;
FixUsedUnitCasenull138 function FixUsedUnitCase(SourceChangeCache: TSourceChangeCache): boolean;
FixUsedUnitCaseInUsesSectionnull139 function FixUsedUnitCaseInUsesSection(UsesNode: TCodeTreeNode;
140 SourceChangeCache: TSourceChangeCache): boolean;
FindUsedUnitNamesnull141 function FindUsedUnitNames(var MainUsesSection,
142 ImplementationUsesSection: TStrings): boolean;
FindUsedUnitNamesnull143 function FindUsedUnitNames(var List: TStringToStringTree): boolean;
FindUsedUnitFilesnull144 function FindUsedUnitFiles(var MainUsesSection: TStrings): boolean;
FindUsedUnitFilesnull145 function FindUsedUnitFiles(var MainUsesSection,
146 ImplementationUsesSection: TStrings): boolean;
FindDelphiProjectUnitsnull147 function FindDelphiProjectUnits(out FoundInUnits, MissingInUnits,
148 NormalUnits: TStrings;
149 UseContainsSection: boolean = false;
150 IgnoreNormalUnits: boolean = false): boolean;
UsesSectionToFilenamesnull151 function UsesSectionToFilenames(UsesNode: TCodeTreeNode): TStrings;
UsesSectionToUnitnamesnull152 function UsesSectionToUnitnames(UsesNode: TCodeTreeNode): TStrings;
FindMissingUnitsnull153 function FindMissingUnits(var MissingUnits: TStrings; FixCase: boolean;
154 SearchImplementation: boolean;
155 SourceChangeCache: TSourceChangeCache): boolean;
CommentUnitsInUsesSectionnull156 function CommentUnitsInUsesSection(MissingUnits: TStrings;
157 SourceChangeCache: TSourceChangeCache; UsesNode: TCodeTreeNode): boolean;
CommentUnitsInUsesSectionsnull158 function CommentUnitsInUsesSections(MissingUnits: TStrings;
159 SourceChangeCache: TSourceChangeCache): boolean;
FindUnusedUnitsnull160 function FindUnusedUnits(Units: TStrings): boolean;
161
162 // lazarus resources
FindNextIncludeInInitializationnull163 function FindNextIncludeInInitialization(
164 var LinkIndex: integer): TCodeBuffer;
FindLazarusResourceInBuffernull165 function FindLazarusResourceInBuffer(ResourceCode: TCodeBuffer;
166 const ResourceName: string): TAtomPosition;
FindLazarusResourcenull167 function FindLazarusResource(const ResourceName: string): TAtomPosition;
AddLazarusResourcenull168 function AddLazarusResource(ResourceCode: TCodeBuffer;
169 const ResourceName, ResourceData: string;
170 SourceChangeCache: TSourceChangeCache): boolean;
RemoveLazarusResourcenull171 function RemoveLazarusResource(ResourceCode: TCodeBuffer;
172 const ResourceName: string;
173 SourceChangeCache: TSourceChangeCache): boolean;
RenameIncludenull174 function RenameInclude(LinkIndex: integer; const NewFilename: string;
175 KeepPath: boolean;
176 SourceChangeCache: TSourceChangeCache): boolean;
CheckLFMnull177 function CheckLFM(LFMBuf: TCodeBuffer; out LFMTree: TLFMTree;
178 const OnFindDefineProperty: TOnFindDefinePropertyForContext;
179 RootMustBeClassInUnit: boolean; RootMustBeClassInIntf: boolean;
180 ObjectsMustExist: boolean): boolean;
181
182 // Application.Createform statements
FindCreateFormStatementnull183 function FindCreateFormStatement(StartPos: integer;
184 const AClassName, AVarName: string;
185 out Position: TAtomPosition): integer; // 0=found, -1=not found, 1=found, but wrong classname
AddCreateFormStatementnull186 function AddCreateFormStatement(const AClassName, AVarName: string;
187 SourceChangeCache: TSourceChangeCache): boolean;
RemoveCreateFormStatementnull188 function RemoveCreateFormStatement(const AVarName: string;
189 SourceChangeCache: TSourceChangeCache): boolean;
ChangeCreateFormStatementnull190 function ChangeCreateFormStatement(StartPos: integer;
191 const OldClassName, OldVarName: string;
192 const NewClassName, NewVarName: string;
193 OnlyIfExists: boolean;
194 SourceChangeCache: TSourceChangeCache): boolean;
ListAllCreateFormStatementsnull195 function ListAllCreateFormStatements: TStrings;
SetAllCreateFromStatementsnull196 function SetAllCreateFromStatements(List: TStrings;
197 SourceChangeCache: TSourceChangeCache): boolean;
198
199 // Application.Title:=<string const> statements
FindApplicationTitleStatementnull200 function FindApplicationTitleStatement(out StartPos, StringConstStartPos,
201 EndPos: integer): boolean;
GetApplicationTitleStatementnull202 function GetApplicationTitleStatement(StringConstStartPos, EndPos: integer;
203 var Title: string): boolean;
SetApplicationTitleStatementnull204 function SetApplicationTitleStatement(const NewTitle: string;
205 SourceChangeCache: TSourceChangeCache): boolean;
RemoveApplicationTitleStatementnull206 function RemoveApplicationTitleStatement(
207 SourceChangeCache: TSourceChangeCache): boolean;
208
209 // Application.Scaled:=<boolean const> statements
FindApplicationScaledStatementnull210 function FindApplicationScaledStatement(out StartPos, BooleanConstStartPos,
211 EndPos: integer): boolean;
GetApplicationScaledStatementnull212 function GetApplicationScaledStatement(BooleanConstStartPos, EndPos: integer;
213 var AScaled: boolean): boolean;
SetApplicationScaledStatementnull214 function SetApplicationScaledStatement(const NewScaled: boolean;
215 SourceChangeCache: TSourceChangeCache): boolean;
RemoveApplicationScaledStatementnull216 function RemoveApplicationScaledStatement(
217 SourceChangeCache: TSourceChangeCache): boolean;
218
219 // forms
RenameFormnull220 function RenameForm(const OldFormName, OldFormClassName: string;
221 const NewFormName, NewFormClassName: string;
222 SourceChangeCache: TSourceChangeCache): boolean;
FindFormAncestornull223 function FindFormAncestor(const AClassName: string;
224 var AncestorClassName: string): boolean;
225
226 // published variables
FindPublishedVariablenull227 function FindPublishedVariable(const AClassName, AVarName: string;
228 ExceptionOnClassNotFound: boolean): TCodeTreeNode;
AddPublishedVariablenull229 function AddPublishedVariable(const AClassName,VarName, VarType: string;
230 SourceChangeCache: TSourceChangeCache): boolean; virtual;
RemovePublishedVariablenull231 function RemovePublishedVariable(const AClassName, AVarName: string;
232 ExceptionOnClassNotFound: boolean;
233 SourceChangeCache: TSourceChangeCache): boolean;
RenamePublishedVariablenull234 function RenamePublishedVariable(const AClassName,
235 AOldVarName: string; const NewVarName, VarType: shortstring;
236 ExceptionOnClassNotFound: boolean;
237 SourceChangeCache: TSourceChangeCache): boolean;
GatherPublishedClassElementsnull238 function GatherPublishedClassElements(const TheClassName: string;
239 ExceptionOnClassNotFound, WithVariables, WithMethods,
240 WithProperties, WithAncestors: boolean;
241 out TreeOfCodeTreeNodeExtension: TAVLTree): boolean;
RetypeClassVariablesnull242 function RetypeClassVariables(const AClassName: string;
243 ListOfTypes: TStringToStringTree; ExceptionOnClassNotFound: boolean;
244 SourceChangeCache: TSourceChangeCache;
245 SearchImplementationToo: boolean = false): boolean;
FindDanglingComponentEventsnull246 function FindDanglingComponentEvents(const TheClassName: string;
247 RootComponent: TComponent; ExceptionOnClassNotFound,
248 SearchInAncestors: boolean;
249 out ListOfPInstancePropInfo: TFPList;
250 const OverrideGetMethodName: TOnGetMethodname = nil): boolean;
251
252 // variables, constants, types
RemoveIdentifierDefinitionnull253 function RemoveIdentifierDefinition(const CursorPos: TCodeXYPosition;
254 SourceChangeCache: TSourceChangeCache): boolean;
255
InsertStatementsnull256 function InsertStatements(InsertPos: TInsertStatementPosDescription;
257 Statements: string; SourceChangeCache: TSourceChangeCache): boolean;
InsertStatementsnull258 function InsertStatements(CleanPos: integer;
259 Statements: string; Indent: integer; FrontGap, AfterGap: TGapTyp;
260 SourceChangeCache: TSourceChangeCache): boolean;
261
262 // blocks (e.g. begin..end)
FindBlockCounterPartnull263 function FindBlockCounterPart(const CursorPos: TCodeXYPosition;
264 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindBlockStartnull265 function FindBlockStart(const CursorPos: TCodeXYPosition;
266 out NewPos: TCodeXYPosition; out NewTopLine: integer;
267 SkipStart: boolean = true): boolean;
GuessUnclosedBlocknull268 function GuessUnclosedBlock(const CursorPos: TCodeXYPosition;
269 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindBlockCleanBoundsnull270 function FindBlockCleanBounds(const CursorPos: TCodeXYPosition;
271 out BlockCleanStart, BlockCleanEnd: integer): boolean;
CompleteBlocknull272 function CompleteBlock(const CursorPos: TCodeXYPosition;
273 SourceChangeCache: TSourceChangeCache;
274 OnlyIfCursorBlockIndented: boolean;
275 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
276
277 // compiler directives
GuessMisplacedIfdefEndifnull278 function GuessMisplacedIfdefEndif(const CursorPos: TCodeXYPosition;
279 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindEnclosingIncludeDirectivenull280 function FindEnclosingIncludeDirective(const CursorPos: TCodeXYPosition;
281 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindModeDirectivenull282 function FindModeDirective(DoBuildTree: boolean;
283 out ACleanPos: integer): boolean;
FindResourceDirectivenull284 function FindResourceDirective(DoBuildTree: boolean;
285 var ACleanPos: integer; const Filename: string = ''): boolean;
FindResourceDirectivenull286 function FindResourceDirective(const CursorPos: TCodeXYPosition;
287 out NewPos: TCodeXYPosition; out NewTopLine: integer;
288 const Filename: string = ''): boolean;
AddResourceDirectivenull289 function AddResourceDirective(const Filename: string;
290 SourceChangeCache: TSourceChangeCache; const NewSrc: string = ''
291 ): boolean;
FindIncludeDirectivenull292 function FindIncludeDirective(DoBuildTree: boolean;
293 var ACleanPos: integer; const Filename: string = ''): boolean;
FindIncludeDirectivenull294 function FindIncludeDirective(const CursorPos: TCodeXYPosition;
295 out NewPos: TCodeXYPosition; out NewTopLine: integer;
296 const Filename: string = ''): boolean;
AddIncludeDirectiveForInitnull297 function AddIncludeDirectiveForInit(const Filename: string;
298 SourceChangeCache: TSourceChangeCache; const NewSrc: string = ''
299 ): boolean;
AddUnitWarnDirectivenull300 function AddUnitWarnDirective(WarnID, Comment: string; TurnOn: boolean;
301 SourceChangeCache: TSourceChangeCache): boolean;
FixIncludeFilenamesnull302 function FixIncludeFilenames(Code: TCodeBuffer;
303 SourceChangeCache: TSourceChangeCache;
304 out FoundIncludeFiles: TStrings;
305 var MissingIncludeFilesCodeXYPos: TFPList): boolean;
306
307 // search & replace
ReplaceWordsnull308 function ReplaceWords(IdentList: TStrings; ChangeStrings: boolean;
309 SourceChangeCache: TSourceChangeCache;
310 SkipPointWords: boolean = false): boolean;
FindNearestIdentifierNodenull311 function FindNearestIdentifierNode(const CursorPos: TCodeXYPosition;
312 IdentTree: TAVLTree): TAVLTreeNode;
ReplaceWordnull313 function ReplaceWord(const OldWord, NewWord: string; ChangeStrings: boolean;
314 SourceChangeCache: TSourceChangeCache;
315 SkipPointWords: boolean = false): boolean;
316
317 // comments
CommentCodenull318 function CommentCode(const StartPos, EndPos: integer;
319 SourceChangeCache: TSourceChangeCache; Apply: boolean): boolean;
320
321 // expressions
GetStringConstBoundsnull322 function GetStringConstBounds(const CursorPos: TCodeXYPosition;
323 out StartPos, EndPos: TCodeXYPosition;
324 ResolveComments: boolean): boolean;
GetStringConstAsFormatStringnull325 function GetStringConstAsFormatString(StartPos, EndPos: integer;
326 out FormatStringConstant, FormatParameters: string;
327 out StartInStringConst, EndInStringConst: boolean): boolean;
GetStringConstAsFormatStringnull328 function GetStringConstAsFormatString(StartPos, EndPos: integer;
329 out FormatStringConstant, FormatParameters: string): boolean;
ExtractOperandnull330 function ExtractOperand(const CursorPos: TCodeXYPosition;
331 out Operand: string; WithPostTokens, WithAsOperator,
332 WithoutTrailingPoints: boolean): boolean;
333
334 // resource strings
GatherResourceStringSectionsnull335 function GatherResourceStringSections(const CursorPos: TCodeXYPosition;
336 PositionList: TCodeXYPositions): boolean;
IdentifierExistsInResourceStringSectionnull337 function IdentifierExistsInResourceStringSection(
338 const CursorPos: TCodeXYPosition;
339 const ResStrIdentifier: string): boolean;
GatherResourceStringsWithValuenull340 function GatherResourceStringsWithValue(const CursorPos: TCodeXYPosition;
341 const StringValue: string;
342 PositionList: TCodeXYPositions): boolean;
GatherResourceStringIdentsnull343 function GatherResourceStringIdents(const SectionPos: TCodeXYPosition;
344 var IdentTree: TAVLTree): boolean;
FindNearestResourceStringnull345 function FindNearestResourceString(const CursorPos,
346 SectionPos: TCodeXYPosition;
347 var NearestPos: TCodeXYPosition): boolean;
AddResourceStringnull348 function AddResourceString(const SectionPos: TCodeXYPosition;
349 const NewIdentifier, NewValue: string;
350 InsertPolicy: TResourcestringInsertPolicy;
351 const NearestPos: TCodeXYPosition;
352 SourceChangeCache: TSourceChangeCache): boolean;
CreateIdentifierFromStringConstnull353 function CreateIdentifierFromStringConst(
354 const StartCursorPos, EndCursorPos: TCodeXYPosition;
355 out Identifier: string; MaxLen: integer): boolean;
StringConstToFormatStringnull356 function StringConstToFormatString(
357 const StartCursorPos, EndCursorPos: TCodeXYPosition;
358 out FormatStringConstant,FormatParameters: string;
359 out StartInStringConst, EndInStringConst: boolean): boolean;
360
361 // register procedure
362 function HasInterfaceRegisterProc(out HasRegisterProc: boolean): boolean;
363
364 // Delphi to Lazarus conversion
ConvertDelphiToLazarusSourcenull365 function ConvertDelphiToLazarusSource(AddLRSCode: boolean;
366 SourceChangeCache: TSourceChangeCache): boolean;
367
368 // IDE % directives
GetIDEDirectivesnull369 function GetIDEDirectives(DirectiveList: TStrings;
370 const Filter: TOnIDEDirectiveFilter = nil): boolean;
SetIDEDirectivesnull371 function SetIDEDirectives(DirectiveList: TStrings;
372 SourceChangeCache: TSourceChangeCache;
373 const Filter: TOnIDEDirectiveFilter = nil): boolean;
374
375 procedure CalcMemSize(Stats: TCTMemStats); override;
376 end;
377
378
379 implementation
380
381
382 type
383 TBlockKeyword = (bkwNone, bkwBegin, bkwAsm, bkwTry, bkwCase, bkwRepeat,
384 bkwRecord, bkwClass, bkwObject, bkwInterface,
385 bkwDispInterface, bkwEnd, bkwUntil, bkwFinally,
386 bkwExcept);
387
388 const
389 BlockKeywords: array[TBlockKeyword] of string = (
390 '(unknown)', 'BEGIN', 'ASM', 'TRY', 'CASE', 'REPEAT', 'RECORD', 'CLASS',
391 'OBJECT', 'INTERFACE', 'DISPINTERFACE', 'END', 'UNTIL', 'FINALLY',
392 'EXCEPT'
393 );
394
395 var
396 BlockKeywordFuncList: TKeyWordFunctionList;
397
398 procedure BuildBlockKeyWordFuncList;
399 var BlockWord: TBlockKeyword;
400 begin
401 if BlockKeywordFuncList=nil then begin
402 BlockKeywordFuncList:=TKeyWordFunctionList.Create('StdCodeTools.BlockKeywordFuncList');
403 for BlockWord:=Low(TBlockKeyword) to High(TBlockKeyword) do
404 with BlockKeywordFuncList do
405 Add(BlockKeywords[BlockWord],{$ifdef FPC}@{$endif}AllwaysTrue);
406 end;
407 end;
408
409
410 { TStandardCodeTool }
411
412 {-------------------------------------------------------------------------------
413 function TStandardCodeTool.GetCachedSourceName: string;
414 Params: none
415 Result: the source name (= e.g. the identifier behind 'program'/'unit' keyword)
416
417 This function does neither check if source needs reparsing, nor does it check
418 for errors in code. It simple checks if there is a first node, which is
419 typically the source type and name.
420 This function can therefore be used as a fast GetSourceName function.
421 -------------------------------------------------------------------------------}
GetCachedSourceNamenull422 function TStandardCodeTool.GetCachedSourceName: string;
423 begin
424 Result:=GetSourceName(false);
425 end;
426
RenameSourcenull427 function TStandardCodeTool.RenameSource(const NewName: string;
428 SourceChangeCache: TSourceChangeCache): boolean;
429 var NamePos: TAtomPosition;
430 begin
431 Result:=false;
432 BuildTree(lsrSourceName);
433 //debugln(['TStandardCodeTool.RenameSource NewName=',NewName]);
434 if (not GetSourceNamePos(NamePos)) or (NamePos.StartPos<1) or (NewName='')
435 or (Length(NewName)>255) then exit;
436 //debugln(['TStandardCodeTool.RenameSource OldName="',dbgstr(copy(Src,NamePos.StartPos,NamePos.EndPos-NamePos.StartPos)),'"']);
437 SourceChangeCache.MainScanner:=Scanner;
438 SourceChangeCache.Replace(gtNone,gtNone,NamePos.StartPos,NamePos.EndPos,
439 NewName);
440 if not SourceChangeCache.Apply then exit;
441 CachedSourceName:=NewName;
442 Result:=true;
443 end;
444
TStandardCodeTool.RenameUsedUnitnull445 function TStandardCodeTool.RenameUsedUnit(const OldUnitName,
446 NewUnitName, NewUnitInFile: string;
447 SourceChangeCache: TSourceChangeCache): boolean;
448 var UnitPos, InPos: TAtomPosition;
449 NewUsesTerm: string;
450 begin
451 Result:=false;
452 if (not IsDottedIdentifier(OldUnitName))
453 or (not IsDottedIdentifier(NewUnitName)) then
454 exit;
455 if not FindUnitInAllUsesSections(OldUnitName,UnitPos,InPos) then begin
456 //debugln('TStandardCodeTool.RenameUsedUnit not found: ',OldUnitName,' ');
457 exit;
458 end;
459 SourceChangeCache.MainScanner:=Scanner;
460 if InPos.StartPos>0 then
461 UnitPos.EndPos:=InPos.EndPos;
462 // build use unit term
463 NewUsesTerm:=NewUnitName;
464 if NewUnitInFile<>'' then
465 NewUsesTerm:=NewUsesTerm+' in '''+NewUnitInFile+'''';
466 // Note: do not use beautifier, unit names are case sensitive
467 if ReplacementNeedsLineEnd(Src,UnitPos.StartPos,UnitPos.EndPos,
468 length(NewUsesTerm),SourceChangeCache.BeautifyCodeOptions.LineLength) then
469 begin
470 if not SourceChangeCache.Replace(gtNewLine,gtNone,
471 UnitPos.StartPos,UnitPos.EndPos,NewUsesTerm) then exit;
472 end else begin
473 if not SourceChangeCache.Replace(gtSpace,gtNone,
474 UnitPos.StartPos,UnitPos.EndPos,NewUsesTerm) then exit;
475 end;
476 if not SourceChangeCache.Apply then exit;
477 Result:=true;
478 end;
479
ReplaceUsedUnitsnull480 function TStandardCodeTool.ReplaceUsedUnits(UnitNamePairs: TStringToStringTree;
481 SourceChangeCache: TSourceChangeCache): boolean;
482 var
483 ExistingUnits: TStringToStringTree;
484
485 procedure CleanNewUnits(const AnUnitName: string; var NewText: string);
486 var
487 StartPos: Integer;
488 EndPos: LongInt;
489 CommaBehind: LongInt;
490 CommaInFront: Integer;
491 NewUnitName: String;
492 begin
493 // remove all units, that already exists
494 StartPos:=1;
495 CommaInFront:=-1;
496 while StartPos<=length(NewText) do begin
497 EndPos:=StartPos;
498 while (EndPos<=length(NewText)) and (IsIdentChar[NewText[EndPos]]) do
499 inc(EndPos);
500 if EndPos<=StartPos then break;
501 NewUnitName:=copy(NewText,StartPos,EndPos-StartPos);
502 // set EndPos to start of next unit
503 CommaBehind:=-1;
504 while (EndPos<=length(NewText)) do begin
505 if NewText[EndPos]='''' then begin
506 inc(EndPos);
507 while (EndPos<=length(NewText)) and (NewText[EndPos]<>'''') do
508 inc(EndPos);
509 end else if NewText[EndPos]=',' then begin
510 CommaBehind:=EndPos;
511 while (EndPos<=length(NewText))
512 and (not IsIdentStartChar[NewText[EndPos]]) do
513 inc(EndPos);
514 break;
515 end;
516 inc(EndPos);
517 end;
518 if (SysUtils.CompareText(AnUnitName,NewUnitName)=0) then begin
519 // this is the old unit or
520 //DebugLn('Replace: keep old unit "',NewUnitName,'"');
521 end else if ExistingUnits.Contains(NewUnitName) then begin
522 // this unit already exists and should not be added
523 //DebugLn('Replace: already exists: "',NewUnitName,'"="',ExistingUnits[NewUnitName],'" CommaInFront=',dbgs(CommaInFront),' CommaBehind=',dbgs(CommaBehind));
524 if CommaBehind>0 then
525 System.Delete(NewText,StartPos,EndPos-StartPos)
526 else if CommaInFront>0 then
527 System.Delete(NewText,CommaInFront,EndPos-CommaInFront)
528 else
529 System.Delete(NewText,StartPos,EndPos-StartPos);
530 EndPos:=StartPos;
531 CommaBehind:=-1;
532 end else begin
533 // this unit does not exist yet
534 //DebugLn('Replace new unit with "',NewUnitName,'"');
535 end;
536 if CommaBehind>0 then
537 CommaInFront:=CommaBehind;
538 StartPos:=EndPos;
539 end;
540 end;
541
Replacenull542 function Replace(UsesNode: TCodeTreeNode): boolean;
543 var
544 UnitNameAtom: TAtomPosition;
545 InAtom: TAtomPosition;
546 NewText: string;
547 CommaInFront: LongInt;
548 FromPos: LongInt;
549 ToPos: LongInt;
550 CommaBehind: Integer;
551 AnUnitName: String;
552 begin
553 if UsesNode=nil then exit(true);
554 MoveCursorToUsesStart(UsesNode);
555 CommaInFront:=-1;
556 repeat
557 // read next unit name
558 ReadNextUsedUnit(UnitNameAtom, InAtom);
559 if CurPos.Flag=cafComma then
560 CommaBehind:=CurPos.StartPos
561 else
562 CommaBehind:=-1;
563 AnUnitName:=GetAtom(UnitNameAtom);
564 if UnitNamePairs.Contains(AnUnitName) then begin
565 // replace
566 NewText:=UnitNamePairs[AnUnitName];
567 //DebugLn('Replace Unit="',AnUnitName,'" NewText="',NewText,'"');
568
569 CleanNewUnits(AnUnitName,NewText);
570
571 if NewText='' then begin
572 // comment unit
573 if CommaInFront>0 then begin
574 // example: uses a{, b};
575 FromPos:=CommaInFront;
576 ToPos:=UnitNameAtom.EndPos;
577 if InAtom.StartPos>0 then
578 ToPos:=InAtom.EndPos;
579 end else if CommaBehind>0 then begin
580 // example: uses {a,} b;
581 // uses {a,} {b};
582 FromPos:=UnitNameAtom.StartPos;
583 ToPos:=CommaBehind+1;
584 end else begin
585 // examples: uses {b};
586 FromPos:=UnitNameAtom.StartPos;
587 ToPos:=UnitNameAtom.EndPos;
588 if InAtom.StartPos>0 then
589 ToPos:=InAtom.EndPos;
590 end;
591 if not CommentCode(FromPos,ToPos,SourceChangeCache,false) then
592 exit(false);
593 end else begin
594 // replace
595 FromPos:=UnitNameAtom.StartPos;
596 ToPos:=UnitNameAtom.EndPos;
597 if InAtom.StartPos>0 then
598 ToPos:=InAtom.EndPos;
599 if not SourceChangeCache.Replace(gtNone,gtNone,FromPos,ToPos,NewText)
600 then exit(false);
601 end;
602 end;
603
604 if CurPos.Flag=cafComma then begin
605 // read next unit name
606 CommaInFront:=CurPos.StartPos;
607 ReadNextAtom;
608 end else if CurPos.Flag=cafSemicolon then begin
609 break;
610 end else
611 RaiseExceptionFmt(20170421201056,ctsStrExpectedButAtomFound,[';',GetAtom]);
612 until false;
613 Result:=true;
614 end;
615
616 begin
617 Result:=false;
618 BuildTree(lsrImplementationUsesSectionEnd);
619 SourceChangeCache.MainScanner:=Scanner;
620 ExistingUnits:=nil;
621 try
622 // first collect all units
623 if not FindUsedUnitNames(ExistingUnits) then exit;
624 // then change uses sections
625 Replace(FindMainUsesNode);
626 Replace(FindImplementationUsesNode);
627 finally
628 ExistingUnits.Free;
629 end;
630 Result:=SourceChangeCache.Apply;
631 end;
632
TStandardCodeTool.AddUnitToUsesSectionnull633 function TStandardCodeTool.AddUnitToUsesSection(UsesNode: TCodeTreeNode;
634 const NewUnitName, NewUnitInFile: string;
635 SourceChangeCache: TSourceChangeCache; AsLast: boolean;
636 CheckSpecialUnits: boolean): boolean;
637 const
638 SpecialUnits: array[1..5] of string = (
639 'cmem',
640 'sharedmem',
641 'lineinfo',
642 'heaptrc',
643 'cthreads'
644 );
645 var
646 Beauty: TBeautifyCodeOptions;
647
SpecialUnitPrioritynull648 function SpecialUnitPriority(Identifier: PChar): integer;
649 begin
650 Result:=Low(SpecialUnits);
651 while Result<=High(SpecialUnits) do begin
652 if CompareIdentifierPtrs(Pointer(Identifier),Pointer(SpecialUnits[Result]))=0 then
653 exit;
654 inc(Result);
655 end;
656 end;
657
NextUseUnitNodeInSameBlocknull658 function NextUseUnitNodeInSameBlock(Node: TCodeTreeNode): boolean;
659 var
660 p: LongInt;
661 begin
662 if Node.NextBrother=nil then exit(false);
663 if PositionsInSameLine(Src,Node.EndPos,Node.NextBrother.StartPos) then
664 begin
665 // uses on same line belongs to the same formatting block
666 exit(true);
667 end;
668 // check that there is no comment/directive between
669 p:=FindPrevNonSpace(Src,Node.NextBrother.StartPos-1);
670 if Src[p]<>',' then exit(false);
671 p:=FindPrevNonSpace(Src,p-1);
672 if p>Node.EndPos then exit(false);
673 if LineEndCount(Src,Node.EndPos,Node.NextBrother.StartPos,p)>1 then exit(false);
674 Result:=true;
675 end;
676
677 procedure AddUseUnit(Lines: TStrings; FirstIndent, Indent: integer;
678 const NewUses: string);
679 var
680 Line: string;
681 l: Integer;
682 begin
683 if Lines.Count=0 then begin
684 Lines.Add(NewUses);
685 exit;
686 end;
687 Line:=Lines[Lines.Count-1];
688 if (atIdentifier in Beauty.DoInsertSpaceAfter)
689 or (atComma in Beauty.DoInsertSpaceInFront) then
690 Line:=Line+' ';
691 Line:=Line+',';
692 l:=length(Line)+length(NewUses)+1; // +1 for the following , or ;
693 if (atComma in Beauty.DoInsertSpaceAfter)
694 or (atIdentifier in Beauty.DoInsertSpaceInFront) then
695 inc(l);
696 if Lines.Count=1 then
697 inc(l,FirstIndent);
698 //DebugLn(['AddUseUnit Lines.Count=',Lines.Count,' l=',l,' Line="',Line,'" NewUses=',NewUses,' FirstIndent=',FirstIndent]);
699 if l<=Beauty.LineLength then begin
700 // append to last line
701 if (atComma in Beauty.DoInsertSpaceAfter)
702 or (atIdentifier in Beauty.DoInsertSpaceInFront) then
703 Line:=Line+' ';
704 Line:=Line+NewUses;
705 Lines[Lines.Count-1]:=Line;
706 end else begin
707 // add new line
708 Lines[Lines.Count-1]:=Line;
709 Line:=Beauty.GetIndentStr(Indent)+NewUses;
710 Lines.Add(Line);
711 end;
712 end;
713
714 var
715 LineStart, LineEnd, Indent, InsertPos, InsertToPos, InsertLen: integer;
716 NewUsesTerm: string;
717 InsertBehind: Boolean;
718 InsertNode: TCodeTreeNode;
719 Node: TCodeTreeNode;
720 NewCode: TCodeBuffer;
721 DiffPath: String;
722 DiffCnt: Integer;
723 BestDiffCnt: LongInt;
724 AnUnitName: String;
725 AnUnitInFilename: String;
726 i: Integer;
727 NewFilename: String;
728 NewComma: string;
729 Lines: TStringList;
730 FirstIndent: Integer;
731 InsertCode: String;
732 UsesInsertPolicy: TUsesInsertPolicy;
733 Prio: LongInt;
734 FirstNormalUsesNode: TCodeTreeNode;
735 InsertPosFound: Boolean;
736 begin
737 Result:=false;
738 if (UsesNode=nil) or (UsesNode.Desc<>ctnUsesSection)
739 or (UsesNode.StartPos<1) or (UsesNode.EndPos<1)
740 or (not IsDottedIdentifier(NewUnitName))
741 then exit;
742 SourceChangeCache.MainScanner:=Scanner;
743 Beauty:=SourceChangeCache.BeautifyCodeOptions;
744
745 // find nice insert position
746
747 Prio:=SpecialUnitPriority(PChar(NewUnitName));
748 UsesInsertPolicy:=Beauty.UsesInsertPolicy;
749 if AsLast then
750 UsesInsertPolicy:=uipLast;
751 InsertPosFound:=false;
752 if CheckSpecialUnits and (Prio<=High(SpecialUnits)) then begin
753 // this is a special unit, insert at the beginning
754 InsertBehind:=false;
755 InsertNode:=UsesNode.FirstChild;
756 while (InsertNode<>nil)
757 and (Prio>SpecialUnitPriority(@Src[InsertNode.StartPos])) do
758 InsertNode:=InsertNode.NextBrother;
759 InsertPosFound:=true;
760 if InsertNode=nil then begin
761 InsertBehind:=true;
762 InsertNode:=UsesNode.LastChild;
763 end;
764 end;
765 if not InsertPosFound then begin
766 FirstNormalUsesNode:=UsesNode.FirstChild;
767 if CheckSpecialUnits and (UsesInsertPolicy<>uipLast) then begin
768 while (FirstNormalUsesNode<>nil)
769 and (SpecialUnitPriority(@Src[FirstNormalUsesNode.StartPos])<Prio) do
770 FirstNormalUsesNode:=FirstNormalUsesNode.NextBrother;
771 if FirstNormalUsesNode=nil then
772 UsesInsertPolicy:=uipLast;
773 end;
774
775 case UsesInsertPolicy of
776
777 uipFirst:
778 begin
779 InsertBehind:=false;
780 InsertNode:=FirstNormalUsesNode;
781 end;
782
783 uipInFrontOfRelated,uipBehindRelated:
784 begin
785 if UsesInsertPolicy=uipBehindRelated then begin
786 InsertNode:=UsesNode.LastChild;
787 InsertBehind:=true;
788 end else begin
789 InsertBehind:=false;
790 InsertNode:=FirstNormalUsesNode;
791 end;
792 NewCode:=FindUnitSource(NewUnitName,'',false);
793 if NewCode<>nil then begin
794 NewFilename:=NewCode.Filename;
795 BestDiffCnt:=High(integer);
796 Node:=FirstNormalUsesNode;
797 while Node<>nil do begin
798 AnUnitName:=ExtractUsedUnitName(Node,@AnUnitInFilename);
799 // search unit
800 //DebugLn(['TStandardCodeTool.AddUnitToUsesSection Unit=',AnUnitName,' in "',AnUnitInFilename,'"']);
801 NewCode:=FindUnitSource(AnUnitName,AnUnitInFilename,false);
802 if NewCode<>nil then begin
803 // used unit found -> compute distance
804 DiffPath:=CreateRelativePath(NewCode.Filename,ExtractFilePath(NewFilename));
805 DiffCnt:=0;
806 for i:=1 to length(DiffPath) do
807 if DiffPath[i]=PathDelim then
808 inc(DiffCnt);
809 //DebugLn(['TStandardCodeTool.AddUnitToUsesSection DiffCnt=',DiffCnt,' "',NewCode.Filename,'" "',NewFilename,'"']);
810 if UsesInsertPolicy=uipInFrontOfRelated then begin
811 // insert in front of the first node with the lowest DiffCnt
812 if BestDiffCnt>DiffCnt then begin
813 BestDiffCnt:=DiffCnt;
814 InsertNode:=Node;
815 InsertBehind:=false;
816 end;
817 end else begin
818 // insert behind the last node with the lowest DiffCnt
819 if BestDiffCnt>=DiffCnt then begin
820 BestDiffCnt:=DiffCnt;
821 InsertNode:=Node;
822 InsertBehind:=true;
823 end;
824 end;
825 end;
826 Node:=Node.NextBrother;
827 end;
828 end;
829 end;
830
831 uipLast:
832 begin
833 InsertNode:=UsesNode.LastChild;
834 InsertBehind:=true;
835 end;
836
837 uipAlphabetically:
838 begin
839 InsertNode:=FirstNormalUsesNode;
840 InsertBehind:=false;
841 while (InsertNode<>nil)
842 and (CompareIdentifiers(PChar(NewUnitName),@Src[InsertNode.StartPos])<0) do
843 InsertNode:=InsertNode.NextBrother;
844 if InsertNode=nil then begin
845 InsertNode:=UsesNode.LastChild;
846 InsertBehind:=true;
847 end;
848 end;
849
850 end;
851 end;
852
853 // build insert text "newunitname in 'file'"
854 NewUsesTerm:=NewUnitName;
855 if NewUnitInFile<>'' then
856 NewUsesTerm:=NewUsesTerm+' '
857 +Beauty.BeautifyKeyWord('in')
858 +' '''+NewUnitInFile+'''';
859
860 NewComma:=',';
861 if (atComma in Beauty.DoInsertSpaceInFront)
862 or (atIdentifier in Beauty.DoInsertSpaceAfter)
863 then
864 NewComma:=' '+NewComma;
865 if (atComma in Beauty.DoInsertSpaceAfter)
866 or (atIdentifier in Beauty.DoInsertSpaceInFront)
867 then
868 NewComma:=NewComma+' ';
869
870 if InsertBehind then begin
871 // insert behind unit name, in front of semicolon or comma
872 // for example: uses unit1|, unit2 in 'unit2.pp'|;
873 InsertPos:=InsertNode.EndPos;
874 InsertCode:=NewComma+NewUsesTerm;
875 end else begin
876 // insert in front of unit name, behind 'uses' or comma
877 // for example: uses |unit1, |unit2;
878 InsertPos:=InsertNode.StartPos;
879 InsertCode:=NewUsesTerm+NewComma;
880 end;
881 InsertToPos:=InsertPos;
882
883 //DebugLn(['TStandardCodeTool.AddUnitToUsesSection InsertNode=',ExtractNode(InsertNode,[]),' InsertBehind=',InsertBehind]);
884
885 // check if addition fits into the line
886 // if not, rebuild the uses section
887 GetLineStartEndAtPosition(Src,InsertPos,LineStart,LineEnd);
888 InsertLen:=length(NewUsesTerm)+length(NewComma);
889 //DebugLn(['TStandardCodeTool.AddUnitToUsesSection Line=',copy(Src,LineStart,InsertPos-LineStart),'<InsertPos>',copy(Src,InsertPos,LineEnd-InsertPos),' NewLen=',LineEnd-LineStart+InsertLen,' Max=',Beauty.LineLength,' Addition=',NewUsesTerm]);
890 if (LineEnd-LineStart+InsertLen > Beauty.LineLength) then begin
891 // line too long => reformat block of used units
892 // find start of block of used units
893 Node:=InsertNode;
894 while (Node.PriorBrother<>nil)
895 and NextUseUnitNodeInSameBlock(Node.PriorBrother) do
896 Node:=Node.PriorBrother;
897 InsertPos:=Node.StartPos;
898 GetLineStartEndAtPosition(Src,InsertPos,LineStart,LineEnd);
899 FirstIndent:=InsertPos-LineStart;
900 Indent:=Beauty.GetLineIndent(Src,InsertPos);
901 if PositionsInSameLine(Src,UsesNode.StartPos,InsertPos) then begin
902 // for example: uses |unit1;
903 inc(Indent,Beauty.Indent);
904 end;
905 // create new block of used units
906 Lines:=TStringList.Create;
907 try
908 while Node<>nil do begin
909 InsertToPos:=Node.EndPos;
910 if (Node=InsertNode) and (not InsertBehind) then
911 AddUseUnit(Lines,FirstIndent,Indent,NewUsesTerm);
912 InsertCode:=ExtractUsedUnitName(Node);
913 if UpAtomIs('IN') then begin
914 ReadNextAtom;
915 InsertCode:=InsertCode+' '+Beauty.BeautifyKeyWord('in')+' '+GetAtom;
916 end;
917 AddUseUnit(Lines,FirstIndent,Indent,InsertCode);
918 if (Node=InsertNode) and InsertBehind then
919 AddUseUnit(Lines,FirstIndent,Indent,NewUsesTerm);
920 if not NextUseUnitNodeInSameBlock(Node) then break;
921 Node:=Node.NextBrother;
922 end;
923 InsertCode:='';
924 for i:=0 to Lines.Count-1 do begin
925 if i>0 then
926 InsertCode:=InsertCode+Beauty.LineEnd;
927 InsertCode:=InsertCode+Lines[i];
928 end;
929 finally
930 Lines.Free;
931 end;
932 end;
933
934 //DebugLn(['TStandardCodeTool.AddUnitToUsesSection Replace="',copy(Src,InsertPos,InsertToPos-InsertPos),'" with "',InsertCode,'"']);
935 if not SourceChangeCache.Replace(gtNone,gtNone,InsertPos,InsertToPos,
936 InsertCode) then exit;
937 if not SourceChangeCache.Apply then exit;
938 Result:=true;
939 end;
940
AddUnitToMainUsesSectionnull941 function TStandardCodeTool.AddUnitToMainUsesSection(const NewUnitName,
942 NewUnitInFile: string; SourceChangeCache: TSourceChangeCache;
943 AsLast: boolean; CheckSpecialUnits: boolean): boolean;
944 begin
945 Result:=AddUnitToSpecificUsesSection(usMain, NewUnitName, NewUnitInFile, SourceChangeCache,
946 AsLast, CheckSpecialUnits);
947 end;
948
AddUnitToImplementationUsesSectionnull949 function TStandardCodeTool.AddUnitToImplementationUsesSection(const NewUnitName,
950 NewUnitInFile: string; SourceChangeCache: TSourceChangeCache;
951 AsLast: boolean; CheckSpecialUnits: boolean): boolean;
952 begin
953 Result:=AddUnitToSpecificUsesSection(usImplementation, NewUnitName, NewUnitInFile, SourceChangeCache,
954 AsLast, CheckSpecialUnits);
955 end;
956
TStandardCodeTool.AddUnitToSpecificUsesSectionnull957 function TStandardCodeTool.AddUnitToSpecificUsesSection(UsesSection: TUsesSection;
958 const NewUnitName, NewUnitInFile: string; SourceChangeCache: TSourceChangeCache;
959 AsLast: boolean; CheckSpecialUnits: boolean): boolean;
960 var
961 UsesNode, OtherUsesNode, SectionNode, Node: TCodeTreeNode;
962 NewUsesTerm: string;
963 InsertPos: integer;
964 Junk: TAtomPosition;
965 Beauty: TBeautifyCodeOptions;
966 begin
967 Result:=false;
968 if not IsDottedIdentifier(NewUnitName) then exit;
969 if UsesSection=usMain then begin
970 // quick check using only the main uses section
971 BuildTree(lsrMainUsesSectionEnd);
972 UsesNode:=FindMainUsesNode;
973 if (UsesNode<>nil)
974 and (FindUnitInUsesSection(UsesNode,NewUnitName,Junk,Junk)) then
975 exit(true); // unit already in main uses section
976 end;
977 if GetSourceType=ctnUnit then
978 BuildTree(lsrImplementationUsesSectionEnd)
979 else if UsesSection=usImplementation then begin
980 MoveCursorToNodeStart(Tree.Root);
981 RaiseException(20170421201102,
982 ctsCanNotAddAUnitToTheImplementationBecauseOnlyAUnitH);
983 end;
984 SourceChangeCache.MainScanner:=Scanner;
985 Beauty:=SourceChangeCache.BeautifyCodeOptions;
986 SourceChangeCache.BeginUpdate;
987 try
988 UsesNode:=FindMainUsesNode;
989 OtherUsesNode:=FindImplementationUsesNode;
990 if UsesSection=usImplementation then begin
991 SectionNode:=UsesNode;
992 UsesNode:=OtherUsesNode;
993 OtherUsesNode:=SectionNode;
994 end;
995 // remove unit from other uses section
996 if (OtherUsesNode<>nil) then
997 RemoveUnitFromUsesSection(OtherUsesNode,NewUnitName,SourceChangeCache);
998
999 if UsesNode<>nil then begin
1000 // add unit to existing uses section
1001 if not (FindUnitInUsesSection(UsesNode,NewUnitName,Junk,Junk))
1002 then begin
1003 if not AddUnitToUsesSection(UsesNode,NewUnitName,NewUnitInFile,
1004 SourceChangeCache,AsLast,CheckSpecialUnits)
1005 then
1006 exit;
1007 end;
1008 end else begin
1009 // create a new uses section
1010 if Tree.Root=nil then exit;
1011 SectionNode:=Tree.Root;
1012 InsertPos:=0;
1013 NewUsesTerm:='';
1014 if SectionNode.Desc=ctnUnit then begin
1015 // unit
1016 case UsesSection of
1017 usMain: SectionNode:=FindInterfaceNode;
1018 usImplementation: SectionNode:=FindImplementationNode;
1019 end;
1020 if SectionNode<>nil then begin
1021 // add uses to existing interface/implementation before any content
1022 MoveCursorToNodeStart(SectionNode);
1023 ReadNextAtom;
1024 InsertPos := CurPos.EndPos;
1025 end else begin
1026 // section is missing => add it
1027 SectionNode:=Tree.Root;
1028 case UsesSection of
1029 usMain: NewUsesTerm:='interface';
1030 usImplementation: NewUsesTerm:='implementation';
1031 end;
1032 NewUsesTerm:=Beauty.BeautifyKeyWord(NewUsesTerm)
1033 +Beauty.LineEnd;
1034 if SectionNode.FirstChild<>nil then begin
1035 // unit not empty => add in front of first node
1036 InsertPos:=FindLineEndOrCodeInFrontOfPosition(SectionNode.FirstChild.StartPos,
1037 true);
1038 end else begin
1039 // unit empty => add at end
1040 InsertPos:=FindLineEndOrCodeInFrontOfPosition(SectionNode.EndPos,true);
1041 end;
1042 end;
1043 end;
1044 if InsertPos<1 then begin
1045 // not a unit (i.e. program)
1046 // => insert after title and directives
1047 Node:=SectionNode.Next;
1048 if (Node<>nil) and (Node.Desc=ctnSrcName) then
1049 Node:=Node.NextSkipChilds;
1050 if Node<>nil then begin
1051 InsertPos:=FindLineEndOrCodeInFrontOfPosition(Node.StartPos,
1052 true);
1053 end else begin
1054 // program empty => add at end
1055 InsertPos:=FindLineEndOrCodeInFrontOfPosition(SectionNode.EndPos,true);
1056 end;
1057 end;
1058 NewUsesTerm:=NewUsesTerm+Beauty.BeautifyKeyWord('uses')+' '+NewUnitName;
1059 if NewUnitInFile<>'' then
1060 NewUsesTerm:=NewUsesTerm+' in '''+NewUnitInFile+''';'
1061 else
1062 NewUsesTerm:=NewUsesTerm+';';
1063 if not SourceChangeCache.Replace(gtEmptyLine,gtEmptyLine,InsertPos,InsertPos,
1064 NewUsesTerm) then exit;
1065 end;
1066 Result:=true;
1067 finally
1068 if not Result then
1069 SourceChangeCache.Clear;
1070 if not SourceChangeCache.EndUpdate then
1071 Result:=false;
1072 end;
1073 end;
1074
TStandardCodeTool.UnitExistsInUsesSectionnull1075 function TStandardCodeTool.UnitExistsInUsesSection(UsesSection: TUsesSection;
1076 const AnUnitName: string): boolean;
1077 var
1078 UsesNode: TCodeTreeNode;
1079 begin
1080 Result:=false;
1081 if not IsDottedIdentifier(AnUnitName) then
1082 exit;
1083 if UsesSection=usMain then
1084 BuildTree(lsrMainUsesSectionEnd)
1085 else
1086 BuildTree(lsrImplementationUsesSectionEnd);
1087 case UsesSection Of
1088 usMain: UsesNode:=FindMainUsesNode;
1089 usImplementation: UsesNode:=FindImplementationUsesNode;
1090 end;
1091 Result:=UnitExistsInUsesSection(UsesNode,AnUnitName);
1092 end;
1093
TStandardCodeTool.UnitExistsInUsesSectionnull1094 function TStandardCodeTool.UnitExistsInUsesSection(UsesNode: TCodeTreeNode;
1095 const AnUnitName: string): boolean;
1096 begin
1097 Result:=false;
1098 if (UsesNode=nil) or (not IsDottedIdentifier(AnUnitName)) then
1099 exit;
1100 MoveCursorToNodeStart(UsesNode);
1101 ReadNextAtom; // read 'uses'
1102 repeat
1103 ReadNextAtom; // read name
1104 if not AtomIsIdentifier then exit;
1105 if ReadAndCompareUsedUnit(AnUnitName) then begin
1106 // unit found
1107 exit(true);
1108 end;
1109 if UpAtomIs('IN') then begin
1110 ReadNextAtom;
1111 ReadNextAtom;
1112 end;
1113 if CurPos.Flag=cafSemicolon then break;
1114 if CurPos.Flag<>cafComma then break;
1115 until (CurPos.StartPos>UsesNode.EndPos) or (CurPos.StartPos>SrcLen);
1116 end;
1117
RemoveUnitFromUsesSectionnull1118 function TStandardCodeTool.RemoveUnitFromUsesSection(UsesNode: TCodeTreeNode;
1119 const AnUnitName: string; SourceChangeCache: TSourceChangeCache): boolean;
1120 var UnitPos, StartPos, EndPos: integer;
1121 Found: Boolean;
1122 begin
1123 Result:=false;
1124 if (UsesNode=nil) or (not IsDottedIdentifier(AnUnitName)) then
1125 exit;
1126 MoveCursorToNodeStart(UsesNode);
1127 ReadNextAtom; // read 'uses'
1128 UnitPos:=0;
1129 repeat
1130 EndPos:=CurPos.StartPos;
1131 ReadNextAtom; // read name
1132 if not AtomIsIdentifier then exit;
1133 inc(UnitPos);
1134 StartPos:=CurPos.StartPos;
1135 Found:=ReadAndCompareUsedUnit(AnUnitName);
1136 if UpAtomIs('IN') then begin
1137 ReadNextAtom;
1138 ReadNextAtom;
1139 end;
1140 if Found then begin
1141 // unit found
1142 SourceChangeCache.MainScanner:=Scanner;
1143 if UnitPos=1 then begin
1144 // first unit in uses section
1145 if AtomIsChar(';') then begin
1146 // last unit in uses section -> delete whole uses section
1147 StartPos:=FindLineEndOrCodeInFrontOfPosition(UsesNode.StartPos,true,true);
1148 EndPos:=UsesNode.EndPos;
1149 end else begin
1150 // not last unit -> delete with comma behind
1151 EndPos:=FindLineEndOrCodeAfterPosition(CurPos.EndPos);
1152 if (EndPos>SrcLen) or (Src[EndPos] in [#10,#13]) then
1153 StartPos:=FindLineEndOrCodeInFrontOfPosition(StartPos);// delete space in front or even the empty line
1154 end;
1155 end else begin
1156 // not first unit in uses section
1157 if AtomIsChar(';') then begin
1158 // last unit -> delete with comma in front
1159 StartPos:=EndPos;
1160 EndPos:=CurPos.StartPos;
1161 end else if PositionsInSameLine(Src,EndPos,StartPos) then begin
1162 // not first unit in line -> delete with comma in front
1163 StartPos:=EndPos;
1164 EndPos:=CurPos.StartPos;
1165 end else begin
1166 // first unit in line -> delete with comma behind
1167 EndPos:=FindLineEndOrCodeAfterPosition(CurPos.EndPos);
1168 if (EndPos>SrcLen) or (Src[EndPos] in [#10,#13]) then
1169 StartPos:=FindLineEndOrCodeInFrontOfPosition(StartPos);// delete space in front or even the empty line
1170 end;
1171 end;
1172 if not SourceChangeCache.Replace(gtNone,gtNone,StartPos,EndPos,'') then
1173 exit;
1174 if not SourceChangeCache.Apply then exit;
1175 Result:=true;
1176 exit;
1177 end;
1178 if AtomIsChar(';') then break;
1179 if not AtomIsChar(',') then break;
1180 until (CurPos.StartPos>UsesNode.EndPos) or (CurPos.StartPos>SrcLen);
1181 Result:=true;
1182 end;
1183
RemoveUnitFromAllUsesSectionsnull1184 function TStandardCodeTool.RemoveUnitFromAllUsesSections(
1185 const AnUnitName: string; SourceChangeCache: TSourceChangeCache): boolean;
1186
RemoveFromSectionnull1187 function RemoveFromSection(UsesNode: TCodeTreeNode): boolean;
1188 begin
1189 Result:=(UsesNode=nil)
1190 or (RemoveUnitFromUsesSection(UsesNode,AnUnitName,SourceChangeCache));
1191 end;
1192
1193 begin
1194 Result:=false;
1195 if (AnUnitName='') or (SourceChangeCache=nil) then exit;
1196 BuildTree(lsrImplementationUsesSectionEnd);
1197
1198 SourceChangeCache.BeginUpdate;
1199 try
1200 if not RemoveFromSection(FindMainUsesNode) then exit;
1201 if not RemoveFromSection(FindImplementationUsesNode) then exit;
1202 finally
1203 Result:=SourceChangeCache.EndUpdate;
1204 end;
1205 end;
1206
TStandardCodeTool.FixUsedUnitCasenull1207 function TStandardCodeTool.FixUsedUnitCase(
1208 SourceChangeCache: TSourceChangeCache): boolean;
1209
FixUsesSectionnull1210 function FixUsesSection(UsesNode: TCodeTreeNode): boolean;
1211 begin
1212 Result:=(UsesNode=nil) or FixUsedUnitCaseInUsesSection(UsesNode,SourceChangeCache);
1213 end;
1214
1215 begin
1216 //debugln('TStandardCodeTool.FixUsedUnitCase ',MainFilename);
1217 Result:=false;
1218 BuildTree(lsrImplementationUsesSectionEnd);
1219 if not FixUsesSection(FindMainUsesNode) then exit;
1220 if not FixUsesSection(FindImplementationUsesNode) then exit;
1221 Result:=true;
1222 end;
1223
FixUsedUnitCaseInUsesSectionnull1224 function TStandardCodeTool.FixUsedUnitCaseInUsesSection(
1225 UsesNode: TCodeTreeNode; SourceChangeCache: TSourceChangeCache): boolean;
1226
FindUnitnull1227 function FindUnit(AFilename: string): string;
1228 var
1229 CurDir: String;
1230 MakeRelative: Boolean;
1231 begin
1232 Result:='';
1233 AFilename:=TrimFilename(AFilename);
1234 CurDir:='';
1235 if FilenameIsAbsolute(AFilename) then begin
1236 MakeRelative:=false;
1237 end else begin
1238 MakeRelative:=true;
1239 if TCodeBuffer(Scanner.MainCode).IsVirtual then exit;
1240 CurDir:=ExtractFilePath(TCodeBuffer(Scanner.MainCode).Filename);
1241 AFilename:=CurDir+AFilename;
1242 end;
1243 Result:=DirectoryCache.Pool.FindDiskFilename(AFilename,true);
1244 if Result='' then exit;
1245 if MakeRelative then
1246 Result:=CreateRelativePath(Result,CurDir);
1247 end;
1248
1249 var
1250 UnitInFilename: String;
1251 Changed: Boolean;
1252 RealUnitInFilename: String;
1253 UnitNameRange: TAtomPosition;
1254 InAtom: TAtomPosition;
1255 begin
1256 Result:=false;
1257 if (UsesNode=nil) then exit;
1258 MoveCursorToNodeStart(UsesNode);
1259 ReadNextAtom; // read 'uses'
1260 Changed:=false;
1261 repeat
1262 ReadNextAtom; // read name
1263 if not ReadNextUsedUnit(UnitNameRange,InAtom,false) then exit;
1264 if InAtom.StartPos>1 then begin
1265 UnitInFilename:=GetAtom(InAtom);
1266 //debugln('TStandardCodeTool.FixUsedUnitCaseInUsesSection A UnitInFilename="',UnitInFilename,'"');
1267 if (UnitInFilename<>'') and (UnitInFilename[1]='''') then begin
1268 UnitInFilename:=copy(UnitInFilename,2,length(UnitInFilename)-2);
1269 RealUnitInFilename:=FindUnit(UnitInFilename);
1270 //debugln('TStandardCodeTool.FixUsedUnitCaseInUsesSection B RealUnitInFilename="',RealUnitInFilename,'"');
1271 if (RealUnitInFilename<>'')
1272 and (RealUnitInFilename<>UnitInFilename) then begin
1273 if not Changed then begin
1274 SourceChangeCache.MainScanner:=Scanner;
1275 Changed:=true;
1276 end;
1277 debugln('TStandardCodeTool.FixUsedUnitCaseInUsesSection Replacing UnitInFilename="',UnitInFilename,'" with "',RealUnitInFilename,'"');
1278 if not SourceChangeCache.Replace(gtNone,gtNone,
1279 InAtom.StartPos,InAtom.EndPos,''''+RealUnitInFilename+'''') then exit;
1280 end;
1281 end;
1282 end;
1283 if CurPos.Flag=cafSemicolon then break;
1284 if CurPos.Flag<>cafComma then exit;
1285 until (CurPos.StartPos>UsesNode.EndPos) or (CurPos.StartPos>SrcLen);
1286 if Changed and (not SourceChangeCache.Apply) then exit;
1287 Result:=true;
1288 end;
1289
FindUsedUnitNamesnull1290 function TStandardCodeTool.FindUsedUnitNames(var MainUsesSection,
1291 ImplementationUsesSection: TStrings): boolean;
1292 var
1293 MainUsesNode, ImplementatioUsesNode: TCodeTreeNode;
1294 begin
1295 MainUsesSection:=nil;
1296 ImplementationUsesSection:=nil;
1297 // find the uses sections
1298 BuildTree(lsrImplementationUsesSectionEnd);
1299 MainUsesNode:=FindMainUsesNode;
1300 ImplementatioUsesNode:=FindImplementationUsesNode;
1301 // create lists
1302 try
1303 MainUsesSection:=UsesSectionToUnitNames(MainUsesNode);
1304 ImplementationUsesSection:=UsesSectionToUnitNames(ImplementatioUsesNode);
1305 except
1306 FreeAndNil(MainUsesSection);
1307 FreeAndNil(ImplementationUsesSection);
1308 raise;
1309 end;
1310 Result:=true;
1311 end;
1312
FindUsedUnitNamesnull1313 function TStandardCodeTool.FindUsedUnitNames(var List: TStringToStringTree
1314 ): boolean;
1315
1316 procedure Collect(UsesNode: TCodeTreeNode; const Tag: string);
1317 var
1318 UnitNameAtom: TAtomPosition;
1319 InAtom: TAtomPosition;
1320 OldTag: string;
1321 AnUnitName: String;
1322 begin
1323 if UsesNode=nil then exit;
1324 MoveCursorToUsesStart(UsesNode);
1325 repeat
1326 // read next unit name
1327 ReadNextUsedUnit(UnitNameAtom, InAtom);
1328 AnUnitName:=GetAtom(UnitNameAtom);
1329 // tag unit in list
1330 OldTag:=List[AnUnitName];
1331 if System.Pos(Tag,OldTag)<1 then
1332 List[AnUnitName]:=OldTag+Tag;
1333 if CurPos.Flag=cafComma then begin
1334 // read next unit name
1335 ReadNextAtom;
1336 end else if CurPos.Flag=cafSemicolon then begin
1337 break;
1338 end else
1339 RaiseExceptionFmt(20170421201120,ctsStrExpectedButAtomFound,[';',GetAtom]);
1340 until false;
1341 Result:=true;
1342 end;
1343
1344 begin
1345 // find the uses sections
1346 List:=TStringToStringTree.Create(false);
1347 BuildTree(lsrImplementationUsesSectionEnd);
1348 Collect(FindMainUsesNode,'Main');
1349 Collect(FindImplementationUsesNode,'Implementation');
1350 Result:=true;
1351 end;
1352
FindUsedUnitFilesnull1353 function TStandardCodeTool.FindUsedUnitFiles(var MainUsesSection: TStrings
1354 ): boolean;
1355 var
1356 MainUsesNode: TCodeTreeNode;
1357 begin
1358 MainUsesSection:=nil;
1359 // find the uses sections
1360 BuildTree(lsrMainUsesSectionEnd);
1361 MainUsesNode:=FindMainUsesNode;
1362 // create lists
1363 try
1364 MainUsesSection:=UsesSectionToFilenames(MainUsesNode);
1365 except
1366 FreeAndNil(MainUsesSection);
1367 raise;
1368 end;
1369 Result:=true;
1370 end;
1371
FindUsedUnitFilesnull1372 function TStandardCodeTool.FindUsedUnitFiles(var MainUsesSection,
1373 ImplementationUsesSection: TStrings): boolean;
1374 var
1375 MainUsesNode, ImplementatioUsesNode: TCodeTreeNode;
1376 begin
1377 MainUsesSection:=nil;
1378 ImplementationUsesSection:=nil;
1379 // find the uses sections
1380 BuildTree(lsrImplementationUsesSectionEnd);
1381 MainUsesNode:=FindMainUsesNode;
1382 ImplementatioUsesNode:=FindImplementationUsesNode;
1383 // create lists
1384 try
1385 MainUsesSection:=UsesSectionToFilenames(MainUsesNode);
1386 ImplementationUsesSection:=UsesSectionToFilenames(ImplementatioUsesNode);
1387 except
1388 FreeAndNil(MainUsesSection);
1389 FreeAndNil(ImplementationUsesSection);
1390 raise;
1391 end;
1392 Result:=true;
1393 end;
1394
1395 {------------------------------------------------------------------------------
1396 function TStandardCodeTool.FindDelphiProjectUnits(var FoundInUnits,
1397 MissingInUnits, NormalUnits: TStrings): boolean;
1398
1399 Reads the main uses section and tries to find each unit file having
1400 an 'in' modifier.
1401 The associated objects in the list will be the found codebuffers.
1402 FoundInUnits returns the list of found 'in' unitnames plus TCodeBuffer
1403 MissingInUnits returns the list of missing 'in' unitnames
1404 NormalUnits returns the list of unitnames plus TCodeBuffer (if found)
1405
1406 If no codebuffer was found/created then the filename will be the unit name
1407 plus the 'in' extension.
1408 ------------------------------------------------------------------------------}
FindDelphiProjectUnitsnull1409 function TStandardCodeTool.FindDelphiProjectUnits(out FoundInUnits,
1410 MissingInUnits, NormalUnits: TStrings; UseContainsSection: boolean;
1411 IgnoreNormalUnits: boolean): boolean;
1412 var
1413 AnUnitName, AnUnitInFilename: string;
1414 NewCode: TCodeBuffer;
1415 UsesNode: TCodeTreeNode;
1416 Node: TCodeTreeNode;
1417 begin
1418 Result:=false;
1419 FoundInUnits:=nil;
1420 MissingInUnits:=nil;
1421 NormalUnits:=nil;
1422 // find the uses sections
1423 BuildTree(lsrMainUsesSectionEnd);
1424 UsesNode:=FindMainUsesNode(UseContainsSection);
1425 if UsesNode=nil then exit;
1426 FoundInUnits:=TStringList.Create;
1427 MissingInUnits:=TStringList.Create;
1428 if IgnoreNormalUnits then
1429 NormalUnits:=nil
1430 else
1431 NormalUnits:=TStringList.Create;
1432 Node:=UsesNode.FirstChild;
1433 while Node<>nil do begin
1434 // read next unit name
1435 AnUnitName:=ExtractUsedUnitName(Node,@AnUnitInFilename);
1436 // find unit file
1437 if AnUnitInFilename<>'' then begin
1438 // An 'in' unit => Delphi project file
1439 NewCode:=FindUnitSource(AnUnitName,AnUnitInFilename,false,Node.StartPos);
1440 if (NewCode=nil) then begin
1441 // no source found
1442 MissingInUnits.Add(AnUnitName+' in '+AnUnitInFilename);
1443 end else begin
1444 // source found => add filename to list
1445 FoundInUnits.AddObject(AnUnitName+' in '+AnUnitInFilename,NewCode);
1446 end;
1447 end else if AnUnitName<>'' then begin
1448 // the units without 'in' are 'Forms' or units added by the user
1449 if not IgnoreNormalUnits then begin
1450 NewCode:=FindUnitSource(AnUnitName,AnUnitInFilename,false,Node.StartPos);
1451 NormalUnits.AddObject(AnUnitName,NewCode);
1452 end;
1453 end;
1454 Node:=Node.NextBrother;
1455 end;
1456 Result:=true;
1457 end;
1458
1459 {------------------------------------------------------------------------------
1460 function TStandardCodeTool.UsesSectionToFilenames(UsesNode: TCodeTreeNode
1461 ): TStrings;
1462
1463 Reads the uses section backwards and tries to find each unit file.
1464 The associated objects in the list will be the found codebuffers.
1465 If no codebuffer was found/created then the filename will be the unit name
1466 plus the 'in' extension.
1467 ------------------------------------------------------------------------------}
TStandardCodeTool.UsesSectionToFilenamesnull1468 function TStandardCodeTool.UsesSectionToFilenames(UsesNode: TCodeTreeNode
1469 ): TStrings;
1470 var
1471 AnUnitName, AnUnitInFilename: string;
1472 NewCode: TCodeBuffer;
1473 UnitFilename: string;
1474 Node: TCodeTreeNode;
1475 begin
1476 Result:=TStringList.Create;
1477 if UsesNode=nil then exit;
1478 Node:=UsesNode.LastChild;
1479 while Node<>nil do begin
1480 // read unit name
1481 AnUnitName:=ExtractUsedUnitName(Node,@AnUnitInFilename);
1482 if AnUnitName<>'' then begin
1483 // find unit file
1484 NewCode:=FindUnitSource(AnUnitName,AnUnitInFilename,false,Node.StartPos);
1485 if (NewCode=nil) then begin
1486 // no source found
1487 UnitFilename:=AnUnitName;
1488 if AnUnitInFilename<>'' then
1489 UnitFilename:=UnitFilename+' in '+AnUnitInFilename;
1490 end else begin
1491 // source found
1492 UnitFilename:=NewCode.Filename;
1493 end;
1494 // add filename to list
1495 Result.AddObject(UnitFilename,NewCode);
1496 end;
1497 Node:=Node.PriorBrother;
1498 end;
1499 end;
1500
TStandardCodeTool.UsesSectionToUnitnamesnull1501 function TStandardCodeTool.UsesSectionToUnitnames(UsesNode: TCodeTreeNode
1502 ): TStrings;
1503 var
1504 AnUnitName: string;
1505 Node: TCodeTreeNode;
1506 begin
1507 Result:=TStringList.Create;
1508 if UsesNode=nil then exit;
1509 Node:=UsesNode.LastChild;
1510 while Node<>nil do begin
1511 // read unit name
1512 AnUnitName:=ExtractUsedUnitName(Node);
1513 if AnUnitName<>'' then
1514 Result.Add(AnUnitName);
1515 Node:=Node.PriorBrother;
1516 end;
1517 end;
1518
TStandardCodeTool.FindMissingUnitsnull1519 function TStandardCodeTool.FindMissingUnits(var MissingUnits: TStrings;
1520 FixCase: boolean; SearchImplementation: boolean;
1521 SourceChangeCache: TSourceChangeCache): boolean;
1522 const
1523 FPCSrcSearchRequiresPPU = true;
1524
CheckUsesSectionnull1525 function CheckUsesSection(UsesNode: TCodeTreeNode): boolean;
1526 var
1527 OldUnitName: String;
1528 OldInFilename: String;
1529 AFilename: String;
1530 s: String;
1531 NewUnitName: String;
1532 NewInFilename: String;
1533 FromPos: LongInt;
1534 ToPos: LongInt;
1535 Node: TCodeTreeNode;
1536 begin
1537 if UsesNode=nil then exit(true);
1538
1539 Node:=UsesNode.FirstChild;
1540 while Node<>nil do begin
1541 // read next unit name
1542 OldUnitName:=ExtractUsedUnitName(Node,@OldInFilename);
1543 // find unit file
1544 NewUnitName:=OldUnitName;
1545 NewInFilename:=OldInFilename;
1546 //debugln(['CheckUsesSection NewUnitName="',NewUnitName,'" NewInFilename="',NewInFilename,'"']);
1547 AFilename:=DirectoryCache.FindUnitSourceInCompletePath(
1548 NewUnitName,NewInFilename,true,FPCSrcSearchRequiresPPU,AddedNameSpace);
1549 s:=NewUnitName;
1550 if NewInFilename<>'' then
1551 s:=s+' in '''+NewInFilename+'''';
1552 if AFilename<>'' then begin
1553 // unit found
1554 if FixCase
1555 and ((NewUnitName<>OldUnitName) or (NewInFilename<>OldInFilename)) then
1556 begin
1557 // fix case
1558 FromPos:=Node.StartPos;
1559 ToPos:=Node.EndPos;
1560 SourceChangeCache.Replace(gtNone,gtNone,FromPos,ToPos,s);
1561 DebugLn('TStandardCodeTool.FindMissingUnits.CheckUsesSection fix case Unit Name(',OldUnitName,'->',NewUnitName,') InFile(',OldInFilename,'->',NewInFilename,')');
1562 end;
1563 end else begin
1564 // unit not found
1565 if MissingUnits=nil then MissingUnits:=TStringList.Create;
1566 MissingUnits.Add(s);
1567 end;
1568 Node:=Node.NextBrother;
1569 end;
1570 Result:=true;
1571 end;
1572
1573 begin
1574 Result:=false;
1575 BuildTree(lsrImplementationUsesSectionEnd);
1576 if FixCase then
1577 SourceChangeCache.MainScanner:=Scanner;
1578 try
1579 if not CheckUsesSection(FindMainUsesNode) then exit;
1580 if SearchImplementation
1581 and not CheckUsesSection(FindImplementationUsesNode) then exit;
1582 except
1583 FreeAndNil(MissingUnits);
1584 raise;
1585 end;
1586 if FixCase then
1587 Result:=SourceChangeCache.Apply
1588 else
1589 Result:=true;
1590 end;
1591
CommentUnitsInUsesSectionnull1592 function TStandardCodeTool.CommentUnitsInUsesSection(MissingUnits: TStrings;
1593 SourceChangeCache: TSourceChangeCache; UsesNode: TCodeTreeNode): boolean;
1594 // Examples:
1595 // 1. uses {a,} b, c; commenting one unit not at end
1596 // 2. uses a, {b,} c; commenting one unit not at end
1597 // 3. uses {a, b,} c; commenting several units not at end
1598 // 4. uses a{, b, c} ; commenting units at end
1599 // 5. {uses a, b, c;} commenting all units
1600 // 6. uses {a,} b{, c}; commenting several units
1601
1602 procedure Comment(StartPos, EndPos: integer);
1603 begin
1604 //debugln(['Comment ',dbgstr(copy(Src,StartPos,EndPos-StartPos))]);
1605 CommentCode(StartPos,EndPos,SourceChangeCache,false);
1606 end;
1607
1608 var
1609 i: Integer;
1610 CurUnitName: String;
1611 CommentCurUnit: Boolean;
1612 FirstCommentUnitStart: Integer;
1613 LastCommaAfterCommentUnitsStart: Integer;
1614 LastNormalUnitEnd: Integer;
1615 LastCommentUnitEnd: Integer;
1616 Node: TCodeTreeNode;
1617 begin
1618 Result:=true;
1619 if UsesNode=nil then exit;
1620 FirstCommentUnitStart:=-1;
1621 LastCommaAfterCommentUnitsStart:=-1;
1622 LastNormalUnitEnd:=-1;
1623 LastCommentUnitEnd:=-1;
1624 Node:=UsesNode.FirstChild;
1625 while Node<>nil do begin
1626 // check if unit should be commented
1627 CurUnitName:=ExtractUsedUnitName(Node);
1628 // Note: CurPos is now on atom behind used unit, i.e. comma or semicolon
1629 i:=MissingUnits.Count-1;
1630 while (i>=0)
1631 and (CompareIdentifiers(PChar(Pointer(MissingUnits[i])),
1632 PChar(Pointer(CurUnitName)))<>0) do
1633 dec(i);
1634 CommentCurUnit:=i>=0;
1635 //debugln('CommentUnitsInUsesSection CurUnitName="',CurUnitName,'" CommentCurUnit=',dbgs(CommentCurUnit));
1636
1637 if CommentCurUnit then begin
1638 // unit should be commented
1639 if FirstCommentUnitStart<1 then FirstCommentUnitStart:=Node.StartPos;
1640 LastCommentUnitEnd:=Node.EndPos;
1641 end else begin
1642 // unit should be kept
1643 LastNormalUnitEnd:=Node.EndPos;
1644 if FirstCommentUnitStart>=1 then begin
1645 // there are some units to be commented
1646 // See examples: 1., 2., 3. and 6.
1647 Comment(FirstCommentUnitStart,LastCommaAfterCommentUnitsStart);
1648 FirstCommentUnitStart:=-1;
1649 LastCommentUnitEnd:=-1;
1650 LastCommaAfterCommentUnitsStart:=-1;
1651 end;
1652 end;
1653
1654 if CommentCurUnit then
1655 LastCommaAfterCommentUnitsStart:=CurPos.EndPos;
1656
1657 if CurPos.Flag<>cafComma then begin
1658 if CommentCurUnit then begin
1659 // last unit must be commented
1660 if LastNormalUnitEnd>=1 then begin
1661 // comment last unit and keep some units in front
1662 // See example: 4.
1663 Comment(LastNormalUnitEnd,LastCommentUnitEnd);
1664 end else begin
1665 // all units should be commented
1666 // See example: 5.
1667 Comment(UsesNode.StartPos,CurPos.EndPos);
1668 end;
1669 end;
1670 break;
1671 end;
1672
1673 Node:=Node.NextBrother;
1674 end;
1675 end;
1676
CommentUnitsInUsesSectionsnull1677 function TStandardCodeTool.CommentUnitsInUsesSections(MissingUnits: TStrings;
1678 SourceChangeCache: TSourceChangeCache): boolean;
1679 begin
1680 if (MissingUnits=nil) or (MissingUnits.Count=0) then
1681 exit(true);
1682 Result:=false;
1683 BuildTree(lsrInitializationStart);
1684 SourceChangeCache.MainScanner:=Scanner;
1685 if not CommentUnitsInUsesSection(MissingUnits, SourceChangeCache, FindMainUsesNode) then exit;
1686 if not CommentUnitsInUsesSection(MissingUnits, SourceChangeCache, FindImplementationUsesNode) then exit;
1687 if not SourceChangeCache.Apply then exit;
1688 Result:=true;
1689 end;
1690
FindUnusedUnitsnull1691 function TStandardCodeTool.FindUnusedUnits(Units: TStrings): boolean;
1692 // returns a list of unitname=flags
1693 // flags are a comma separated list of words:
1694 // 'implementation': unit is in implementation uses section
1695 // 'used': an identifier of the interface is used
1696 // 'code': unit has non empty initialization/finalization section
1697 var
1698 Identifiers: TAVLTree;// all identifiers used in this unit
1699
IsUnitAlreadyCheckednull1700 function IsUnitAlreadyChecked(const AnUnitName: string): boolean;
1701 var
1702 i: Integer;
1703 begin
1704 for i:=0 to Units.Count-1 do
1705 if SysUtils.CompareText(Units.Names[i],AnUnitName)=0 then exit(true);
1706 Result:=false;
1707 end;
1708
1709 procedure GatherIdentifiersInRange(StartPos, EndPos: integer);
1710 // gather all used identifiers from this unit in the range Startpos..EndPos
1711 var
1712 Identifier: PChar;
1713 begin
1714 if (StartPos<1) or (StartPos>=EndPos) then exit;
1715 MoveCursorToCleanPos(StartPos);
1716 repeat
1717 ReadNextAtom;
1718 if CurPos.StartPos>=EndPos then break;
1719 if IsIdentStartChar[Src[CurPos.StartPos]] then begin
1720 Identifier:=@Src[CurPos.StartPos];
1721 if Identifiers.Find(Identifier)=nil then begin
1722 {$IFDEF VerboseFindUnusedUnits}
1723 DebugLn(['Used Identifier=',GetIdentifier(Identifier)]);
1724 {$ENDIF}
1725 Identifiers.Add(Identifier);
1726 end;
1727 end;
1728 until false;
1729 end;
1730
1731 procedure GatherIdentifiers;
1732 // gather all used identifiers from this unit
1733 var
1734 StartPos: Integer;
1735
1736 procedure Gather(EndPos: integer);
1737 begin
1738 if StartPos<1 then exit;
1739 GatherIdentifiersInRange(StartPos,EndPos);
1740 StartPos:=-1;
1741 end;
1742
1743 var
1744 Node: TCodeTreeNode;
1745 begin
1746 if Identifiers<>nil then exit;
1747 Identifiers:=TAVLTree.Create(@CompareIdentifierPtrs);
1748 {$IFDEF VerboseFindUnusedUnits}
1749 DebugLn(['GatherIdentifiers ']);
1750 {$ENDIF}
1751 StartPos:=-1;
1752 Node:=Tree.Root;
1753 while Node<>nil do begin
1754 case Node.Desc of
1755 ctnUseUnit,ctnUsesSection,ctnUseUnitNamespace,ctnUseUnitClearName,
1756 ctnProgram,ctnUnit,ctnPackage,ctnLibrary,ctnEndPoint:
1757 begin
1758 // skip node
1759 Gather(Node.StartPos);
1760 end;
1761 ctnEnumIdentifier,
1762 ctnVarDefinition,ctnConstDefinition,ctnTypeDefinition:
1763 begin
1764 // start reading behind identifier
1765 Gather(Node.StartPos);
1766 MoveCursorToCleanPos(Node.StartPos);
1767 ReadNextAtom;
1768 StartPos:=CurPos.EndPos;
1769 end;
1770 else
1771 if StartPos<1 then
1772 StartPos:=Node.StartPos;
1773 end;
1774 Node:=Node.Next;
1775 end;
1776 end;
1777
InterfaceIsUsednull1778 function InterfaceIsUsed(Tool: TFindDeclarationTool;
1779 IntfNode: TCodeTreeNode): boolean;
1780
IsIdentifierUsednull1781 function IsIdentifierUsed(StartPos: integer): boolean;
1782 begin
1783 {$IFDEF VerboseFindUnusedUnits}
1784 if CompareIdentifiers(PChar(GetIdentifier(@Tool.Src[StartPos])),'TComponent')=0 then
1785 DebugLn(['IsIdentifierUsed ',GetIdentifier(@Tool.Src[StartPos])]);
1786 {$ENDIF}
1787 Result:=Identifiers.Find(@Tool.Src[StartPos])<>nil;
1788 end;
1789
IsNodeVisiblenull1790 function IsNodeVisible(Node: TCodeTreeNode): boolean;
1791 begin
1792 Result:=false;
1793 Node:=Node.Parent;
1794 while Node<>nil do begin
1795 if Node.Desc=ctnInterface then exit(true);
1796 if Node.Desc in AllClasses then exit;
1797 Node:=Node.Parent;
1798 end;
1799 end;
1800
FindProceduresInHelpernull1801 function FindProceduresInHelper(Node: TCodeTreeNode): boolean;
1802 begin
1803 Result := False;
1804 Node := Node.FirstChild;
1805 while (Node<>nil) and (Node.Desc <> ctnEndPoint) do
1806 begin
1807 if (Node.Desc = ctnProcedure) and (Node.FirstChild<>nil) then
1808 begin
1809 if IsIdentifierUsed(Node.FirstChild.StartPos) then
1810 Exit(True);
1811 end;
1812 Node:=Node.Next;
1813 end;
1814 end;
1815
1816 var
1817 Node: TCodeTreeNode;
1818 begin
1819 Result:=true;
1820 Node:=IntfNode.FirstChild;
1821 while Node<>nil do begin
1822 case Node.Desc of
1823 ctnTypeHelper, ctnRecordHelper, ctnClassHelper:
1824 if FindProceduresInHelper(Node) then exit;
1825 ctnEnumIdentifier:
1826 if IsIdentifierUsed(Node.StartPos) then exit;
1827 ctnVarDefinition,ctnConstDefinition,ctnTypeDefinition,ctnGenericName:
1828 if IsNodeVisible(Node) and IsIdentifierUsed(Node.StartPos) then exit;
1829 ctnProcedure:
1830 if (Node.Parent.Desc=ctnInterface)
1831 and (Node.FirstChild<>nil)
1832 and (Node.FirstChild.Desc=ctnProcedureHead)
1833 and IsIdentifierUsed(Node.FirstChild.StartPos) then exit;
1834 ctnGlobalProperty:
1835 if Tool.MoveCursorToPropName(Node)
1836 and IsIdentifierUsed(Tool.CurPos.StartPos) then exit;
1837 end;
1838 Node:=Node.Next;
1839 end;
1840 Result:=false;
1841 end;
1842
1843 procedure CheckUnit(Tool: TFindDeclarationTool;
1844 out HasCode, UseInterface: boolean);
1845 var
1846 Node: TCodeTreeNode;
1847 Identifier: String;
1848 begin
1849 GatherIdentifiers;
1850 HasCode:=false;
1851 UseInterface:=false;
1852 // parse used unit
1853 Tool.BuildTree(lsrEnd);
1854 Node:=Tool.Tree.Root;
1855 while (Node<>nil) do begin
1856 case Node.Desc of
1857 ctnUnit,ctnPackage,ctnLibrary:
1858 begin
1859 Identifier:=Tool.ExtractSourceName;
1860 if Identifiers.Find(PChar(Identifier))<>nil then
1861 UseInterface:=true;
1862 end;
1863 ctnInterface:
1864 if not UseInterface then
1865 UseInterface:=InterfaceIsUsed(Tool,Node);
1866 ctnInitialization,ctnFinalization,ctnBeginBlock:
1867 begin
1868 HasCode:=true;
1869 break;
1870 end;
1871 end;
1872 Node:=Node.NextBrother;
1873 end;
1874 end;
1875
1876 procedure CheckUsesSection(UsesNode: TCodeTreeNode; InImplementation: boolean);
1877 var
1878 Unit_Name: String;
1879 UnitInFilename: String;
1880 Tool: TFindDeclarationTool;
1881 HasCode: boolean;
1882 UseInterface: boolean;
1883 Flags: String;
1884 Node: TCodeTreeNode;
1885 begin
1886 HasCode:=false;
1887 UseInterface:=false;
1888 if UsesNode=nil then exit;
1889 Node:=UsesNode.FirstChild;
1890 while Node<>nil do begin
1891 Unit_Name:=ExtractUsedUnitName(Node,@UnitInFilename);
1892 if not IsUnitAlreadyChecked(Unit_Name) then begin
1893 // try to load the used unit
1894 {$IFDEF VerboseFindUnusedUnits}
1895 DebugLn(['CheckUsesSection ',Unit_Name,' in ',UnitInFilename]);
1896 {$ENDIF}
1897 Tool:=FindCodeToolForUsedUnit(Unit_Name,UnitInFilename,true);
1898 // parse the used unit
1899 CheckUnit(Tool,HasCode,UseInterface);
1900 Flags:='';
1901 if InImplementation then
1902 Flags:=Flags+',implementation';
1903 if HasCode then
1904 Flags:=Flags+',code';
1905 if UseInterface then
1906 Flags:=Flags+',used';
1907 {$IFDEF VerboseFindUnusedUnits}
1908 DebugLn(['CheckUsesSection ',Unit_Name,'=',Flags]);
1909 {$ENDIF}
1910 Units.Add(Unit_Name+'='+Flags);
1911 end;
1912 Node:=Node.NextBrother;
1913 end;
1914 end;
1915
1916 begin
1917 Result:=false;
1918 {$IFDEF VerboseFindUnusedUnits}
1919 DebugLn(['TStandardCodeTool.FindUnusedUnits START']);
1920 {$ENDIF}
1921 BuildTree(lsrEnd);
1922 Identifiers:=nil;
1923 try
1924 CheckUsesSection(FindMainUsesNode,false);
1925 CheckUsesSection(FindImplementationUsesNode,true);
1926 finally
1927 Identifiers.Free;
1928 end;
1929 {$IFDEF VerboseFindUnusedUnits}
1930 DebugLn(['TStandardCodeTool.FindUnusedUnits END']);
1931 {$ENDIF}
1932 Result:=true;
1933 end;
1934
TStandardCodeTool.FindNextIncludeInInitializationnull1935 function TStandardCodeTool.FindNextIncludeInInitialization(
1936 var LinkIndex: integer): TCodeBuffer;
1937 // LinkIndex < 0 -> search first
1938 var
1939 InitializationNode: TCodeTreeNode;
1940 StartCode: TCodeBuffer;
1941 begin
1942 Result:=nil;
1943 if LinkIndex<0 then begin
1944 BuildTree(lsrEnd);
1945 InitializationNode:=FindInitializationNode;
1946 if InitializationNode=nil then exit;
1947 LinkIndex:=Scanner.LinkIndexAtCleanPos(InitializationNode.StartPos);
1948 end else begin
1949 InitializationNode:=nil;
1950 inc(LinkIndex);
1951 end;
1952 if (LinkIndex<0) or (LinkIndex>=Scanner.LinkCount) then exit;
1953 StartCode:=TCodeBuffer(Scanner.Links[LinkIndex].Code);
1954 // ToDo: Fix the test for InitializationNode, it can be Nil.
1955 while (LinkIndex<Scanner.LinkCount)
1956 and (Scanner.Links[LinkIndex].CleanedPos<InitializationNode.EndPos) do begin
1957 Result:=TCodeBuffer(Scanner.Links[LinkIndex].Code);
1958 if (Result<>StartCode) then
1959 exit;
1960 inc(LinkIndex);
1961 end;
1962 Result:=nil;
1963 end;
1964
FindLazarusResourceInBuffernull1965 function TStandardCodeTool.FindLazarusResourceInBuffer(
1966 ResourceCode: TCodeBuffer; const ResourceName: string): TAtomPosition;
1967 var ResNameCode: string;
1968
ReadLazResourcenull1969 function ReadLazResource: boolean;
1970 begin
1971 Result:=false;
1972 if not ReadNextAtomIsChar('.') then exit;
1973 if not ReadNextUpAtomIs('ADD') then exit;
1974 if not ReadNextAtomIsChar('(') then exit;
1975 ReadNextAtom;
1976 if not AtomIsStringConstant then exit;
1977 if UpAtomIs(ResNameCode) then
1978 Result:=true;
1979 repeat
1980 ReadNextAtom;
1981 until (CurPos.StartPos>SrcLen) or (AtomIsChar(')'));
1982 ReadNextAtom; // read ';'
1983 end;
1984
1985 var CleanPos, MaxCleanPos: integer;
1986 begin
1987 Result.StartPos:=-1;
1988 if (ResourceCode=nil) or (ResourceName='') or (length(ResourceName)>255) then
1989 exit;
1990 if Scanner.CursorToCleanPos(1,ResourceCode,CleanPos)<>0 then exit;
1991 if Scanner.CursorToCleanPos(ResourceCode.SourceLength,ResourceCode,
1992 MaxCleanPos)<>0 then
1993 MaxCleanPos:=-1;
1994 MoveCursorToCleanPos(CleanPos);
1995 ResNameCode:=''''+UpperCaseStr(ResourceName)+'''';
1996 // search "LazarusResources.Add('<ResourceName>',"
1997 repeat
1998 ReadNextAtom; // read 'LazarusResources'
1999 if UpAtomIs('LAZARUSRESOURCES') then begin
2000 Result.StartPos:=CurPos.StartPos;
2001 if ReadLazResource then begin
2002 Result.EndPos:=CurPos.EndPos;
2003 exit;
2004 end;
2005 end;
2006 until (CurPos.StartPos>SrcLen) or UpAtomIs('END')
2007 or ((MaxCleanPos>0) and (CurPos.StartPos>MaxCleanPos));
2008 Result.StartPos:=-1;
2009 end;
2010
TStandardCodeTool.FindLazarusResourcenull2011 function TStandardCodeTool.FindLazarusResource(
2012 const ResourceName: string): TAtomPosition;
2013 // search Resource in all include files
2014 var LinkIndex: integer;
2015 CurCode: TCodeBuffer;
2016 begin
2017 Result.StartPos:=-1;
2018 Result.EndPos:=-1;
2019 Result.Flag:=cafNone;
2020 LinkIndex:=-1;
2021 CurCode:=FindNextIncludeInInitialization(LinkIndex);
2022 while (CurCode<>nil) do begin
2023 Result:=FindLazarusResourceInBuffer(CurCode,ResourceName);
2024 if Result.StartPos>0 then exit;
2025 CurCode:=FindNextIncludeInInitialization(LinkIndex);
2026 end;
2027 end;
2028
TStandardCodeTool.AddLazarusResourcenull2029 function TStandardCodeTool.AddLazarusResource(ResourceCode: TCodeBuffer;
2030 const ResourceName, ResourceData: string;
2031 SourceChangeCache: TSourceChangeCache): boolean;
2032 // ResoureData is the complete LazarusResource Statement
2033 var FromPos, ToPos, i: integer;
2034 OldPosition: TAtomPosition;
2035 begin
2036 Result:=false;
2037 if (ResourceCode=nil) or (ResourceName='') or (length(ResourceName)>255)
2038 or (ResourceData='') or (SourceChangeCache=nil) then exit;
2039 BuildTree(lsrEnd);
2040 SourceChangeCache.MainScanner:=Scanner;
2041 OldPosition:=FindLazarusResourceInBuffer(ResourceCode,ResourceName);
2042 if OldPosition.StartPos>0 then begin
2043 // replace old resource
2044 FromPos:=OldPosition.StartPos;
2045 ToPos:=OldPosition.EndPos;
2046 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,FromPos,ToPos,
2047 ResourceData) then exit;
2048 end else begin
2049 // insert new resource
2050 if ResourceCode.SourceLength>0 then begin
2051 if Scanner.CursorToCleanPos(ResourceCode.SourceLength,ResourceCode,
2052 FromPos)<>0 then exit;
2053 inc(FromPos);
2054 end else begin
2055 // resource code empty -> can not be found in cleaned code
2056 // special replace
2057 i:=0;
2058 while (i<Scanner.LinkCount)
2059 and (Scanner.Links[i].Code<>Pointer(ResourceCode)) do
2060 inc(i);
2061 if i>=Scanner.LinkCount then exit;
2062 FromPos:=Scanner.Links[i].CleanedPos;
2063 end;
2064 if not SourceChangeCache.ReplaceEx(gtNewLine,gtNewLine,FromPos,FromPos,
2065 ResourceCode,ResourceCode.SourceLength+1,ResourceCode.SourceLength+1,
2066 ResourceData)
2067 then exit;
2068 end;
2069 if not SourceChangeCache.Apply then exit;
2070 Result:=true;
2071 end;
2072
RemoveLazarusResourcenull2073 function TStandardCodeTool.RemoveLazarusResource(ResourceCode: TCodeBuffer;
2074 const ResourceName: string;
2075 SourceChangeCache: TSourceChangeCache): boolean;
2076 var OldPosition: TAtomPosition;
2077 begin
2078 Result:=false;
2079 if (ResourceCode=nil) or (ResourceName='') or (length(ResourceName)>255)
2080 or (SourceChangeCache=nil) then exit;
2081 BuildTree(lsrEnd);
2082 SourceChangeCache.MainScanner:=Scanner;
2083 OldPosition:=FindLazarusResourceInBuffer(ResourceCode,ResourceName);
2084 if OldPosition.StartPos>0 then begin
2085 OldPosition.StartPos:=FindLineEndOrCodeInFrontOfPosition(
2086 OldPosition.StartPos);
2087 OldPosition.EndPos:=FindLineEndOrCodeAfterPosition(OldPosition.EndPos);
2088 if not SourceChangeCache.Replace(gtNone,gtNone,
2089 OldPosition.StartPos,OldPosition.EndPos,'') then exit;
2090 end;
2091 if not SourceChangeCache.Apply then exit;
2092 Result:=true;
2093 end;
2094
TStandardCodeTool.RenameIncludenull2095 function TStandardCodeTool.RenameInclude(LinkIndex: integer;
2096 const NewFilename: string; KeepPath: boolean;
2097 SourceChangeCache: TSourceChangeCache): boolean;
2098 { change filename in an include directive
2099 if KeepPath is true and the include dircetive contains a path
2100 (relative or absolute), then this path is kept and only the filename is
2101 replaced
2102 }
2103 var IncludeStart, IncludeEnd, FileStart, FileNameStart, FileEnd: integer;
2104 begin
2105 Result:=false;
2106 if (LinkIndex<0) or (LinkIndex>=Scanner.LinkCount) or (NewFileName='')
2107 or (KeepPath and (length(NewFilename)>255))
2108 or (SourceChangeCache=nil) then exit;
2109 // find include directive
2110 IncludeEnd:=Scanner.Links[LinkIndex].CleanedPos;
2111 IncludeStart:=IncludeEnd-1;
2112 if IncludeStart<1 then exit;
2113 FileEnd:=0;
2114 case Src[IncludeStart] of
2115 '}':
2116 begin
2117 FileEnd:=IncludeStart;
2118 dec(IncludeStart);
2119 while (IncludeStart>0) and (Src[IncludeStart]<>'{') do
2120 dec(IncludeStart);
2121 end;
2122 ')':
2123 begin
2124 dec(IncludeStart);
2125 FileEnd:=IncludeStart;
2126 while (IncludeStart>1)
2127 and ((Src[IncludeStart]<>'*') or (Src[IncludeStart-1]<>'(')) do
2128 dec(IncludeStart);
2129 end;
2130 #13,#10:
2131 begin
2132 FileEnd:=IncludeStart;
2133 if (FileEnd>0) and (IsLineEndChar[Src[FileEnd]]) then dec(FileEnd);
2134 dec(IncludeStart);
2135 while (IncludeStart>1)
2136 and ((Src[IncludeStart]<>'/') or (Src[IncludeStart-1]<>'/')) do
2137 dec(IncludeStart);
2138 end;
2139 end;
2140 if IncludeStart<1 then exit;
2141 FileStart:=IncludeStart;
2142 while (FileStart<IncludeEnd) and (Src[FileStart]<>'$') do
2143 inc(FileStart);
2144 while (FileStart<IncludeEnd) and (not (IsSpaceChar[Src[FileStart]])) do
2145 inc(FileStart);
2146 while (FileStart<IncludeEnd) and (IsSpaceChar[Src[FileStart]]) do
2147 inc(FileStart);
2148 if FileStart>=IncludeEnd then exit;
2149 SourceChangeCache.MainScanner:=Scanner;
2150 if KeepPath then begin
2151 FileNameStart:=FileEnd;
2152 while (FileNameStart>FileStart) and (Src[FileNameStart]<>PathDelim) do
2153 dec(FileNameStart);
2154 if Src[FileNameStart]=PathDelim then
2155 FileStart:=FileNameStart+1;
2156 end;
2157 if not SourceChangeCache.Replace(gtNone,GtNone,FileStart,FileEnd,
2158 NewFilename) then exit;
2159 if not SourceChangeCache.Apply then exit;
2160 Result:=true;
2161 end;
2162
TStandardCodeTool.CheckLFMnull2163 function TStandardCodeTool.CheckLFM(LFMBuf: TCodeBuffer; out LFMTree: TLFMTree;
2164 const OnFindDefineProperty: TOnFindDefinePropertyForContext;
2165 RootMustBeClassInUnit: boolean; RootMustBeClassInIntf: boolean;
2166 ObjectsMustExist: boolean): boolean;
2167 var
2168 RootContext: TFindContext;
2169
2170 function CheckLFMObjectValues(LFMObject: TLFMObjectNode;
2171 const ClassContext: TFindContext; ContextIsDefault: boolean): boolean; forward;
2172
FindNonPublishedDefinePropertynull2173 function FindNonPublishedDefineProperty(LFMNode: TLFMTreeNode;
2174 DefaultErrorPosition: integer;
2175 const IdentName: string; const ClassContext: TFindContext): boolean;
2176 // properties can be defined via DefineProperties
2177 var
2178 PropertyNode: TLFMPropertyNode;
2179 ObjectNode: TLFMObjectNode;
2180 AncestorClassContext: TFindContext;
2181 Params: TFindDeclarationParams;
2182 IsDefined: Boolean;
2183 begin
2184 Result:=false;
2185 if (not (LFMNode is TLFMPropertyNode)) then exit;
2186 PropertyNode:=TLFMPropertyNode(LFMNode);
2187 if (PropertyNode.Parent=nil)
2188 or (not (PropertyNode.Parent is TLFMObjectNode)) then exit;
2189 ObjectNode:=TLFMObjectNode(PropertyNode.Parent);
2190 // find define property
2191 IsDefined:=false;
2192 if Assigned(OnFindDefineProperty) then begin
2193 AncestorClassContext:=CleanFindContext;
2194 if ClassContext.Tool=Self then begin
2195 // the class is defined in this source
2196 // -> try to find the ancestor class
2197 if ObjectNode.AncestorContextValid then begin
2198 AncestorClassContext:=CreateFindContext(
2199 TFindDeclarationTool(ObjectNode.AncestorTool),
2200 TCodeTreeNode(ObjectNode.AncestorNode));
2201 end else begin
2202 {$IFDEF VerboseCheckLFM}
2203 debugln('FindNonPublishedDefineProperty Class is defined in this source: search ancestor ... ');
2204 {$ENDIF}
2205 Params:=TFindDeclarationParams.Create;
2206 try
2207 Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound,
2208 fdfExceptionOnPredefinedIdent];
2209 Params.ContextNode:=ClassContext.Node;
2210 try
2211 if ClassContext.Tool.FindAncestorOfClass(ClassContext.Node,
2212 Params,true) then
2213 begin
2214 {$IFDEF VerboseCheckLFM}
2215 debugln('FindNonPublishedDefineProperty Ancestor found');
2216 {$ENDIF}
2217 AncestorClassContext:=CreateFindContext(Params);
2218 ObjectNode.AncestorTool:=AncestorClassContext.Tool;
2219 ObjectNode.AncestorNode:=AncestorClassContext.Node;
2220 end;
2221 except
2222 // ignore search/parse errors
2223 on E: ECodeToolError do ;
2224 end;
2225 finally
2226 Params.Free;
2227 end;
2228 ObjectNode.AncestorContextValid:=true;
2229 end;
2230 end;
2231 OnFindDefineProperty(Self,ClassContext,AncestorClassContext,LFMNode,
2232 IdentName,IsDefined);
2233 if IsDefined then begin
2234 //debugln('FindNonPublishedDefineProperty Path=',LFMNode.GetPath,' IdentName="',IdentName,'"');
2235 end else begin
2236 {$IFDEF VerboseCheckLFM}
2237 debugln('FindNonPublishedDefineProperty Path=',LFMNode.GetPath,' NO DEFINE PROPERTIES');
2238 {$ENDIF}
2239 if DefaultErrorPosition=0 then ;
2240 end;
2241 end;
2242 Result:=IsDefined;
2243 end;
2244
FindLFMIdentifiernull2245 function FindLFMIdentifier(LFMNode: TLFMTreeNode;
2246 DefaultErrorPosition: integer;
2247 const IdentName: string; const ClassContext: TFindContext;
2248 SearchInDefinePropertiesToo, ErrorOnNotFound: boolean;
2249 out IdentContext: TFindContext): boolean;
2250 var
2251 Params: TFindDeclarationParams;
2252 IsPublished, IsMissingInCode: Boolean;
2253 CurContext: TFindContext;
2254 begin
2255 Result:=false;
2256 IdentContext:=CleanFindContext;
2257 IsPublished:=false;
2258 if (ClassContext.Node=nil)
2259 or (not (ClassContext.Node.Desc in AllClasses)) then begin
2260 DebugLn('TStandardCodeTool.CheckLFM.FindLFMIdentifier Internal error');
2261 exit;
2262 end;
2263 Params:=TFindDeclarationParams.Create;
2264 try
2265 Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound,
2266 fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
2267 fdfIgnoreOverloadedProcs];
2268 Params.ContextNode:=ClassContext.Node;
2269 Params.SetIdentifier(ClassContext.Tool,PChar(Pointer(IdentName)),nil);
2270 try
2271 {DebugLn('FindLFMIdentifier A ',
2272 ' Ident=',
2273 '"'+GetIdentifier(Params.Identifier)+'"',
2274 ' Context="'+ClassContext.Node.DescAsString,'" "',StringToPascalConst(copy(ClassContext.Tool.Src,ClassContext.Node.StartPos,20))+'"',
2275 ' File="'+ExtractFilename(ClassContext.Tool.MainFilename)+'"',
2276 ' Flags=['+FindDeclarationFlagsAsString(Params.Flags)+']'
2277 );}
2278 if ClassContext.Tool.FindIdentifierInContext(Params) then begin
2279 IdentContext:=CleanFindContext;
2280 repeat
2281 CurContext:=CreateFindContext(Params);
2282 if (not IsPublished)
2283 and (CurContext.Node.HasParentOfType(ctnClassPublished)) then
2284 IsPublished:=true;
2285
2286 if (IdentContext.Node=nil) then begin
2287 if (LFMNode.TheType<>lfmnProperty)
2288 or ((CurContext.Node.Desc=ctnProperty)
2289 and (not CurContext.Tool.PropNodeIsTypeLess(CurContext.Node)))
2290 then
2291 IdentContext:=CurContext;
2292 end;
2293
2294 if (IdentContext.Node<>nil) and IsPublished then break;
2295
2296 // search further
2297 Params.Clear;
2298 Params.Flags:=[fdfSearchInAncestors,
2299 fdfIgnoreMissingParams,
2300 fdfIgnoreCurContextNode,
2301 fdfIgnoreOverloadedProcs];
2302 Params.ContextNode:=CurContext.Node.Parent;
2303 while (Params.ContextNode<>nil)
2304 and (not (Params.ContextNode.Desc in AllClasses)) do
2305 Params.ContextNode:=Params.ContextNode.Parent;
2306 if Params.ContextNode=nil then break;
2307 Params.SetIdentifier(ClassContext.Tool,PChar(Pointer(IdentName)),nil);
2308 if not CurContext.Tool.FindIdentifierInContext(Params) then
2309 begin
2310 DebugLn(['FindLFMIdentifier ERROR ancestor of '+LFMNode.GetPath+' not found: ',FindContextToString(IdentContext),' IdentName=',IdentName]);
2311 break;
2312 end;
2313 until Params.NewNode=nil;
2314 end;
2315 except
2316 // ignore search/parse errors
2317 on E: ECodeToolError do ;
2318 end;
2319 finally
2320 Params.Free;
2321 end;
2322
2323 IsMissingInCode := False;
2324 if (IdentContext.Node<>nil) and IsPublished then begin
2325 Result:=true;
2326 end else begin
2327 // no proper node found -> search in DefineProperties
2328 if SearchInDefinePropertiesToo then begin
2329 if FindNonPublishedDefineProperty(LFMNode,DefaultErrorPosition,IdentName,ClassContext)
2330 then begin
2331 //debugln(['FindLFMIdentifier "',IdentName,'" is defined via DefineProperties']);
2332 Result:=true;
2333 end;
2334 end
2335 else
2336 IsMissingInCode := True;
2337 end;
2338 if (not Result) and ErrorOnNotFound then begin
2339 if (IdentContext.Node<>nil) and (not IsPublished) then begin
2340 LFMTree.AddError(lfmeIdentifierNotPublished,LFMNode,
2341 'identifier '+IdentName+' is not published in class '
2342 +'"'+ClassContext.Tool.ExtractClassName(ClassContext.Node,false,true)+'"',
2343 DefaultErrorPosition);
2344 end
2345 else if IsMissingInCode then begin
2346 LFMTree.AddError(lfmeIdentifierMissingInCode,LFMNode,
2347 'identifier '+IdentName+' not found in pascal code '
2348 +'"'+ClassContext.Tool.ExtractClassName(ClassContext.Node,false,true)+'"',
2349 DefaultErrorPosition);
2350 end
2351 else begin
2352 LFMTree.AddError(lfmeIdentifierNotFound,LFMNode,
2353 'identifier '+IdentName+' not found in class '
2354 +'"'+ClassContext.Tool.ExtractClassName(ClassContext.Node,false,true)+'"',
2355 DefaultErrorPosition);
2356 end;
2357 end;
2358 end;
2359
FindClassNodeForLFMObjectnull2360 function FindClassNodeForLFMObject(LFMNode: TLFMTreeNode;
2361 DefaultErrorPosition: integer;
2362 StartTool: TFindDeclarationTool; DefinitionNode: TCodeTreeNode): TFindContext;
2363 var
2364 Params: TFindDeclarationParams;
2365 Identifier: PChar;
2366 OldInput: TFindDeclarationInput;
2367 begin
2368 Result:=CleanFindContext;
2369 if (DefinitionNode.Desc=ctnIdentifier) then
2370 Identifier:=@StartTool.Src[DefinitionNode.StartPos]
2371 else if DefinitionNode.Desc=ctnProperty then
2372 Identifier:=StartTool.GetPropertyTypeIdentifier(DefinitionNode)
2373 else
2374 Identifier:=nil;
2375 if Identifier=nil then begin
2376 {$IFDEF VerboseCheckLFM}
2377 debugln(['FindClassNodeForLFMObject LFMNode=',LFMNode.GetPath,' definition node has no identifier: ',FindContextToString(CreateFindContext(StartTool,DefinitionNode))]);
2378 {$ENDIF}
2379 exit;
2380 end;
2381 Params:=TFindDeclarationParams.Create;
2382 try
2383 Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound,
2384 fdfSearchInParentNodes,
2385 fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
2386 fdfIgnoreOverloadedProcs,fdfIgnoreCurContextNode];
2387 Params.ContextNode:=DefinitionNode;
2388 Params.SetIdentifier(StartTool,Identifier,nil);
2389 try
2390 Params.Save(OldInput);
2391 if StartTool.FindIdentifierInContext(Params) then begin
2392 Params.Load(OldInput,true);
2393 Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode);
2394 if (Result.Node=nil) then begin
2395 {$IFDEF VerboseCheckLFM}
2396 debugln(['FindClassNodeForLFMObject FindBaseTypeOfNode failed. LFMNode=',LFMNode.GetPath,' ',FindContextToString(CreateFindContext(StartTool,DefinitionNode))]);
2397 {$ENDIF}
2398 Result:=CleanFindContext;
2399 end else if (not (Result.Node.Desc in AllClasses)) then begin
2400 {$IFDEF VerboseCheckLFM}
2401 debugln(['FindClassNodeForLFMObject base type is not a class. LFMNode=',LFMNode.GetPath,' ',FindContextToString(Result)]);
2402 {$ENDIF}
2403 Result:=CleanFindContext;
2404 end;
2405 end;
2406 except
2407 // ignore search/parse errors
2408 on E: ECodeToolError do begin
2409 {$IFDEF VerboseCheckLFM}
2410 debugln(['FindClassNodeForLFMObject ',E.Message]);
2411 {$ENDIF}
2412 end;
2413 end;
2414 finally
2415 Params.Free;
2416 end;
2417 if Result.Node=nil then begin
2418 // FindClassNodeForLFMObject
2419 LFMTree.AddError(lfmeIdentifierNotFound,LFMNode,
2420 'class '+GetIdentifier(Identifier)+' not found',
2421 DefaultErrorPosition);
2422 exit;
2423 end;
2424 end;
2425
CreateFootNotenull2426 function CreateFootNote(const Context: TFindContext): string;
2427 var
2428 Caret: TCodeXYPosition;
2429 begin
2430 Result:=' see '+Context.Tool.MainFilename;
2431 if Context.Tool.CleanPosToCaret(Context.Node.StartPos,Caret) then
2432 Result:=Result+'('+IntToStr(Caret.Y)+','+IntToStr(Caret.X)+')';
2433 end;
2434
FindClassContextnull2435 function FindClassContext(const ClassName: string): TFindContext;
2436 var
2437 Params: TFindDeclarationParams;
2438 Identifier: PChar;
2439 OldInput: TFindDeclarationInput;
2440 StartTool: TStandardCodeTool;
2441 begin
2442 Result:=CleanFindContext;
2443 Params:=TFindDeclarationParams.Create;
2444 StartTool:=Self;
2445 Identifier:=PChar(Pointer(ClassName));
2446 try
2447 Params.Flags:=[fdfExceptionOnNotFound,
2448 fdfSearchInParentNodes,
2449 fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
2450 fdfIgnoreOverloadedProcs];
2451 Params.ContextNode:=FindInterfaceNode;
2452 if Params.ContextNode=nil then
2453 Params.ContextNode:=FindMainUsesNode;
2454 Params.SetIdentifier(StartTool,Identifier,nil);
2455 try
2456 Params.Save(OldInput);
2457 if FindIdentifierInContext(Params) then begin
2458 Params.Load(OldInput,true);
2459 Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode);
2460 if (Result.Node=nil)
2461 or (not (Result.Node.Desc in AllClasses)) then
2462 Result:=CleanFindContext;
2463 end;
2464 except
2465 // ignore search/parse errors
2466 on E: ECodeToolError do ;
2467 end;
2468 finally
2469 Params.Free;
2470 end;
2471 end;
2472
2473 procedure CheckLFMChildObject(LFMObject: TLFMObjectNode;
2474 const ParentContext: TFindContext; ContextIsDefault: boolean);
2475 var
2476 LFMObjectName: String;
2477 ChildContext: TFindContext;
2478 VariableTypeName: String;
2479 DefinitionNode: TCodeTreeNode;
2480 ClassContext: TFindContext;
2481 IdentifierFound: Boolean;
2482 begin
2483 // find variable for object
2484
2485 // find identifier in Lookup Root
2486 LFMObjectName:=LFMObject.Name;
2487 //DebugLn('CheckChildObject A LFMObjectName="',LFMObjectName,'"');
2488 if LFMObjectName='' then begin
2489 LFMTree.AddError(lfmeObjectNameMissing,LFMObject,'missing object name',
2490 LFMObject.StartPos);
2491 exit;
2492 end;
2493
2494 ChildContext:=CleanFindContext;
2495 IdentifierFound:=(not ContextIsDefault) and
2496 FindLFMIdentifier(LFMObject,LFMObject.NamePosition,LFMObjectName,RootContext,
2497 false,ObjectsMustExist,ChildContext);
2498
2499 //debugln(['CheckLFMChildObject LFMObjectName="',LFMObjectName,'" IdentifierFound=',IdentifierFound,' ObjectsMustExist=',ObjectsMustExist,' ',FindContextToString(ChildContext)]);
2500 if IdentifierFound and (ObjectsMustExist or (ChildContext.Node<>nil)) then
2501 begin
2502 if ChildContext.Node=nil then begin
2503 // this is an extra entry, created via DefineProperties.
2504 // There is no generic way to test such things
2505 exit;
2506 end;
2507
2508 // check if identifier is a variable or property
2509 VariableTypeName:='';
2510 if (ChildContext.Node.Desc=ctnVarDefinition) then begin
2511 DefinitionNode:=ChildContext.Tool.FindTypeNodeOfDefinition(ChildContext.Node);
2512 if DefinitionNode<>nil then
2513 VariableTypeName:=ChildContext.Tool.ExtractDefinitionNodeType(ChildContext.Node);
2514 end else if (ChildContext.Node.Desc=ctnProperty) then begin
2515 DefinitionNode:=ChildContext.Node;
2516 VariableTypeName:=ChildContext.Tool.ExtractPropType(ChildContext.Node,false,false);
2517 end
2518 else
2519 DefinitionNode:=nil;
2520 if DefinitionNode=nil then begin
2521 LFMTree.AddError(lfmeObjectIncompatible,LFMObject,
2522 LFMObjectName+' is not a variable'
2523 +CreateFootNote(ChildContext),
2524 LFMObject.NamePosition);
2525 exit;
2526 end;
2527
2528 // check if variable/property has a compatible type
2529 if (VariableTypeName<>'') then begin
2530 if (LFMObject.TypeName<>'')
2531 and (CompareIdentifiers(PChar(VariableTypeName),
2532 PChar(LFMObject.TypeName))<>0)
2533 then begin
2534 ChildContext.Node:=DefinitionNode;
2535 LFMTree.AddError(lfmeObjectIncompatible,LFMObject,
2536 VariableTypeName+' expected, but '+LFMObject.TypeName+' found.'
2537 +CreateFootNote(ChildContext),
2538 LFMObject.NamePosition);
2539 exit;
2540 end;
2541
2542 // ToDo: check if variable/property type exists
2543
2544 end;
2545
2546
2547 // find class node
2548 //debugln(['CheckLFMChildObject searching class node: LFMObjectName="',LFMObjectName,'" ',FindContextToString(CreateFindContext(ChildContext.Tool,DefinitionNode))]);
2549 ClassContext:=FindClassNodeForLFMObject(LFMObject,LFMObject.TypeNamePosition,
2550 ChildContext.Tool,DefinitionNode);
2551 //debugln(['CheckLFMChildObject LFMObjectName="',LFMObjectName,'" class context: ',FindContextToString(ClassContext)]);
2552 end else begin
2553 // try the object type
2554 ClassContext:=FindClassContext(LFMObject.TypeName);
2555 if ClassContext.Node=nil then begin
2556 // object type not found
2557 LFMTree.AddError(lfmeIdentifierNotFound,LFMObject,
2558 'type '+LFMObject.TypeName+' not found',LFMObject.TypeNamePosition);
2559 end;
2560 end;
2561 // check child LFM nodes
2562 if ClassContext.Node<>nil then
2563 CheckLFMObjectValues(LFMObject,ClassContext,false)
2564 else
2565 CheckLFMObjectValues(LFMObject,ParentContext,true);
2566 end;
2567
FindClassNodeForPropertyTypenull2568 function FindClassNodeForPropertyType(LFMProperty: TLFMPropertyNode;
2569 DefaultErrorPosition: integer; const PropertyContext: TFindContext): TFindContext;
2570 var
2571 Params: TFindDeclarationParams;
2572 begin
2573 Result:=CleanFindContext;
2574 Params:=TFindDeclarationParams.Create;
2575 try
2576 Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound,
2577 fdfSearchInParentNodes,
2578 fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
2579 fdfIgnoreOverloadedProcs];
2580 Params.ContextNode:=PropertyContext.Node;
2581 Params.SetIdentifier(PropertyContext.Tool,nil,nil);
2582 try
2583 Result:=PropertyContext.Tool.FindBaseTypeOfNode(Params,
2584 PropertyContext.Node);
2585 except
2586 // ignore search/parse errors
2587 on E: ECodeToolError do ;
2588 end;
2589 finally
2590 Params.Free;
2591 end;
2592 if Result.Node=nil then begin
2593 LFMTree.AddError(lfmePropertyHasNoSubProperties,LFMProperty,
2594 'property has no sub properties',
2595 DefaultErrorPosition);
2596 exit;
2597 end;
2598 end;
2599
2600 procedure CheckLFMProperty(LFMProperty: TLFMPropertyNode;
2601 const ParentContext: TFindContext);
2602 // checks properties. For example lines like 'OnShow = FormShow'
2603 // or 'VertScrollBar.Range = 29'
2604 // LFMProperty is the property node
2605 // ParentContext is the context, where properties are searched.
2606 // This can be a class or a property.
2607 var
2608 i: Integer;
2609 CurName: string;
2610 CurPropertyContext: TFindContext;
2611 SearchContext: TFindContext;
2612 begin
2613 // find complete property name
2614 //DebugLn('CheckLFMProperty A LFMProperty Name="',LFMProperty.CompleteName,'" ParentContext=',FindContextToString(ParentContext));
2615
2616 if LFMProperty.CompleteName='' then begin
2617 LFMTree.AddError(lfmePropertyNameMissing,LFMProperty,
2618 'property without name',LFMProperty.StartPos);
2619 exit;
2620 end;
2621
2622 // find every part of the property name
2623 SearchContext:=ParentContext;
2624 for i:=0 to LFMProperty.NameParts.Count-1 do begin
2625 if SearchContext.Node.Desc=ctnProperty then begin
2626 // get the type of the property and search the class node
2627 SearchContext:=FindClassNodeForPropertyType(LFMProperty,
2628 LFMProperty.NameParts.NamePositions[i],SearchContext);
2629 if SearchContext.Node=nil then exit;
2630 end;
2631
2632 CurName:=LFMProperty.NameParts.Names[i];
2633 if not FindLFMIdentifier(LFMProperty,
2634 LFMProperty.NameParts.NamePositions[i],
2635 CurName,SearchContext,true,true,
2636 CurPropertyContext)
2637 then
2638 break;
2639 if CurPropertyContext.Node=nil then begin
2640 // this is an extra entry, created via DefineProperties.
2641 // There is no generic way to test such things
2642 break;
2643 end;
2644 SearchContext:=CurPropertyContext;
2645 end;
2646 // ToDo: check value
2647 end;
2648
CheckLFMObjectValuesnull2649 function CheckLFMObjectValues(LFMObject: TLFMObjectNode;
2650 const ClassContext: TFindContext; ContextIsDefault: boolean): boolean;
2651 var
2652 CurLFMNode: TLFMTreeNode;
2653 begin
2654 //DebugLn('TStandardCodeTool.CheckLFM.CheckLFMObjectValues A ',LFMObject.Name,':',LFMObject.TypeName);
2655 CurLFMNode:=LFMObject.FirstChild;
2656 while CurLFMNode<>nil do begin
2657 //DebugLn('TStandardCodeTool.CheckLFM.CheckLFMObjectValues B ',CurLFMNode.ClassName);
2658 case CurLFMNode.TheType of
2659 lfmnObject:
2660 CheckLFMChildObject(TLFMObjectNode(CurLFMNode),ClassContext,ContextIsDefault);
2661 lfmnProperty:
2662 if not ContextIsDefault then
2663 CheckLFMProperty(TLFMPropertyNode(CurLFMNode),ClassContext);
2664 end;
2665 CurLFMNode:=CurLFMNode.NextSibling;
2666 end;
2667 Result:=true;
2668 end;
2669
CheckLFMRootnull2670 function CheckLFMRoot(RootLFMNode: TLFMTreeNode): boolean;
2671 var
2672 LookupRootLFMNode: TLFMObjectNode;
2673 LookupRootTypeName: String;
2674 RootClassNode: TCodeTreeNode;
2675 begin
2676 Result:=false;
2677
2678 //DebugLn('TStandardCodeTool.CheckLFM.CheckLFMRoot checking root ...');
2679 // get root object node
2680 if (RootLFMNode=nil) or (not (RootLFMNode is TLFMObjectNode)) then begin
2681 LFMTree.AddError(lfmeMissingRoot,nil,'missing root object',1);
2682 exit;
2683 end;
2684 LookupRootLFMNode:=TLFMObjectNode(RootLFMNode);
2685
2686 // get type name of root object
2687 LookupRootTypeName:=LookupRootLFMNode.TypeName;
2688 if LookupRootTypeName='' then begin
2689 LFMTree.AddError(lfmeMissingRoot,nil,'missing type of root object',1);
2690 exit;
2691 end;
2692
2693 // find root type
2694 if RootMustBeClassInIntf then begin
2695 RootClassNode:=FindClassNodeInInterface(LookupRootTypeName,true,false,false);
2696 RootContext:=CleanFindContext;
2697 RootContext.Node:=RootClassNode;
2698 RootContext.Tool:=Self;
2699 end else if RootMustBeClassInUnit then begin
2700 RootClassNode:=FindClassNodeInUnit(LookupRootTypeName,true,false,false,false);
2701 RootContext:=CleanFindContext;
2702 RootContext.Node:=RootClassNode;
2703 RootContext.Tool:=Self;
2704 end else begin
2705 RootContext:=FindClassContext(LookupRootTypeName);
2706 RootClassNode:=RootContext.Node;
2707 end;
2708 if RootClassNode=nil then begin
2709 LFMTree.AddError(lfmeMissingRoot,LookupRootLFMNode,
2710 'type '+LookupRootLFMNode.TypeName+' not found',
2711 LookupRootLFMNode.TypeNamePosition);
2712 exit;
2713 end;
2714 Result:=CheckLFMObjectValues(LookupRootLFMNode,RootContext,false);
2715 end;
2716
2717 var
2718 CurRootLFMNode: TLFMTreeNode;
2719 begin
2720 Result:=false;
2721 //DebugLn('TStandardCodeTool.CheckLFM A');
2722 // create tree from LFM file
2723 LFMTree:=DefaultLFMTrees.GetLFMTree(LFMBuf,true);
2724 ActivateGlobalWriteLock;
2725 try
2726 //DebugLn('TStandardCodeTool.CheckLFM parsing LFM ...');
2727 if not LFMTree.ParseIfNeeded then exit;
2728 // parse unit and find LookupRoot
2729 //DebugLn('TStandardCodeTool.CheckLFM parsing unit ...');
2730 BuildTree(lsrImplementationUsesSectionEnd);
2731 // find every identifier
2732 //DebugLn('TStandardCodeTool.CheckLFM checking identifiers ...');
2733 CurRootLFMNode:=LFMTree.Root;
2734 while CurRootLFMNode<>nil do begin
2735 if not CheckLFMRoot(CurRootLFMNode) then exit;
2736 CurRootLFMNode:=CurRootLFMNode.NextSibling;
2737 end;
2738 finally
2739 DeactivateGlobalWriteLock;
2740 end;
2741 Result:=LFMTree.FirstError=nil;
2742 end;
2743
FindCreateFormStatementnull2744 function TStandardCodeTool.FindCreateFormStatement(StartPos: integer;
2745 const AClassName, AVarName: string;
2746 out Position: TAtomPosition): integer;
2747 // 0=found, -1=not found, 1=found, but wrong classname
2748 var MainBeginNode: TCodeTreeNode;
2749 ClassNameFits: boolean;
2750 begin
2751 Result:=-1;
2752 Position.StartPos:=-1;
2753 if (AClassName='') or (AVarName='') or (length(AClassName)>255)
2754 or (length(AVarName)>255) then exit;
2755 if StartPos<1 then begin
2756 BuildTree(lsrEnd);
2757 MainBeginNode:=FindMainBeginEndNode;
2758 if MainBeginNode=nil then exit;
2759 StartPos:=MainBeginNode.StartPos;
2760 if StartPos<1 then exit;
2761 end;
2762 MoveCursorToCleanPos(StartPos);
2763 repeat
2764 ReadNextAtom;
2765 if UpAtomIs('APPLICATION') then begin
2766 Position.StartPos:=CurPos.StartPos;
2767 if ReadNextAtomIsChar('.') and ReadNextUpAtomIs('CREATEFORM')
2768 and ReadNextAtomIsChar('(') then begin
2769 ReadNextAtom;
2770 ClassNameFits:=AtomIsIdentifier(PChar(AClassName));
2771 if ReadNextAtomIsChar(',')
2772 and (ReadNextAtomIsIdentifier(PChar(AVarName)) or (AVarName='*')) then begin
2773 if ReadNextAtomIsChar(')') then ReadNextAtomIsChar(';');
2774 Position.EndPos:=CurPos.EndPos;
2775 if ClassNameFits then
2776 Result:=0
2777 else
2778 Result:=1;
2779 exit;
2780 end;
2781 end;
2782 end;
2783 until (CurPos.StartPos>SrcLen);
2784 Result:=-1;
2785 end;
2786
TStandardCodeTool.AddCreateFormStatementnull2787 function TStandardCodeTool.AddCreateFormStatement(const AClassName,
2788 AVarName: string; SourceChangeCache: TSourceChangeCache): boolean;
2789 var MainBeginNode: TCodeTreeNode;
2790 OldPosition: TAtomPosition;
2791 FromPos, ToPos, Indent: integer;
2792 Beauty: TBeautifyCodeOptions;
2793 begin
2794 Result:=false;
2795 if (AClassName='') or (length(AClassName)>255) or (AVarName='')
2796 or (length(AVarName)>255) then exit;
2797 BuildTree(lsrEnd);
2798 MainBeginNode:=FindMainBeginEndNode;
2799 if MainBeginNode=nil then exit;
2800 Beauty:=SourceChangeCache.BeautifyCodeOptions;
2801 FromPos:=-1;
2802 if FindCreateFormStatement(MainBeginNode.StartPos,AClassName,
2803 AVarName,OldPosition)=-1
2804 then begin
2805 // does not exist -> create as last in front of 'Application.Run'
2806 MoveCursorToCleanPos(MainBeginNode.StartPos);
2807 repeat
2808 if ReadNextUpAtomIs('APPLICATION') then begin
2809 FromPos:=CurPos.StartPos;
2810 if ReadNextAtomIsChar('.') and ReadNextUpAtomIs('RUN') then begin
2811 break;
2812 end;
2813 FromPos:=-1;
2814 end;
2815 until (CurPos.StartPos>SrcLen);
2816 if FromPos<1 then exit;
2817 SourceChangeCache.MainScanner:=Scanner;
2818 Indent:=Beauty.GetLineIndent(Src,FromPos);
2819 FromPos:=FindLineEndOrCodeInFrontOfPosition(FromPos);
2820 SourceChangeCache.Replace(gtNewLine,gtNewLine,FromPos,FromPos,
2821 Beauty.BeautifyStatement(
2822 'Application.CreateForm('+AClassName+','+AVarName+');',Indent));
2823 end else begin
2824 // it exists -> replace it
2825 FromPos:=FindLineEndOrCodeInFrontOfPosition(OldPosition.StartPos);
2826 ToPos:=FindLineEndOrCodeAfterPosition(OldPosition.EndPos);
2827 SourceChangeCache.MainScanner:=Scanner;
2828 SourceChangeCache.Replace(gtNewLine,gtNewLine,FromPos,ToPos,
2829 Beauty.BeautifyStatement(
2830 'Application.CreateForm('+AClassName+','+AVarName+');',
2831 Beauty.Indent));
2832 end;
2833 Result:=SourceChangeCache.Apply;
2834 end;
2835
TStandardCodeTool.RemoveCreateFormStatementnull2836 function TStandardCodeTool.RemoveCreateFormStatement(const AVarName: string;
2837 SourceChangeCache: TSourceChangeCache): boolean;
2838 var Position: TAtomPosition;
2839 FromPos, ToPos: integer;
2840 begin
2841 Result:=false;
2842 if FindCreateFormStatement(-1,'*',AVarName,Position)=-1 then
2843 exit;
2844 FromPos:=FindLineEndOrCodeInFrontOfPosition(Position.StartPos);
2845 ToPos:=FindLineEndOrCodeAfterPosition(Position.EndPos);
2846 SourceChangeCache.MainScanner:=Scanner;
2847 SourceChangeCache.Replace(gtNone,gtNone,FromPos,ToPos,'');
2848 Result:=SourceChangeCache.Apply;
2849 end;
2850
TStandardCodeTool.ChangeCreateFormStatementnull2851 function TStandardCodeTool.ChangeCreateFormStatement(StartPos: integer;
2852 const OldClassName, OldVarName: string;
2853 const NewClassName, NewVarName: string;
2854 OnlyIfExists: boolean; SourceChangeCache: TSourceChangeCache): boolean;
2855 var MainBeginNode: TCodeTreeNode;
2856 OldPosition: TAtomPosition;
2857 FromPos, ToPos: integer;
2858 Beauty: TBeautifyCodeOptions;
2859 begin
2860 Result:=false;
2861 if (OldClassName='') or (length(OldClassName)>255)
2862 or (OldVarName='') or (length(OldVarName)>255)
2863 or (NewClassName='') or (length(NewClassName)>255)
2864 or (NewVarName='') or (length(NewVarName)>255)
2865 then exit;
2866 BuildTree(lsrEnd);
2867 Beauty:=SourceChangeCache.BeautifyCodeOptions;
2868 if StartPos<1 then begin
2869 MainBeginNode:=FindMainBeginEndNode;
2870 if MainBeginNode=nil then exit;
2871 StartPos:=MainBeginNode.StartPos;
2872 if StartPos<1 then exit;
2873 end;
2874 FromPos:=-1;
2875 if FindCreateFormStatement(StartPos,OldClassName,
2876 OldVarName,OldPosition)=-1 then begin
2877 // does not exist
2878 if OnlyIfExists then begin
2879 Result:=true;
2880 exit;
2881 end;
2882 Result:=AddCreateFormStatement(NewClassName,NewVarName,SourceChangeCache);
2883 end else begin
2884 // replace
2885 FromPos:=FindLineEndOrCodeInFrontOfPosition(OldPosition.StartPos);
2886 ToPos:=FindLineEndOrCodeAfterPosition(OldPosition.EndPos);
2887 SourceChangeCache.MainScanner:=Scanner;
2888 SourceChangeCache.Replace(gtNewLine,gtNewLine,FromPos,ToPos,
2889 Beauty.BeautifyStatement(
2890 'Application.CreateForm('+NewClassName+','+NewVarName+');',
2891 Beauty.Indent));
2892 Result:=SourceChangeCache.Apply;
2893 end;
2894 end;
2895
ListAllCreateFormStatementsnull2896 function TStandardCodeTool.ListAllCreateFormStatements: TStrings;
2897 // list format: VarName:ClassName
2898 var Position: integer;
2899 StatementPos: TAtomPosition;
2900 s:string;
2901 var MainBeginNode: TCodeTreeNode;
2902 begin
2903 BuildTree(lsrEnd);
2904 Result:=TStringList.Create;
2905 MainBeginNode:=FindMainBeginEndNode;
2906 if MainBeginNode=nil then exit;
2907 Position:=MainBeginNode.StartPos;
2908 repeat
2909 if FindCreateFormStatement(Position,'*','*',StatementPos)=-1 then
2910 exit;
2911 Position:=StatementPos.EndPos;
2912 MoveCursorToCleanPos(StatementPos.StartPos);
2913 ReadNextAtom; // read 'Application'
2914 ReadNextAtom; // read '.'
2915 ReadNextAtom; // read 'CreateForm'
2916 ReadNextAtom; // read '('
2917 ReadNextAtom; // read class name
2918 s:=GetAtom;
2919 ReadNextAtom; // read ','
2920 ReadNextAtom; // read variable name
2921 s:=GetAtom+':'+s;
2922 Result.Add(s);
2923 until false;
2924 end;
2925
TStandardCodeTool.SetAllCreateFromStatementsnull2926 function TStandardCodeTool.SetAllCreateFromStatements(List: TStrings;
2927 SourceChangeCache: TSourceChangeCache): boolean;
2928 { every string in the list has the format VarName:ClassName
2929 or simply VarName In the latter case it will be automatically expanded
2930 to VarName:TVarName
2931 }
2932 var Position, InsertPos, i, ColonPos, Indent: integer;
2933 StatementPos: TAtomPosition;
2934 MainBeginNode: TCodeTreeNode;
2935 AClassName, AVarName: string;
2936 LastEndPos: Integer;
2937 Beauty: TBeautifyCodeOptions;
2938 begin
2939 Result:= false;
2940 if (List = nil) or (SourceChangeCache = nil) then exit;
2941 BuildTree(lsrEnd);
2942
2943 { first delete all CreateForm Statements }
2944 SourceChangeCache.MainScanner:= Scanner;
2945 Beauty:=SourceChangeCache.BeautifyCodeOptions;
2946 MainBeginNode:=FindMainBeginEndNode;
2947 if MainBeginNode = nil then exit;
2948 Position:=MainBeginNode.StartPos;
2949 InsertPos:=-1;
2950 LastEndPos:=-1;
2951 repeat
2952 if FindCreateFormStatement(Position, '*', '*', StatementPos) = -1 then break;
2953
2954 Position:=StatementPos.EndPos;
2955 StatementPos.StartPos:=FindLineEndOrCodeInFrontOfPosition(StatementPos.StartPos);
2956 if (LastEndPos>0) and (StatementPos.StartPos<LastEndPos) then
2957 StatementPos.StartPos:=LastEndPos;
2958 if InsertPos < 1 then InsertPos:= StatementPos.StartPos;
2959
2960 StatementPos.EndPos:=FindLineEndOrCodeAfterPosition(StatementPos.EndPos);
2961 LastEndPos:=StatementPos.EndPos;
2962
2963 if not SourceChangeCache.Replace(gtNone,gtNone, StatementPos.StartPos, StatementPos.EndPos, '') then
2964 exit;
2965 until false;
2966
2967 Result:=SourceChangeCache.Apply;
2968 if not Result then exit;
2969
2970 { then add all CreateForm Statements }
2971 if InsertPos < 1 then begin
2972
2973 { there was no createform statement -> insert in front of Application.Run }
2974 MoveCursorToCleanPos(MainBeginNode.StartPos);
2975 repeat
2976 if ReadNextUpAtomIs('APPLICATION') then begin
2977 InsertPos:=CurPos.StartPos;
2978 if ReadNextAtomIsChar('.') and ReadNextUpAtomIs('RUN') then begin
2979 InsertPos:=FindLineEndOrCodeInFrontOfPosition(InsertPos);
2980 break;
2981 end;
2982 InsertPos:=-1;
2983 end;
2984 until (CurPos.StartPos>SrcLen);
2985 if InsertPos < 1 then exit;
2986 end;
2987
2988 for i:= 0 to List.Count - 1 do begin
2989 if Length(List[i]) <= 1 then continue;
2990
2991 ColonPos:= Pos(List[i], ':');
2992 if (ColonPos > 1) then begin
2993 AVarName:= Copy(List[i], 1, ColonPos);
2994 AClassName:= Copy(List[i], ColonPos + 1, Length(List[i]) - ColonPos);
2995 end else begin
2996 AVarName:= List[i];
2997 AClassName:= 'T' + AVarName;
2998 end;
2999 Indent:=Beauty.GetLineIndent(Src, InsertPos);
3000
3001 SourceChangeCache.Replace(gtNewLine, gtNewLine, InsertPos, InsertPos,
3002 SourceChangeCache.BeautifyCodeOptions.BeautifyStatement(
3003 'Application.CreateForm('+AClassName+','+AVarName+');', Indent));
3004 end;
3005 Result:= Result and SourceChangeCache.Apply;
3006 end;
3007
SetApplicationScaledStatementnull3008 function TStandardCodeTool.SetApplicationScaledStatement(
3009 const NewScaled: boolean; SourceChangeCache: TSourceChangeCache): boolean;
3010 begin
3011 Result := SetApplicationStatement('Scaled', BoolToStr(NewScaled, True), SourceChangeCache);
3012 end;
3013
TStandardCodeTool.SetApplicationStatementnull3014 function TStandardCodeTool.SetApplicationStatement(const APropertyName,
3015 NewCode: string; SourceChangeCache: TSourceChangeCache): boolean;
3016 var
3017 StartPos, ConstStartPos, EndPos: integer;
3018 NewStatement: String;
3019 Beauty: TBeautifyCodeOptions;
3020 begin
3021 Result:=false;
3022 Beauty:=SourceChangeCache.BeautifyCodeOptions;
3023 // search old Application.APropertyName:=XYZ statement
3024 FindApplicationStatement(UpperCase(APropertyName),StartPos,ConstStartPos,EndPos);
3025 // create statement. FindApplicationStatement always returns an insert point.
3026 NewStatement:='Application.'+APropertyName+':='+NewCode+';';
3027 NewStatement:=Beauty.BeautifyStatement(NewStatement,Beauty.Indent);
3028 SourceChangeCache.MainScanner:=Scanner;
3029 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,StartPos,EndPos,NewStatement) then
3030 exit;
3031 if not SourceChangeCache.Apply then exit;
3032 Result:=true;
3033 end;
3034
FindApplicationTitleStatementnull3035 function TStandardCodeTool.FindApplicationTitleStatement(out StartPos,
3036 StringConstStartPos, EndPos: integer): boolean;
3037 begin
3038 Result := FindApplicationStatement('TITLE', StartPos, StringConstStartPos, EndPos);
3039 end;
3040
TStandardCodeTool.GetApplicationTitleStatementnull3041 function TStandardCodeTool.GetApplicationTitleStatement(StringConstStartPos,
3042 EndPos: integer; var Title: string): boolean;
3043 var
3044 FormatStringParams: string;
3045 begin
3046 Result:=false;
3047 Title:='';
3048 if (StringConstStartPos<1) or (StringConstStartPos>SrcLen) then exit;
3049 MoveCursorToCleanPos(StringConstStartPos);
3050 ReadNextAtom;
3051 if not AtomIsStringConstant then exit;
3052 Result:=GetStringConstAsFormatString(StringConstStartPos,EndPos,Title,
3053 FormatStringParams);
3054 if FormatStringParams='' then ;
3055 end;
3056
TStandardCodeTool.SetApplicationTitleStatementnull3057 function TStandardCodeTool.SetApplicationTitleStatement(const NewTitle: string;
3058 SourceChangeCache: TSourceChangeCache): boolean;
3059 begin
3060 Result := SetApplicationStatement('Title', StringToPascalConst(NewTitle), SourceChangeCache);
3061 end;
3062
RemoveApplicationTitleStatementnull3063 function TStandardCodeTool.RemoveApplicationTitleStatement(
3064 SourceChangeCache: TSourceChangeCache): boolean;
3065 begin
3066 Result := RemoveApplicationStatement('TITLE', SourceChangeCache);
3067 end;
3068
TStandardCodeTool.RenameFormnull3069 function TStandardCodeTool.RenameForm(const OldFormName,
3070 OldFormClassName: string; const NewFormName, NewFormClassName: string;
3071 SourceChangeCache: TSourceChangeCache): boolean;
3072 var
3073 IdentList: TStringList;
3074 begin
3075 Result:=false;
3076 if (OldFormName='') or (OldFormClassName='')
3077 or (NewFormName='') or (NewFormClassName='')
3078 or (SourceChangeCache=nil) then exit;
3079 if (OldFormName=NewFormName)
3080 and (OldFormClassName=NewFormClassName) then exit;
3081 IdentList:=TStringList.Create;
3082 try
3083 if (OldFormName<>NewFormName) then begin
3084 IdentList.Add(OldFormName);
3085 IdentList.Add(NewFormName);
3086 end;
3087 if (OldFormClassName<>NewFormClassName) then begin
3088 IdentList.Add(OldFormClassName);
3089 IdentList.Add(NewFormClassName);
3090 end;
3091 Result:=ReplaceWords(IdentList,false,SourceChangeCache);
3092 finally
3093 IdentList.Free;
3094 end;
3095 end;
3096
TStandardCodeTool.FindFormAncestornull3097 function TStandardCodeTool.FindFormAncestor(const AClassName: string;
3098 var AncestorClassName: string): boolean;
3099 var
3100 ClassNode: TCodeTreeNode;
3101 begin
3102 Result:=false;
3103 AncestorClassName:='';
3104 if AClassName='' then exit;
3105 BuildTree(lsrImplementationStart);
3106 ClassNode:=FindClassNodeInInterface(AClassName,true,false,false);
3107 if (ClassNode=nil) then exit;
3108 // search the ancestor name
3109 MoveCursorToNodeStart(ClassNode);
3110 ReadNextAtom; // read keyword 'class', 'object', 'interface', 'dispinterface'
3111 while UpAtomIs('SEALED') or UpAtomIs('ABSTRACT') do ReadNextAtom;
3112 if UpAtomIs('PACKED') or UpAtomIs('BITPACKED') then ReadNextAtom;
3113 ReadNextAtom;
3114 if AtomIsChar('(') then begin
3115 ReadNextAtom;
3116 if UpAtomIs('SPECIALIZE') then
3117 ReadNextAtom;
3118 if AtomIsIdentifier then
3119 AncestorClassName:=GetAtom;
3120 end;
3121 if AncestorClassName='' then
3122 AncestorClassName:='TObject';
3123 Result:=true;
3124 end;
3125
3126 {-------------------------------------------------------------------------------
3127 function TStandardCodeTool.ReplaceWords(IdentList: TStrings;
3128 ChangeStrings: boolean; SourceChangeCache: TSourceChangeCache): boolean;
3129
3130 Search in all used sources (not only the cleaned source) for identifiers.
3131 It will find all identifiers, except identifiers in compiler directives.
3132 This includes identifiers in string constants and comments.
3133
3134 ChangeStrings = true, means to replace in string constants too
3135 -------------------------------------------------------------------------------}
ReplaceWordsnull3136 function TStandardCodeTool.ReplaceWords(IdentList: TStrings;
3137 ChangeStrings: boolean; SourceChangeCache: TSourceChangeCache;
3138 SkipPointWords: boolean): boolean;
3139
CheckIdentifiernull3140 function CheckIdentifier(const CurSource: string;
3141 IdentStart: integer): boolean;
3142 var
3143 p: integer;
3144 begin
3145 if not SkipPointWords then exit(true);
3146 p:=IdentStart-1;
3147 while (p>0) and (IsSpaceChar[CurSource[p]]) do dec(p);
3148 Result:=(p<1) or (CurSource[p]<>'.');
3149 end;
3150
3151 procedure ReplaceWordsInSource(ACode: TCodeBuffer);
3152 var
3153 StartPos, EndPos, MaxPos, IdentStart, IdentEnd: integer;
3154 CurSource: string;
3155 i: integer;
3156 begin
3157 CurSource:=ACode.Source;
3158 MaxPos:=length(CurSource);
3159 StartPos:=1;
3160 // go through all source parts between compiler directives
3161 //DebugLn('TStandardCodeTool.ReplaceWords ',ACode.Filename);
3162 repeat
3163 EndPos:=FindNextCompilerDirective(CurSource,StartPos,
3164 Scanner.NestedComments);
3165 if EndPos>MaxPos then EndPos:=MaxPos+1;
3166 // search all identifiers
3167 repeat
3168 if ChangeStrings then
3169 IdentStart:=FindNextIdentifier(CurSource,StartPos,EndPos-1)
3170 else
3171 IdentStart:=FindNextIdentifierSkipStrings(CurSource,StartPos,EndPos-1);
3172 if IdentStart>=EndPos then
3173 break;
3174 i:=0;
3175 while i<IdentList.Count do begin
3176 if (IdentList[i]<>'')
3177 and (BasicCodeTools.CompareIdentifiers(PChar(Pointer(IdentList[i])),
3178 @CurSource[IdentStart])=0)
3179 and CheckIdentifier(CurSource,IdentStart)
3180 and (IdentList[i]<>IdentList[i+1])
3181 then begin
3182 // identifier found -> replace
3183 IdentEnd:=IdentStart+length(IdentList[i]);
3184 //DebugLn('TStandardCodeTool.ReplaceWords replacing: ',
3185 //' "',copy(CurSource,IdentStart,IdentEnd-IdentStart),'" -> "',IdentList[i+1],'" at ',IdentStart
3186 //);
3187 SourceChangeCache.ReplaceEx(gtNone,gtNone,1,1,
3188 ACode,IdentStart,IdentEnd,IdentList[i+1]);
3189 break;
3190 end;
3191 inc(i,2);
3192 end;
3193 // skip identifier
3194 StartPos:=IdentStart;
3195 while (StartPos<MaxPos) and IsIdentChar[CurSource[StartPos]] do
3196 inc(StartPos);
3197 until false;
3198 if EndPos<=MaxPos then begin
3199 // skip comment
3200 StartPos:=FindCommentEnd(CurSource,EndPos,Scanner.NestedComments);
3201 if StartPos>MaxPos then break;
3202 end else begin
3203 break;
3204 end;
3205 until false;
3206 end;
3207
3208 var
3209 SourceList: TFPList;
3210 i: integer;
3211 begin
3212 Result:=false;
3213 if (IdentList=nil) or (IdentList.Count=0) or (SourceChangeCache=nil)
3214 or (Odd(IdentList.Count)) then exit;
3215 BuildTree(lsrEnd);
3216 if Scanner=nil then exit;
3217 SourceChangeCache.MainScanner:=Scanner;
3218 SourceList:=TFPList.Create;
3219 try
3220 Scanner.FindCodeInRange(1,SrcLen,SourceList);
3221 for i:=0 to SourceList.Count-1 do begin
3222 ReplaceWordsInSource(TCodeBuffer(SourceList[i]));
3223 end;
3224 finally
3225 SourceList.Free;
3226 end;
3227 if not SourceChangeCache.Apply then exit;
3228 Result:=true;
3229 end;
3230
TStandardCodeTool.FindNearestIdentifierNodenull3231 function TStandardCodeTool.FindNearestIdentifierNode(
3232 const CursorPos: TCodeXYPosition; IdentTree: TAVLTree): TAVLTreeNode;
3233 var
3234 CleanCursorPos: integer;
3235 BestDiff: Integer;
3236 CurIdentNode: TAVLTreeNode;
3237 CurDiff: Integer;
3238 begin
3239 Result:=nil;
3240 if IdentTree=nil then exit;
3241 BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanCursorPos,[]);
3242 BestDiff:=SrcLen+1;
3243 MoveCursorToCleanPos(1);
3244 repeat
3245 ReadNextAtom;
3246 if AtomIsIdentifier then begin
3247 CurIdentNode:=
3248 IdentTree.FindKey(@Src[CurPos.StartPos],
3249 TListSortCompare(@CompareIdentifiers));
3250 if CurIdentNode<>nil then begin
3251 CurDiff:=CurPos.StartPos-CleanCursorPos;
3252 if CurDiff<0 then CurDiff:=-CurDiff;
3253 if (Result=nil) or (CurDiff<BestDiff) then begin
3254 BestDiff:=CurDiff;
3255 Result:=CurIdentNode;
3256 end;
3257 end;
3258 end;
3259 until CurPos.EndPos>SrcLen;
3260 end;
3261
ReplaceWordnull3262 function TStandardCodeTool.ReplaceWord(const OldWord, NewWord: string;
3263 ChangeStrings: boolean; SourceChangeCache: TSourceChangeCache;
3264 SkipPointWords: boolean): boolean;
3265 var
3266 IdentList: TStringList;
3267 begin
3268 Result:=false;
3269 if OldWord='' then exit;
3270 if OldWord=NewWord then exit(true);
3271 if (SourceChangeCache=nil) then exit;
3272 IdentList:=TStringList.Create;
3273 try
3274 IdentList.Add(OldWord);
3275 IdentList.Add(NewWord);
3276 Result:=ReplaceWords(IdentList,ChangeStrings,SourceChangeCache,SkipPointWords);
3277 finally
3278 IdentList.Free;
3279 end;
3280 end;
3281
TStandardCodeTool.CommentCodenull3282 function TStandardCodeTool.CommentCode(const StartPos, EndPos: integer;
3283 SourceChangeCache: TSourceChangeCache; Apply: boolean): boolean;
3284 var
3285 i: LongInt;
3286 CurStartPos: LongInt;
3287 CommentNeeded: Boolean;
3288 CurEndPos: LongInt;
3289 begin
3290 if StartPos>=EndPos then
3291 RaiseException(20170421201123,'TStandardCodeTool CommentCode');
3292
3293 Result:=false;
3294 // comment with curly brackets {}
3295 i:=StartPos;
3296 CurStartPos:=i;
3297 CurEndPos:=CurStartPos;
3298 CommentNeeded:=false;
3299 repeat
3300 //debugln(['TPascalReaderTool.CommentCode ',dbgstr(Src[i]),' Needed=',CommentNeeded,' ',dbgstr(copy(Src,CurStartPos,CurEndPos-CurStartPos))]);
3301 if (Src[i]='{') or (i>=EndPos) then begin
3302 // the area contains a comment -> comment in front
3303 if CommentNeeded then begin
3304 if not SourceChangeCache.Replace(gtNone,gtNone,
3305 CurStartPos,CurStartPos,'{') then exit;
3306 if not SourceChangeCache.Replace(gtNone,gtNone,
3307 CurEndPos,CurEndPos,'}') then exit;
3308 //DebugLn('Comment "',copy(Src,CurStartPos,i-CurStartPos),'"');
3309 CommentNeeded:=false;
3310 end;
3311 if i>=EndPos then break;
3312 // skip comment
3313 i:=FindCommentEnd(Src,i,Scanner.NestedComments)-1;
3314 end else if not IsSpaceChar[Src[i]] then begin
3315 if not CommentNeeded then begin
3316 CurStartPos:=i;
3317 CommentNeeded:=true;
3318 end;
3319 CurEndPos:=i+1;
3320 end;
3321 inc(i);
3322 until false;
3323 if Apply then
3324 Result:=SourceChangeCache.Apply
3325 else
3326 Result:=true;
3327 end;
3328
TStandardCodeTool.GetStringConstBoundsnull3329 function TStandardCodeTool.GetStringConstBounds(
3330 const CursorPos: TCodeXYPosition;
3331 out StartPos, EndPos: TCodeXYPosition; ResolveComments: boolean): boolean;
3332 // examples:
..null3333 // 's1'+'s2'#13+AFunction(...)+inherited AMethod
3334 { $DEFINE VerboseGetStringConstBounds}
3335 type
3336 TStrConstTokenType = (scatNone, scatStrConst, scatPlus, scatIdent,
3337 scatInherited, scatPoint, scatUp,
3338 scatEdgedBracketOpen, scatEdgedBracketClose,
3339 scatRoundBracketOpen, scatRoundBracketClose);
3340
3341 {$IFDEF VerboseGetStringConstBounds}
EnumToStrnull3342 function EnumToStr(TokenType: TStrConstTokenType): string;
3343 begin
3344 WriteStr(Result, TokenType);
3345 end;
3346 {$ENDIF}
3347
GetCurrentTokenTypenull3348 function GetCurrentTokenType: TStrConstTokenType;
3349 begin
3350 if (CurPos.StartPos<1) or (CurPos.StartPos>SrcLen) then
3351 Result:=scatNone
3352 else if AtomIsStringConstant then
3353 Result:=scatStrConst
3354 else if AtomIsChar('+') then
3355 Result:=scatPlus
3356 else if AtomIsIdentifier then
3357 Result:=scatIdent
3358 else if UpAtomIs('INHERITED') then
3359 Result:=scatInherited
3360 else if CurPos.Flag=cafPoint then
3361 Result:=scatPoint
3362 else if AtomIsChar('^') then
3363 Result:=scatUp
3364 else if CurPos.Flag=cafRoundBracketOpen then
3365 Result:=scatRoundBracketOpen
3366 else if CurPos.Flag=cafRoundBracketClose then
3367 Result:=scatRoundBracketClose
3368 else if CurPos.Flag=cafEdgedBracketOpen then
3369 Result:=scatEdgedBracketOpen
3370 else if CurPos.Flag=cafEdgedBracketClose then
3371 Result:=scatEdgedBracketClose
3372 else
3373 Result:=scatNone;
3374 end;
3375
3376 var
3377 CleanCursorPos: integer;
3378 SameArea: TAtomPosition;
3379 LastToken, CurrentToken: TStrConstTokenType;
3380 StartCleanPos, EndCleanPos: integer;
3381 StringConstantFound: Boolean;
3382 begin
3383 StartPos:=CursorPos;
3384 EndPos:=CursorPos;
3385 Result:=true;
3386 BuildTreeAndGetCleanPos(CursorPos,CleanCursorPos);
3387 {$IFDEF VerboseGetStringConstBounds}
3388 DebugLn('TStandardCodeTool.GetStringConstBounds A Start at ',CleanPosToStr(CleanCursorPos),' "',copy(Src,CleanCursorPos-5,5),'" | "',copy(Src,CleanCursorPos,5),'"');
3389 {$ENDIF}
3390 GetCleanPosInfo(-1,CleanCursorPos,ResolveComments,SameArea);
3391 {$IFDEF VerboseGetStringConstBounds}
3392 DebugLn('TStandardCodeTool.GetStringConstBounds B Same Area: ',CleanPosToStr(SameArea.StartPos),'-',CleanPosToStr(SameArea.EndPos),' "',copy(Src,SameArea.StartPos,SameArea.EndPos-SameArea.StartPos),'"');
3393 {$ENDIF}
3394 if (SameArea.EndPos=SameArea.StartPos) or (SameArea.StartPos>SrcLen) then
3395 exit;
3396
3397 // read til end of string constant
3398 MoveCursorToCleanPos(SameArea.StartPos);
3399 ReadNextAtom;
3400 {$IFDEF VerboseGetStringConstBounds}
3401 DebugLn('TStandardCodeTool.GetStringConstBounds read til end of string Atom=',GetAtom);
3402 {$ENDIF}
3403 CurrentToken:=GetCurrentTokenType;
3404 if (CurrentToken=scatNone) then exit;
3405 StringConstantFound:=(CurrentToken=scatStrConst);
3406 repeat
3407 EndCleanPos:=CurPos.EndPos;
3408 ReadNextAtom;
3409 LastToken:=CurrentToken;
3410 CurrentToken:=GetCurrentTokenType;
3411 {$IFDEF VerboseGetStringConstBounds}
3412 DebugLn('TStandardCodeTool.GetStringConstBounds Read Forward: ',GetAtom,' EndCleanPos=',dbgs(EndCleanPos),
3413 ' LastToken=',EnumToStr(LastToken),
3414 ' CurrentToken=',EnumToStr(CurrentToken),' ',EnumToStr(GetCurrentTokenType));
3415 {$ENDIF}
3416 case CurrentToken of
3417 scatNone, scatEdgedBracketClose, scatRoundBracketClose:
3418 if not (LastToken in [scatStrConst,scatIdent,scatUp,
3419 scatEdgedBracketClose, scatRoundBracketClose])
3420 then
3421 exit
3422 else
3423 break;
3424
3425 scatStrConst:
3426 if not (LastToken in [scatPlus]) then
3427 exit
3428 else
3429 StringConstantFound:=true;
3430
3431 scatPlus:
3432 if not (LastToken in [scatStrConst, scatIdent, scatUp,
3433 scatEdgedBracketClose, scatRoundBracketClose]) then exit;
3434
3435 scatIdent:
3436 if not (LastToken in [scatPlus, scatPoint, scatInherited]) then exit;
3437
3438 scatInherited:
3439 if not (LastToken in [scatPlus, scatPoint]) then exit;
3440
3441 scatPoint:
3442 if not (LastToken in [scatIdent, scatUp, scatRoundBracketClose,
3443 scatEdgedBracketClose]) then
3444 exit;
3445
3446 scatEdgedBracketOpen,scatRoundBracketOpen:
3447 if not (LastToken in [scatIdent, scatUp]) then
3448 exit
3449 else begin
3450 ReadTilBracketClose(true);
3451 CurrentToken:=GetCurrentTokenType;
3452 end;
3453
3454 end;
3455 until false;
3456
3457 // read til start of string constant
3458 MoveCursorToCleanPos(SameArea.StartPos);
3459 ReadNextAtom;
3460 {$IFDEF VerboseGetStringConstBounds}
3461 DebugLn('TStandardCodeTool.GetStringConstBounds Read til start of string ',GetAtom);
3462 {$ENDIF}
3463 CurrentToken:=GetCurrentTokenType;
3464 repeat
3465 StartCleanPos:=CurPos.StartPos;
3466 ReadPriorAtom;
3467 {$IFDEF VerboseGetStringConstBounds}
3468 DebugLn('TStandardCodeTool.GetStringConstBounds Read backward: ',GetAtom,' StartCleanPos=',dbgs(StartCleanPos));
3469 {$ENDIF}
3470 LastToken:=CurrentToken;
3471 CurrentToken:=GetCurrentTokenType;
3472 case CurrentToken of
3473 scatNone, scatEdgedBracketOpen, scatRoundBracketOpen:
3474 if not (LastToken in [scatStrConst,scatIdent,scatPlus]) then
3475 exit
3476 else
3477 break;
3478
3479 scatStrConst:
3480 if not (LastToken in [scatPlus]) then
3481 exit
3482 else
3483 StringConstantFound:=true;
3484
3485 scatPlus:
3486 if not (LastToken in [scatStrConst, scatIdent, scatRoundBracketOpen]) then
3487 exit;
3488
3489 scatIdent:
3490 if not (LastToken in [scatPlus, scatPoint, scatUp, scatRoundBracketOpen,
3491 scatEdgedBracketOpen]) then exit;
3492
3493 scatInherited:
3494 if not (LastToken in [scatIdent]) then exit;
3495
3496 scatPoint:
3497 if not (LastToken in [scatIdent]) then exit;
3498
3499 scatEdgedBracketClose,scatRoundBracketClose:
3500 if not (LastToken in [scatPlus, scatUp, scatPoint]) then
3501 exit
3502 else begin
3503 ReadBackTilBracketOpen(true);
3504 CurrentToken:=GetCurrentTokenType;
3505 end;
3506
3507 end;
3508 until false;
3509
3510 // convert start and end position
3511 {$IFDEF VerboseGetStringConstBounds}
3512 DebugLn('TStandardCodeTool.GetStringConstBounds END "',copy(Src,StartCleanPos,EndCleanPos-StartCleanPos),'" StringConstantFound=',dbgs(StringConstantFound));
3513 {$ENDIF}
3514 if not StringConstantFound then begin
3515 EndCleanPos:=StartCleanPos;
3516 end;
3517 if not CleanPosToCaret(StartCleanPos,StartPos) then exit;
3518 if not CleanPosToCaret(EndCleanPos,EndPos) then exit;
3519
3520 Result:=true;
3521 end;
3522
TStandardCodeTool.GetStringConstAsFormatStringnull3523 function TStandardCodeTool.GetStringConstAsFormatString(StartPos,
3524 EndPos: integer; out FormatStringConstant, FormatParameters: string;
3525 out StartInStringConst, EndInStringConst: boolean): boolean;
3526 { Converts a string constant into the parameters for a Format call of the
3527 system unit.
3528
3529 Examples:
3530
3531 'Hallo' -> "Hallo", ""
3532 'A'+IntToStr(1) -> "A%s", "IntToStr(1)"
3533 'A%B'#13#10 -> "A%sB%s", "'%', #13#10"
3534 }
3535 procedure AddChar(c: char);
3536 begin
3537 FormatStringConstant:=FormatStringConstant+c;
3538 end;
3539
3540 procedure AddParameter(const NewParam: string);
3541 begin
3542 FormatStringConstant:=FormatStringConstant+'%s';
3543 if FormatParameters<>'' then
3544 FormatParameters:=FormatParameters+',';
3545 FormatParameters:=FormatParameters+NewParam;
3546 end;
3547
3548 procedure AddParameter(ParamStartPos,ParamEndPos: integer);
3549 begin
3550 AddParameter(copy(Src,ParamStartPos,ParamEndPos-ParamStartPos));
3551 end;
3552
3553 procedure ConvertStringConstant;
3554 var
3555 APos: Integer;
3556 CharConstStart: Integer;
3557 InRange: Boolean;
3558 begin
3559 if (CurPos.StartPos<StartPos) and (CurPos.EndPos>StartPos) then
3560 StartInStringConst:=true;
3561 if (CurPos.StartPos<EndPos) and (CurPos.EndPos>EndPos) then
3562 EndInStringConst:=true;
3563
3564 APos:=CurPos.StartPos;
3565 while APos<EndPos do begin
3566 InRange:=(APos>=StartPos);
3567 //debugln('ConvertStringConstant InRange=',dbgs(InRange),' Src[APos]=',Src[APos]);
3568 if Src[APos]='''' then begin
3569 // read string constant
3570 inc(APos);
3571 while APos<EndPos do begin
3572 InRange:=(APos>=StartPos);
3573 case Src[APos] of
3574 '''':
3575 if (APos<EndPos-1) and (Src[APos+1]='''') then begin
3576 // a double ' means a single '
3577 if InRange then begin
3578 AddChar('''');
3579 AddChar('''');
3580 end;
3581 inc(APos,2);
3582 end else begin
3583 // a single ' means end of string constant
3584 inc(APos);
3585 break;
3586 end;
3587 else
3588 begin
3589 // normal char
3590 if InRange then
3591 AddChar(Src[APos]);
3592 inc(APos);
3593 end;
3594 end;
3595 end;
3596 end else if Src[APos]='#' then begin
3597 CharConstStart:=APos;
3598 InRange:=(APos+1>=StartPos);
3599 repeat
3600 // read char constant
3601 inc(APos);
3602 if APos<EndPos then begin
3603 if Src[APos-1]='#' then begin
3604 if IsNumberChar[Src[APos]] then begin
3605 // read decimal number
3606 while (APos<EndPos) and IsNumberChar[Src[APos]] do
3607 inc(APos);
3608 end else if Src[APos]='$' then begin
3609 // read hexnumber
3610 while (APos<EndPos) and IsHexNumberChar[Src[APos]] do
3611 inc(APos);
3612 end;
3613 end;
3614 end;
3615 until (APos>=EndPos) or (Src[APos]<>'#');
3616 if InRange then
3617 AddParameter(CharConstStart,APos);
3618 end else
3619 break;
3620 end;
3621 end;
3622
3623 procedure ConvertOther;
3624 var
3625 ParamStartPos: Integer;
3626 ParamEndPos: Integer;
3627 begin
3628 // read till next string constant
3629 ParamStartPos:=CurPos.StartPos;
3630 ParamEndPos:=ParamStartPos;
3631 while (not AtomIsStringConstant) and (CurPos.EndPos<=EndPos) do begin
3632 if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then
3633 ReadTilBracketClose(true);
3634 if not AtomIsChar('+') then ParamEndPos:=CurPos.EndPos;
3635 ReadNextAtom;
3636 end;
3637 if ParamEndPos>ParamStartPos then
3638 AddParameter(ParamStartPos,ParamEndPos);
3639 if AtomIsStringConstant then UndoReadNextAtom;
3640 end;
3641
3642 var
3643 ANode: TCodeTreeNode;
3644 CodePosInFront: LongInt;
3645 begin
3646 Result:=false;
3647 // read string constants and convert it
3648 FormatStringConstant:='';
3649 FormatParameters:='';
3650 StartInStringConst:=false;
3651 EndInStringConst:=false;
3652 ANode:=FindDeepestNodeAtPos(StartPos,True);
3653 CodePosInFront:=ANode.StartPos;
3654 MoveCursorToCleanPos(CodePosInFront);
3655 if EndPos>SrcLen then EndPos:=SrcLen+1;
3656 repeat
3657 ReadNextAtom;
3658 //debugln('GetStringConstAsFormatString Atom=',GetAtom);
3659 if (CurPos.StartPos>=EndPos) then break;
3660 if CurPos.EndPos>StartPos then begin
3661 //debugln('GetStringConstAsFormatString Parsing...');
3662 if AtomIsStringConstant then begin
3663 // a string constant
3664 ConvertStringConstant;
3665 end else if AtomIsChar('+') then begin
3666 // simply ignore
3667 end else if (CurPos.Flag=cafRoundBracketOpen) or AtomIsIdentifier
3668 then begin
3669 // add as parameter
3670 ConvertOther;
3671 end else
3672 // string constant end
3673 break;
3674 end;
3675 until false;
3676 Result:=FormatStringConstant<>'';
3677 end;
3678
GetStringConstAsFormatStringnull3679 function TStandardCodeTool.GetStringConstAsFormatString(StartPos,
3680 EndPos: integer; out FormatStringConstant, FormatParameters: string
3681 ): boolean;
3682 var
3683 StartInStringConst, EndInStringConstant: boolean;
3684 begin
3685 Result:=GetStringConstAsFormatString(StartPos,EndPos,FormatStringConstant,
3686 FormatParameters,StartInStringConst,EndInStringConstant);
3687 if StartInStringConst then ;
3688 if EndInStringConstant then ;
3689 end;
3690
ExtractOperandnull3691 function TStandardCodeTool.ExtractOperand(const CursorPos: TCodeXYPosition; out
3692 Operand: string; WithPostTokens, WithAsOperator,
3693 WithoutTrailingPoints: boolean): boolean;
3694 var
3695 CleanPos: integer;
3696 StartPos: LongInt;
3697 EndPos: LongInt;
3698 Node: TCodeTreeNode;
3699 begin
3700 Result:=false;
3701 Operand:='';
3702 if CursorPos.Code.LineColIsSpace(CursorPos.Y,CursorPos.X) then exit;
3703 BuildTreeAndGetCleanPos(CursorPos,CleanPos);
3704 Node:=FindDeepestNodeAtPos(CleanPos,true);
3705 StartPos:=FindStartOfTerm(CleanPos,NodeTermInType(Node));
3706 if StartPos<1 then exit;
3707 StartPos:=FindNextNonSpace(Src,StartPos);
3708 if StartPos>CleanPos then exit;
3709 EndPos:=FindEndOfTerm(CleanPos,false,WithAsOperator);
3710 if not WithPostTokens then begin
3711 MoveCursorToCleanPos(CleanPos);
3712 ReadNextAtom;
3713 if CurPos.EndPos<EndPos then
3714 EndPos:=CurPos.EndPos;
3715 end;
3716 if EndPos<1 then exit;
3717 //DebugLn(['TStandardCodeTool.ExtractOperand "',dbgstr(copy(Src,StartPos,EndPos-StartPos)),'"']);
3718 Operand:=ExtractCode(StartPos,EndPos,[phpCommentsToSpace]);
3719 if WithoutTrailingPoints then begin
3720 while (Operand<>'') and (Operand[length(Operand)]='.') do
3721 Operand:=copy(Operand,1,length(Operand)-1);
3722 end;
3723 Result:=true;
3724 end;
3725
FindApplicationScaledStatementnull3726 function TStandardCodeTool.FindApplicationScaledStatement(out StartPos,
3727 BooleanConstStartPos, EndPos: integer): boolean;
3728 begin
3729 Result := FindApplicationStatement('SCALED', StartPos, BooleanConstStartPos, EndPos);
3730 end;
3731
FindApplicationStatementnull3732 function TStandardCodeTool.FindApplicationStatement(const APropertyUpCase: string;
3733 out StartPos, ConstStartPos, EndPos: integer): boolean;
3734 // Find statement "Application.APropertyUpCase:=XYZ;" and return True if found.
3735 // Also return its positions (Start, const "XYZ" and End) in out parameters.
3736 // If not found, out parameters get a good position to insert such a statement.
3737 var
3738 MainBeginNode: TCodeTreeNode;
3739 AppPos, FirstAppPos: Integer;
3740 begin
3741 Result:=false;
3742 StartPos:=-1;
3743 ConstStartPos:=-1;
3744 EndPos:=-1;
3745 FirstAppPos:=-1;
3746 BuildTree(lsrEnd);
3747 MainBeginNode:=FindMainBeginEndNode;
3748 if (MainBeginNode=nil) or (MainBeginNode.StartPos<1) then exit;
3749 MoveCursorToCleanPos(MainBeginNode.StartPos);
3750 repeat
3751 ReadNextAtom;
3752 if UpAtomIs('APPLICATION') then
3753 begin
3754 AppPos:=CurPos.StartPos;
3755 if FirstAppPos=-1 then
3756 FirstAppPos:=AppPos;
3757 ReadNextAtom;
3758 if AtomIsChar('.') then
3759 begin // Application.APropertyUpCase:=XYZ;
3760 if ReadNextUpAtomIs(APropertyUpCase) and ReadNextUpAtomIs(':=') then
3761 begin
3762 StartPos:=AppPos;
3763 repeat // read till semicolon or end
3764 ReadNextAtom;
3765 if ConstStartPos<1 then
3766 ConstStartPos:=CurPos.StartPos;
3767 EndPos:=CurPos.EndPos;
3768 if CurPos.Flag in [cafEnd,cafSemicolon] then
3769 exit(true);
3770 until CurPos.StartPos>SrcLen;
3771 end;
3772 end
3773 else // Application:=TMyApplication.Create(nil);
3774 if UpAtomIs(':=') and ReadNextUpAtomIs('TMYAPPLICATION')
3775 and ReadNextAtomIsChar('.') and ReadNextUpAtomIs('CREATE') then
3776 repeat // read till semicolon or end
3777 ReadNextAtom;
3778 StartPos:=CurPos.EndPos; // Insert point behind the TMyApplication.Create line.
3779 if CurPos.Flag in [cafEnd,cafSemicolon] then
3780 break;
3781 until CurPos.StartPos>SrcLen;
3782 end; // UpAtomIs('APPLICATION')
3783 until (CurPos.StartPos>SrcLen);
3784 // The statement was not found. Return a good place for insertion.
3785 if StartPos=-1 then
3786 if FirstAppPos <> -1 then
3787 StartPos:=FirstAppPos // Before first Application statement if there is one
3788 else begin
3789 MoveCursorToNodeStart(MainBeginNode);
3790 ReadNextAtom;
3791 StartPos:=CurPos.EndPos; // or after the main Begin.
3792 end;
3793 EndPos:=StartPos; // Both StartPos and EndPos return the same insert point.
3794 end;
3795
GatherResourceStringSectionsnull3796 function TStandardCodeTool.GatherResourceStringSections(
3797 const CursorPos: TCodeXYPosition; PositionList: TCodeXYPositions): boolean;
3798
3799 function SearchInUsesSection(UsesNode: TCodeTreeNode): boolean;
3800 var
3801 NewCodeTool: TPascalReaderTool;
3802 IntfNode: TCodeTreeNode;
3803 NewCaret: TCodeXYPosition;
3804 Node: TCodeTreeNode;
3805 AnUnitName, InFilename: string;
3806 begin
3807 Result:=false;
3808 if UsesNode=nil then exit(true);
3809 Node:=UsesNode.LastChild;
3810 while Node<>nil do begin
3811 AnUnitName:=ExtractUsedUnitName(Node,@InFilename);
3812 // open the unit
3813 NewCodeTool:=FindCodeToolForUsedUnit(AnUnitName,InFilename,true);
3814 NewCodeTool.BuildTree(lsrImplementationStart);
3815 // search all resource string sections in the interface
3816 IntfNode:=NewCodeTool.FindInterfaceNode;
3817 if (IntfNode<>nil) and (IntfNode.LastChild<>nil) then begin
3818 IntfNode:=IntfNode.LastChild;
3819 while IntfNode<>nil do begin
3820 if IntfNode.Desc=ctnResStrSection then begin
3821 if not NewCodeTool.CleanPosToCaret(IntfNode.StartPos,NewCaret) then
3822 break;
3823 //DebugLn('TStandardCodeTool.GatherResourceStringSections Found Other ',NewCodeTool.MainFilename,' Y=',NewCaret.Y);
3824 PositionList.Add(NewCaret);
3825 end;
3826 IntfNode:=IntfNode.PriorBrother;
3827 end;
3828 end;
3829 Node:=Node.PriorBrother;
3830 end;
3831 Result:=true;
3832 end;
3833
3834 var
3835 CleanCursorPos: integer;
3836 CursorNode: TCodeTreeNode;
3837 NewCaret: TCodeXYPosition;
3838 ANode: TCodeTreeNode;
3839 begin
3840 Result:=false;
3841 //DebugLn('TStandardCodeTool.GatherResourceStringSections A ');
3842 BuildTreeAndGetCleanPos(CursorPos,CleanCursorPos);
3843 CursorNode:=FindDeepestNodeAtPos(CleanCursorPos,true);
3844 PositionList.Clear;
3845 ANode:=CursorNode;
3846 while ANode<>nil do begin
3847 case ANode.Desc of
3848
3849 ctnResStrSection:
3850 begin
3851 if not CleanPosToCaret(ANode.StartPos,NewCaret) then exit;
3852 //DebugLn('TStandardCodeTool.GatherResourceStringSections Found Same Y=',NewCaret.Y);
3853 PositionList.Add(NewCaret);
3854 end;
3855
3856 ctnUsesSection:
3857 if not SearchInUsesSection(ANode) then break;
3858
3859 end;
3860
3861 // go to next node
3862 if ANode.PriorBrother<>nil then begin
3863 ANode:=ANode.PriorBrother;
3864 if (ANode.Desc=ctnInterface) and (ANode.LastChild<>nil) then
3865 ANode:=ANode.LastChild;
3866 end else begin
3867 ANode:=ANode.Parent;
3868 end;
3869 end;
3870 Result:=true;
3871 end;
3872
IdentifierExistsInResourceStringSectionnull3873 function TStandardCodeTool.IdentifierExistsInResourceStringSection(
3874 const CursorPos: TCodeXYPosition; const ResStrIdentifier: string): boolean;
3875 var
3876 CleanCursorPos: integer;
3877 ANode: TCodeTreeNode;
3878 begin
3879 Result:=false;
3880 if ResStrIdentifier='' then exit;
3881 // parse source and find clean positions
3882 BuildTreeAndGetCleanPos(CursorPos,CleanCursorPos);
3883 // find resource string section
3884 ANode:=FindDeepestNodeAtPos(CleanCursorPos,true);
3885 if (ANode=nil) then exit;
3886 ANode:=ANode.GetNodeOfType(ctnResStrSection);
3887 if ANode=nil then exit;
3888 // search identifier in section
3889 ANode:=ANode.FirstChild;
3890 while ANode<>nil do begin
3891 if (ANode.Desc=ctnConstDefinition)
3892 and CompareSrcIdentifiers(ANode.StartPos,PChar(ResStrIdentifier)) then begin
3893 Result:=true;
3894 exit;
3895 end;
3896 ANode:=ANode.NextBrother;
3897 end;
3898 end;
3899
CreateIdentifierFromStringConstnull3900 function TStandardCodeTool.CreateIdentifierFromStringConst(const StartCursorPos,
3901 EndCursorPos: TCodeXYPosition; out Identifier: string;
3902 MaxLen: integer): boolean;
3903 var
3904 StartPos, EndPos: integer;
3905 Dummy: Integer;
3906 IdentStr: String;
3907 ANode: TCodeTreeNode;
3908 CodePosInFront: LongInt;
3909 begin
3910 Result:=false;
3911 if MaxLen<=0 then exit;
3912 // parse source and find clean positions
3913 BuildTreeAndGetCleanPos(StartCursorPos,StartPos);
3914 Dummy:=CaretToCleanPos(EndCursorPos, EndPos);
3915 if (Dummy<>0) and (Dummy<>-1) then exit;
3916 ANode:=FindDeepestNodeAtPos(StartPos,True);
3917 CodePosInFront:=ANode.StartPos;
3918 // read string constants and extract identifier characters
3919 Identifier:='';
3920 MoveCursorToCleanPos(CodePosInFront);
3921 repeat
3922 ReadNextAtom;
3923 //debugln('TStandardCodeTool.CreateIdentifierFromStringConst Atom=',GetAtom);
3924 if (CurPos.StartPos>=EndPos) then break;
3925 if AtomIsStringConstant then begin
3926 IdentStr:=ExtractIdentCharsFromStringConstant(CurPos.StartPos,
3927 StartPos,EndPos,MaxLen-length(Identifier));
3928 //debugln('TStandardCodeTool.CreateIdentifierFromStringConst IdentStr=',IdentStr);
3929 if (IdentStr<>'') then begin
3930 IdentStr[1]:=UpChars[IdentStr[1]];
3931 Identifier:=Identifier+IdentStr;
3932 end;
3933 end;
3934 until length(Identifier)>=MaxLen;
3935 Result:=Identifier<>'';
3936 end;
3937
StringConstToFormatStringnull3938 function TStandardCodeTool.StringConstToFormatString(const StartCursorPos,
3939 EndCursorPos: TCodeXYPosition;
3940 out FormatStringConstant, FormatParameters: string;
3941 out StartInStringConst, EndInStringConst: boolean): boolean;
3942 var
3943 StartPos,EndPos,Dummy: Integer;
3944 begin
3945 Result:=false;
3946 // parse source and find clean positions
3947 BuildTreeAndGetCleanPos(StartCursorPos,StartPos);
3948 Dummy:=CaretToCleanPos(EndCursorPos, EndPos);
3949 if (Dummy<>0) and (Dummy<>-1) then exit;
3950 Result:=GetStringConstAsFormatString(StartPos,EndPos,FormatStringConstant,
3951 FormatParameters,StartInStringConst,EndInStringConst);
3952 end;
3953
HasInterfaceRegisterProcnull3954 function TStandardCodeTool.HasInterfaceRegisterProc(out HasRegisterProc: boolean
3955 ): boolean;
3956
3957 function IsRegisterProc(ANode: TCodeTreeNode): boolean;
3958 begin
3959 Result:=false;
3960 if ANode=nil then exit;
3961 if ANode.Desc=ctnProcedureHead then
3962 ANode:=Anode.Parent;
3963 if (ANode.Desc<>ctnProcedure) then exit;
3964 MoveCursorToNodeStart(ANode);
3965 if not ReadNextUpAtomIs('PROCEDURE') then exit;
3966 if not ReadNextUpAtomIs('REGISTER') then exit;
3967 if CurPos.Flag<>cafSemicolon then exit;
3968 HasRegisterProc:=true;
3969 Result:=true;
3970 end;
3971
3972 var
3973 InterfaceNode: TCodeTreeNode;
3974 ANode: TCodeTreeNode;
3975 begin
3976 Result:=false;
3977 HasRegisterProc:=false;
3978 ANode:=FindDeclarationNodeInInterface('Register',true);
3979 if ANode=nil then exit;
3980 if IsRegisterProc(ANode) then
3981 exit(true);
3982 // there may be multiple register
3983 InterfaceNode:=FindInterfaceNode;
3984 ANode:=InterfaceNode.FirstChild;
3985 while ANode<>nil do begin
3986 if IsRegisterProc(ANode) then
3987 exit(true);
3988 ANode:=ANode.NextBrother;
3989 end;
3990 end;
3991
ConvertDelphiToLazarusSourcenull3992 function TStandardCodeTool.ConvertDelphiToLazarusSource(AddLRSCode: boolean;
3993 SourceChangeCache: TSourceChangeCache): boolean;
3994 var
3995 Beauty: TBeautifyCodeOptions;
3996
3997 function AddModeDelphiDirective: boolean;
3998 var
3999 ModeDirectivePos: integer;
4000 InsertPos: Integer;
4001 begin
4002 Result:=false;
4003 BuildTree(lsrInterfaceStart);
4004 if not FindModeDirective(false,ModeDirectivePos) then begin
4005 // add {$MODE Delphi} behind source type
4006 if Tree.Root=nil then exit;
4007 MoveCursorToNodeStart(Tree.Root);
4008 ReadNextAtom; // 'unit', 'program', ..
4009 ReadNextAtom; // name
4010 ReadNextAtom; // semicolon
4011 InsertPos:=CurPos.EndPos;
4012 SourceChangeCache.Replace(gtEmptyLine,gtEmptyLine,InsertPos,InsertPos,
4013 '{$MODE Delphi}');
4014 if not SourceChangeCache.Apply then exit;
4015 end;
4016 // changing mode requires rescan
4017 BuildTree(lsrImplementationStart);
4018 Result:=true;
4019 end;
4020
4021 function ConvertUsedUnits: boolean;
4022 // replace unit 'Windows' with 'LCLIntf' and add 'LResources'
4023 // rename 'in' filenames to case sensitive filename
4024 var
4025 NamePos, InPos: TAtomPosition;
4026 begin
4027 Result:=false;
4028 if FindUnitInAllUsesSections('WINDOWS',NamePos,InPos)
4029 and (InPos.StartPos<1) then begin
4030 if not SourceChangeCache.Replace(gtNone,gtNone,
4031 NamePos.StartPos,NamePos.EndPos,'LCLIntf') then
4032 begin
4033 debugln('ConvertUsedUnits Unable to replace Windows with LCLIntf unit');
4034 exit;
4035 end;
4036 end;
4037 if AddLRSCode then
4038 if not AddUnitToMainUsesSection('LResources','',SourceChangeCache) then
4039 begin
4040 debugln('ConvertUsedUnits Unable to add LResources to main uses section');
4041 exit;
4042 end;
4043 if not RemoveUnitFromAllUsesSections('VARIANTS',SourceChangeCache) then
4044 begin
4045 debugln('ConvertUsedUnits Unable to remove Variants from all uses sections');
4046 exit;
4047 end;
4048 if not FixUsedUnitCase(SourceChangeCache) then
4049 begin
4050 debugln('ConvertUsedUnits Unable to fix unit filename case sensitivity in all uses sections');
4051 exit;
4052 end;
4053 Result:=true;
4054 end;
4055
4056 function RemoveDFMResourceDirective: boolean;
4057 // remove {$R *.dfm} or {$R *.xfm} directive
4058 var
4059 ParamPos: Integer;
4060 ACleanPos: Integer;
4061 StartPos: Integer;
4062 s: String;
4063 begin
4064 Result:=false;
4065 // find $R directive
4066 ACleanPos:=1;
4067 repeat
4068 ACleanPos:=FindNextCompilerDirectiveWithName(Src,ACleanPos,'R',
4069 Scanner.NestedComments,ParamPos);
4070 if (ACleanPos<1) or (ACleanPos>SrcLen) or (ParamPos>SrcLen) then break;
4071 s:=UpperCaseStr(copy(Src,ParamPos,6));
4072 if (Src[ACleanPos]='{')
4073 and ((s='*.DFM}') or (s='*.XFM}'))
4074 then begin
4075 StartPos:=FindLineEndOrCodeInFrontOfPosition(ACleanPos,true);
4076 if not SourceChangeCache.Replace(gtNone,gtNone,StartPos,ParamPos+6,'')
4077 then exit;
4078 break;
4079 end;
4080 ACleanPos:=FindCommentEnd(Src,ACleanPos,Scanner.NestedComments);
4081 until false;
4082 Result:=true;
4083 end;
4084
4085 function AddLRSIncludeDirective: boolean;
4086 // add initialization and {$i unit.lrs} include directive
4087 var
4088 FirstInclude: TCodeBuffer;
4089 LRSFilename: String;
4090 InitializationNode: TCodeTreeNode;
4091 ImplementationNode: TCodeTreeNode;
4092 NewCode: String;
4093 InsertPos: Integer;
4094 LinkIndex: Integer;
4095 begin
4096 Result:=false;
4097 if AddLRSCode then begin
4098 LRSFilename:=ExtractFilenameOnly(MainFilename)+'.lrs';
4099 LinkIndex:=-1;
4100 FirstInclude:=FindNextIncludeInInitialization(LinkIndex);
4101 if (FirstInclude<>nil)
4102 and (CompareFilenames(FirstInclude.Filename,LRSFilename)=0) then begin
4103 // already there
4104 Result:=true;
4105 exit;
4106 end;
4107 if Tree.Root.Desc=ctnUnit then begin
4108 InitializationNode:=FindInitializationNode;
4109 NewCode:=Beauty.GetIndentStr(Beauty.Indent)
4110 +'{$i '+LRSFilename+'}';
4111 if InitializationNode=nil then begin
4112 // add also an initialization section
4113 ImplementationNode:=FindImplementationNode;
4114 InsertPos:=ImplementationNode.EndPos;
4115 NewCode:=Beauty.BeautifyKeyWord(
4116 'initialization')
4117 +Beauty.LineEnd
4118 +NewCode;
4119 if not SourceChangeCache.Replace(gtEmptyLine,gtEmptyLine,
4120 InsertPos,InsertPos,
4121 NewCode) then exit;
4122 end else begin
4123 InsertPos:=InitializationNode.StartPos+length('initialization');
4124 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,
4125 InsertPos,InsertPos,
4126 NewCode) then exit;
4127 end;
4128 end else begin
4129 // only Units supported yet
4130 exit;
4131 end;
4132 end;
4133 Result:=true;
4134 end;
4135
4136 begin
4137 Result:=false;
4138 if SourceChangeCache=nil then exit;
4139 SourceChangeCache.MainScanner:=Scanner;
4140 Beauty:=SourceChangeCache.BeautifyCodeOptions;
4141 DebugLn('ConvertDelphiToLazarusSource AddModeDelphiDirective');
4142 if not AddModeDelphiDirective then exit;
4143 DebugLn('ConvertDelphiToLazarusSource RemoveDFMResourceDirective');
4144 if not RemoveDFMResourceDirective then exit;
4145 DebugLn('ConvertDelphiToLazarusSource AddLRSIncludeDirective');
4146 if not AddLRSIncludeDirective then exit;
4147 DebugLn('ConvertDelphiToLazarusSource ConvertUsedUnits');
4148 if not ConvertUsedUnits then exit;
4149 DebugLn('ConvertDelphiToLazarusSource Apply');
4150 if not SourceChangeCache.Apply then exit;
4151 DebugLn('ConvertDelphiToLazarusSource END');
4152 Result:=true;
4153 end;
4154
GetIDEDirectivesnull4155 function TStandardCodeTool.GetIDEDirectives(DirectiveList: TStrings;
4156 const Filter: TOnIDEDirectiveFilter): boolean;
4157 var
4158 StartPos: Integer;
4159 EndPos: Integer;
4160 begin
4161 Result:=false;
4162 DirectiveList.Clear;
4163 BuildTree(lsrImplementationStart);
4164 EndPos:=1;
4165 repeat
4166 StartPos:=FindNextIDEDirective(Src,EndPos,Scanner.NestedComments);
4167 if StartPos<1 then break;
4168 EndPos:=FindCommentEnd(Src,StartPos,Scanner.NestedComments);
4169 if (Filter=nil) or Filter(Self,StartPos,EndPos) then
4170 DirectiveList.Add(copy(Src,StartPos,EndPos-StartPos));
4171 if EndPos>SrcLen then break;
4172 StartPos:=EndPos;
4173 until false;
4174 Result:=true;
4175 end;
4176
SetIDEDirectivesnull4177 function TStandardCodeTool.SetIDEDirectives(DirectiveList: TStrings;
4178 SourceChangeCache: TSourceChangeCache; const Filter: TOnIDEDirectiveFilter
4179 ): boolean;
4180 var
4181 InsertPos: Integer;
4182 EndPos: Integer;
4183 StartPos: Integer;
4184 InsertTxt: String;
4185 ImplementationNode: TCodeTreeNode;
4186 begin
4187 Result:=false;
4188 if SourceChangeCache=nil then exit;
4189 SourceChangeCache.MainScanner:=Scanner;
4190 BuildTree(lsrEnd);
4191
4192 // find first old IDE directive
4193 InsertPos:=FindNextIDEDirective(Src,1,Scanner.NestedComments);
4194 if InsertPos>=1 then begin
4195 EndPos:=FindCommentEnd(Src,InsertPos,Scanner.NestedComments);
4196 if (Filter<>nil) and (not Filter(Self,InsertPos,EndPos)) then
4197 InsertPos:=0;
4198 end else
4199 InsertPos:=0;
4200
4201 // remove all old IDE directives
4202 if InsertPos>=1 then
4203 EndPos:=InsertPos
4204 else
4205 EndPos:=1;
4206 repeat
4207 // find next IDE directive
4208 StartPos:=FindNextIDEDirective(Src,EndPos,Scanner.NestedComments);
4209 if StartPos<1 then break;
4210 EndPos:=FindCommentEnd(Src,StartPos,Scanner.NestedComments);
4211 if (Filter=nil) or Filter(Self,StartPos,EndPos) then begin
4212 // remove also space in front of directive
4213 while (StartPos>1) and (Src[StartPos-1] in [' ',#9]) do dec(StartPos);
4214 // remove also space behind directive
4215 while (EndPos<=SrcLen) and (Src[EndPos] in [' ',#9]) do inc(EndPos);
4216 if (EndPos<=SrcLen) and (Src[EndPos] in [#10,#13]) then begin
4217 inc(EndPos);
4218 if (EndPos<=SrcLen) and (Src[EndPos] in [#10,#13])
4219 and (Src[EndPos]<>Src[EndPos-1]) then
4220 inc(EndPos);
4221 end;
4222 // remove directive
4223 if not SourceChangeCache.Replace(gtNone,gtNone,StartPos,EndPos,'') then
4224 exit;
4225 end;
4226 if EndPos>SrcLen then break;
4227 StartPos:=EndPos;
4228 until false;
4229
4230 // find a nice insert position
4231 ImplementationNode:=FindImplementationNode;
4232 if (ImplementationNode<>nil)
4233 and (ImplementationNode.StartPos<=InsertPos) then
4234 InsertPos:=0;
4235 if InsertPos<1 then begin
4236 // set default insert position
4237 InsertPos:=1;
4238 if (Tree<>nil) and (Tree.Root<>nil) then
4239 InsertPos:=Tree.Root.StartPos;
4240 end;
4241
4242 // add directives
4243 InsertTxt:=ChompLineEndsAtEnd(DirectiveList.Text);
4244 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,InsertPos,InsertPos,
4245 InsertTxt) then exit;
4246 if not SourceChangeCache.Apply then exit;
4247
4248 Result:=true;
4249 end;
4250
4251 procedure TStandardCodeTool.CalcMemSize(Stats: TCTMemStats);
4252 begin
4253 inherited CalcMemSize(Stats);
4254 end;
4255
GatherResourceStringsWithValuenull4256 function TStandardCodeTool.GatherResourceStringsWithValue(
4257 const CursorPos: TCodeXYPosition; const StringValue: string;
4258 PositionList: TCodeXYPositions): boolean;
4259
4260 procedure CompareStringConst(ANode: TCodeTreeNode);
4261 var
4262 CurValue: String;
4263 NewCaret: TCodeXYPosition;
4264 begin
4265 MoveCursorToNodeStart(ANode);
4266 ReadNextAtom; // read identifier
4267 if not AtomIsIdentifier then exit;
4268 ReadNextAtom; // read =
4269 if CurPos.Flag<>cafEqual then exit;
4270 ReadNextAtom; // read start of string constant
4271 if not AtomIsStringConstant then exit;
4272 // extract string constant value
4273 CurValue:=ReadStringConstantValue(CurPos.StartPos);
4274 if CurValue<>StringValue then exit;
4275 // values are the same
4276 // -> add it to position list
4277 // get x,y position
4278 if not CleanPosToCaret(ANode.StartPos,NewCaret) then exit;
4279 //DebugLn('TStandardCodeTool.GatherResourceStringsWithValue Found ',MainFilename,' Y=',NewCaret.Y);
4280 PositionList.Add(NewCaret);
4281 end;
4282
4283 var
4284 CleanCursorPos: integer;
4285 ANode: TCodeTreeNode;
4286 begin
4287 Result:=false;
4288 if PositionList=nil then exit;
4289 // parse source and find clean positions
4290 BuildTreeAndGetCleanPos(CursorPos,CleanCursorPos);
4291 // find resource string section
4292 ANode:=FindDeepestNodeAtPos(CleanCursorPos,true);
4293 if (ANode=nil) then exit;
4294 ANode:=ANode.GetNodeOfType(ctnResStrSection);
4295 if ANode=nil then exit;
4296 // search identifier in section
4297 ANode:=ANode.FirstChild;
4298 while ANode<>nil do begin
4299 if (ANode.Desc=ctnConstDefinition) then begin
4300 CompareStringConst(ANode);
4301 end;
4302 ANode:=ANode.NextBrother;
4303 end;
4304 end;
4305
GetApplicationScaledStatementnull4306 function TStandardCodeTool.GetApplicationScaledStatement(BooleanConstStartPos,
4307 EndPos: integer; var AScaled: boolean): boolean;
4308 begin
4309 Result:=false;
4310 AScaled:=false;
4311 if (BooleanConstStartPos<1) or (BooleanConstStartPos>SrcLen) then exit;
4312 MoveCursorToCleanPos(BooleanConstStartPos);
4313 ReadNextAtom;
4314 if (EndPos>0) and (CurPos.EndPos>EndPos) then exit;
4315 if UpAtomIs('TRUE') then
4316 begin
4317 AScaled := True;
4318 Result := True;
4319 end;
4320 if UpAtomIs('FALSE') then
4321 begin
4322 AScaled := False;
4323 Result := True;
4324 end;
4325 end;
4326
GatherResourceStringIdentsnull4327 function TStandardCodeTool.GatherResourceStringIdents(
4328 const SectionPos: TCodeXYPosition; var IdentTree: TAVLTree): boolean;
4329 var
4330 CleanCursorPos: integer;
4331 ANode: TCodeTreeNode;
4332 begin
4333 Result:=false;
4334 IdentTree:=nil;
4335 // parse source and find clean positions
4336 BuildTreeAndGetCleanPos(SectionPos,CleanCursorPos);
4337 // find resource string section
4338 ANode:=FindDeepestNodeAtPos(CleanCursorPos,true);
4339 if (ANode=nil) then exit;
4340 ANode:=ANode.GetNodeOfType(ctnResStrSection);
4341 if ANode=nil then exit;
4342 // search identifier in section
4343 ANode:=ANode.FirstChild;
4344 while ANode<>nil do begin
4345 if (ANode.Desc=ctnConstDefinition) then begin
4346 if IdentTree=nil then
4347 IdentTree:=TAVLTree.Create(TListSortCompare(@BasicCodeTools.CompareIdentifiers));
4348 IdentTree.Add(@Src[ANode.StartPos]);
4349 end;
4350 ANode:=ANode.NextBrother;
4351 end;
4352 Result:=true;
4353 end;
4354
FindNearestResourceStringnull4355 function TStandardCodeTool.FindNearestResourceString(const CursorPos,
4356 SectionPos: TCodeXYPosition; var NearestPos: TCodeXYPosition): boolean;
4357 var
4358 CursorTool, SectionTool: TStandardCodeTool;
4359 IdentTree: TAVLTree;
4360 NearestNode: TAVLTreeNode;
4361 NearestCleanPos: Integer;
4362 begin
4363 Result:=false;
4364 NearestPos.Code:=nil;
4365 // get both codetools
4366 if not Assigned(OnGetCodeToolForBuffer) then exit;
4367 CursorTool:=
4368 TStandardCodeTool(OnGetCodeToolForBuffer(Self,CursorPos.Code,true));
4369 SectionTool:=
4370 TStandardCodeTool(OnGetCodeToolForBuffer(Self,SectionPos.Code,true));
4371 if (CursorTool=nil) or (SectionTool=nil) then exit;
4372 // get all resourcestring identifiers
4373 IdentTree:=nil;
4374 Result:=SectionTool.GatherResourceStringIdents(SectionPos,IdentTree);
4375 if IdentTree=nil then exit;
4376 try
4377 // find nearest resourcestring identifier in the cursor source
4378 NearestNode:=CursorTool.FindNearestIdentifierNode(CursorPos,IdentTree);
4379 if NearestNode=nil then exit;
4380 // convert node to cleanpos
4381 NearestCleanPos:={%H-}PtrUInt(NearestNode.Data)-{%H-}PtrUInt(@SectionTool.Src[1])+1;
4382 // convert cleanpos to caret
4383 CleanPosToCaret(NearestCleanPos,NearestPos);
4384 finally
4385 IdentTree.Free;
4386 end;
4387 Result:=true;
4388 end;
4389
AddResourceStringnull4390 function TStandardCodeTool.AddResourceString(const SectionPos: TCodeXYPosition;
4391 const NewIdentifier, NewValue: string;
4392 InsertPolicy: TResourcestringInsertPolicy;
4393 const NearestPos: TCodeXYPosition;
4394 SourceChangeCache: TSourceChangeCache): boolean;
4395 var
4396 CleanSectionPos: integer;
4397 ANode, SectionNode: TCodeTreeNode;
4398 Indent: Integer;
4399 InsertPos: Integer;
4400 InsertSrc: String;
4401 NearestCleanPos: integer;
4402 Beauty: TBeautifyCodeOptions;
4403 begin
4404 Result:=false;
4405 //DebugLn('TStandardCodeTool.AddResourcestring A ',NewIdentifier,'=',NewValue,' ');
4406 if (NewIdentifier='') or (length(NewIdentifier)>255) then exit;
4407 if SourceChangeCache=nil then exit;
4408 SourceChangeCache.MainScanner:=Scanner;
4409 // parse source and find clean positions
4410 //DebugLn('TStandardCodeTool.AddResourcestring B');
4411 BuildTreeAndGetCleanPos(SectionPos,CleanSectionPos);
4412 //DebugLn('TStandardCodeTool.AddResourcestring C');
4413 // find resource string section
4414 SectionNode:=FindDeepestNodeAtPos(CleanSectionPos,true);
4415 if (SectionNode=nil) then exit;
4416 SectionNode:=SectionNode.GetNodeOfType(ctnResStrSection);
4417 if SectionNode=nil then exit;
4418
4419 Beauty:=SourceChangeCache.BeautifyCodeOptions;
4420 //DebugLn('TStandardCodeTool.AddResourcestring D SectionChilds=',SectionNode.FirstChild<>nil);
4421 // find insert position
4422 if SectionNode.FirstChild=nil then begin
4423 // no resourcestring in this section yet -> append as first child
4424 Indent:=Beauty.GetLineIndent(Src,SectionNode.StartPos)+Beauty.Indent;
4425 InsertPos:=SectionNode.StartPos+length('RESOURCESTRING');
4426 end else begin
4427 // search insert position
4428 case InsertPolicy of
4429 rsipAlphabetically:
4430 begin
4431 // insert new identifier alphabetically
4432 ANode:=SectionNode.FirstChild;
4433 while (ANode<>nil) do begin
4434 if (ANode.Desc=ctnConstDefinition)
4435 and (CompareIdentifiers(@Src[ANode.StartPos],
4436 PChar(Pointer(NewIdentifier)))<0)
4437 then
4438 break;
4439 ANode:=ANode.NextBrother;
4440 end;
4441 if ANode=nil then begin
4442 // append new identifier as last
4443 Indent:=Beauty.GetLineIndent(Src,SectionNode.LastChild.StartPos);
4444 InsertPos:=FindLineEndOrCodeAfterPosition(SectionNode.LastChild.EndPos);
4445 end else begin
4446 // insert in front of node
4447 Indent:=Beauty.GetLineIndent(Src,ANode.StartPos);
4448 InsertPos:=FindLineEndOrCodeInFrontOfPosition(ANode.StartPos);
4449 end;
4450 end;
4451
4452 rsipContext:
4453 begin
4454 // find nearest
4455 ANode:=nil;
4456 if (NearestPos.Code<>nil)
4457 and (CaretToCleanPos(NearestPos,NearestCleanPos)=0) then begin
4458 ANode:=SectionNode.FirstChild;
4459 while (ANode<>nil) do begin
4460 if (ANode.Desc=ctnConstDefinition)
4461 and (ANode.StartPos<=NearestCleanPos)
4462 and (ANode.EndPos>NearestCleanPos)
4463 then begin
4464 break;
4465 end;
4466 ANode:=ANode.NextBrother;
4467 end;
4468 end;
4469 if ANode=nil then begin
4470 // append new identifier as last
4471 Indent:=Beauty.GetLineIndent(Src,SectionNode.LastChild.StartPos);
4472 InsertPos:=FindLineEndOrCodeAfterPosition(SectionNode.LastChild.EndPos);
4473 end else begin
4474 // insert behind node
4475 Indent:=Beauty.GetLineIndent(Src,ANode.StartPos);
4476 InsertPos:=FindLineEndOrCodeAfterPosition(ANode.EndPos);
4477 end;
4478 end;
4479
4480 else
4481 begin
4482 // append new identifier
4483 Indent:=Beauty.GetLineIndent(Src,SectionNode.LastChild.StartPos);
4484 InsertPos:=FindLineEndOrCodeAfterPosition(SectionNode.LastChild.EndPos);
4485 end;
4486 end;
4487 end;
4488
4489 //DebugLn('TStandardCodeTool.AddResourcestring E Indent=',Indent,' InsertPos=',InsertPos,' ',copy(Src,InsertPos-9,8),'|',copy(Src,InsertPos,8));
4490 // insert
4491 InsertSrc:=SourceChangeCache.BeautifyCodeOptions.BeautifyStatement(
4492 NewIdentifier+' = '+NewValue+';',Indent);
4493 //DebugLn('TStandardCodeTool.AddResourcestring F "',InsertSrc,'"');
4494 SourceChangeCache.Replace(gtNewLine,gtNewLine,InsertPos,InsertPos,InsertSrc);
4495 SourceChangeCache.Apply;
4496 Result:=true;
4497 //DebugLn('TStandardCodeTool.AddResourcestring END ',Result);
4498 end;
4499
FindPublishedVariablenull4500 function TStandardCodeTool.FindPublishedVariable(const AClassName,
4501 AVarName: string; ExceptionOnClassNotFound: boolean): TCodeTreeNode;
4502 var ClassNode, SectionNode: TCodeTreeNode;
4503 begin
4504 Result:=nil;
4505 if (AClassName='') or (length(AClassName)>255) then
4506 RaiseExceptionFmt(20170421201129,ctsinvalidClassName, [AClassName]);
4507 if AVarName='' then exit;
4508 BuildTree(lsrImplementationStart);
4509 ClassNode:=FindClassNodeInInterface(AClassName,true,false,false);
4510 if ClassNode=nil then begin
4511 if ExceptionOnClassNotFound then
4512 RaiseExceptionFmt(20170421201136,ctsclassNotFound, [AClassName])
4513 else
4514 exit;
4515 end;
4516 SectionNode:=ClassNode.FirstChild;
4517 while (SectionNode<>nil) do begin
4518 if SectionNode.Desc=ctnClassPublished then begin
4519 Result:=SectionNode.FirstChild;
4520 while Result<>nil do begin
4521 if (Result.Desc=ctnVarDefinition) then begin
4522 MoveCursorToNodeStart(Result);
4523 if ReadNextAtomIsIdentifier(PChar(AVarName)) then
4524 exit;
4525 end;
4526 Result:=Result.NextBrother;
4527 end;
4528 end;
4529 SectionNode:=SectionNode.NextBrother;
4530 end;
4531 end;
4532
AddPublishedVariablenull4533 function TStandardCodeTool.AddPublishedVariable(const AClassName,
4534 VarName, VarType: string; SourceChangeCache: TSourceChangeCache): boolean;
4535 var ClassNode, SectionNode: TCodeTreeNode;
4536 Indent, InsertPos: integer;
4537 Beauty: TBeautifyCodeOptions;
4538 begin
4539 Result:=false;
4540 if (AClassName='') or (length(AClassName)>255) then
4541 RaiseExceptionFmt(20170421201143,ctsinvalidClassName2, [AClassName]);
4542 if (VarName='') or (length(VarName)>255) then
4543 RaiseExceptionFmt(20170421201152,ctsinvalidVariableName, [VarName]);
4544 if (VarType='') or (length(VarType)>255) then
4545 RaiseExceptionFmt(20170421201158,ctsinvalidVariableType, [VarType]);
4546 if (SourceChangeCache=nil) then
4547 RaiseException(20170421201203,'missing SourceChangeCache');
4548 if FindPublishedVariable(AClassName,VarName,true)<>nil then
4549 begin
4550 Result:=true;
4551 exit;
4552 end;
4553 ClassNode:=FindClassNodeInInterface(AClassName,true,false,true);
4554 if ClassNode=nil then
4555 RaiseExceptionFmt(20170421201208,ctsclassNotFound, [AClassName]);
4556 SectionNode:=ClassNode.FirstChild;
4557 if (SectionNode.NextBrother<>nil)
4558 and (SectionNode.NextBrother.Desc=ctnClassPublished) then
4559 SectionNode:=SectionNode.NextBrother;
4560 SourceChangeCache.MainScanner:=Scanner;
4561 Beauty:=SourceChangeCache.BeautifyCodeOptions;
4562 if SectionNode.FirstChild<>nil then begin
4563 Indent:=Beauty.GetLineIndent(Src,SectionNode.FirstChild.StartPos);
4564 end else begin
4565 Indent:=Beauty.GetLineIndent(Src,SectionNode.StartPos)+Beauty.Indent;
4566 end;
4567 InsertPos:=FindLineEndOrCodeInFrontOfPosition(SectionNode.EndPos);
4568 SourceChangeCache.Replace(gtNewLine,gtNewLine,InsertPos,InsertPos,
4569 Beauty.BeautifyStatement(VarName+':'+VarType+';',Indent)
4570 );
4571 Result:=SourceChangeCache.Apply;
4572 end;
4573
RemovePublishedVariablenull4574 function TStandardCodeTool.RemovePublishedVariable(const AClassName,
4575 AVarName: string; ExceptionOnClassNotFound: boolean;
4576 SourceChangeCache: TSourceChangeCache): boolean;
4577 var VarNode: TCodeTreeNode;
4578 FromPos, ToPos: integer;
4579 begin
4580 Result:=false;
4581 VarNode:=FindPublishedVariable(AClassName,AVarName,
4582 ExceptionOnClassNotFound);
4583 if VarNode=nil then exit;
4584 if (VarNode.PriorBrother<>nil)
4585 and (VarNode.PriorBrother.Desc=ctnVarDefinition)
4586 and (VarNode.PriorBrother.FirstChild=nil) then begin
4587 // variable definition has the form 'PriorVarName, VarName: VarType;'
4588 // or 'PriorVarName, VarName, NextVarName: VarType'
4589 // -> delete only ', VarName'
4590 MoveCursorToNodeStart(VarNode.PriorBrother);
4591 ReadNextAtom; // read 'PriorVarName'
4592 ReadNextAtom; // read ','
4593 FromPos:=CurPos.StartPos;
4594 ReadNextAtom; // read 'VarName'
4595 ReadNextAtom; // read ':'
4596 ToPos:=CurPos.StartPos;
4597 end else begin
4598 if VarNode.FirstChild<>nil then begin
4599 // variable definition has the form 'VarName: VarType;'
4600 // -> delete whole line
4601 FromPos:=FindLineEndOrCodeInFrontOfPosition(VarNode.StartPos);
4602 ToPos:=FindLineEndOrCodeAfterPosition(VarNode.EndPos);
4603 //debugln(['TStandardCodeTool.RemovePublishedVariable ',dbgstr(copy(Src,FromPos,ToPos-FromPos))]);
4604 end else begin
4605 // variable definition has the form 'VarName, NextVarName: VarType;'
4606 // -> delete only 'VarName, '
4607 FromPos:=VarNode.StartPos;
4608 ToPos:=VarNode.NextBrother.StartPos;
4609 end;
4610 end;
4611 SourceChangeCache.MainScanner:=Scanner;
4612 if not SourceChangeCache.Replace(gtNone,gtNone,FromPos,ToPos,'') then exit;
4613 Result:=SourceChangeCache.Apply;
4614 end;
4615
RenamePublishedVariablenull4616 function TStandardCodeTool.RenamePublishedVariable(const AClassName,
4617 AOldVarName: string; const NewVarName, VarType: shortstring;
4618 ExceptionOnClassNotFound: boolean;
4619 SourceChangeCache: TSourceChangeCache): boolean;
4620 var
4621 TypeNode, VarNode: TCodeTreeNode;
4622 ApplyNeeded: Boolean;
4623 begin
4624 Result:=false;
4625 if (NewVarName='') or (VarType='') then exit;
4626 BuildTree(lsrEnd);
4627 VarNode:=FindPublishedVariable(AClassName,AOldVarName,
4628 ExceptionOnClassNotFound);
4629 if VarNode<>nil then begin
4630 // old variable found
4631 // check type
4632 TypeNode:=FindTypeNodeOfDefinition(VarNode);
4633 MoveCursorToNodeStart(TypeNode);
4634 ReadNextAtom;
4635 SourceChangeCache.MainScanner:=Scanner;
4636 ApplyNeeded:=false;
4637 if (not AtomIsIdentifier(@VarType[1])) then begin
4638 // change the type
4639 ApplyNeeded:=true;
4640 if not SourceChangeCache.Replace(gtNone,gtNone,
4641 CurPos.StartPos,CurPos.EndPos,VarType)
4642 then begin
4643 RaiseException(20170421201215,'Unable to replace type');
4644 end;
4645 end;
4646 // rename variable in source
4647 if not ReplaceWord(AOldVarName,NewVarName,false,SourceChangeCache,true)
4648 then
4649 exit;
4650 Result:=(not ApplyNeeded) or SourceChangeCache.Apply;
4651 end else begin
4652 // old variable not found -> add it
4653 Result:=AddPublishedVariable(AClassName,NewVarName,VarType,
4654 SourceChangeCache);
4655 end;
4656 end;
4657
GatherPublishedClassElementsnull4658 function TStandardCodeTool.GatherPublishedClassElements(
4659 const TheClassName: string;
4660 ExceptionOnClassNotFound, WithVariables, WithMethods, WithProperties,
4661 WithAncestors: boolean;
4662 out TreeOfCodeTreeNodeExtension: TAVLTree): boolean;
4663
4664 function Add(AFindContext: PFindContext): boolean;
4665 var
4666 ClassNode: TCodeTreeNode;
4667 CurTool: TFindDeclarationTool;
4668 SectionNode: TCodeTreeNode;
4669 ANode: TCodeTreeNode;
4670 CurProcName: String;
4671 NewNodeExt: TCodeTreeNodeExtension;
4672 CurPropName: String;
4673 CurVarName: String;
4674 begin
4675 Result:=false;
4676 ClassNode:=AFindContext^.Node;
4677 if (ClassNode=nil)
4678 or (not (ClassNode.Desc in AllClasses)) then exit;
4679 CurTool:=AFindContext^.Tool;
4680 SectionNode:=ClassNode.FirstChild;
4681 while (SectionNode<>nil) do begin
4682 if SectionNode.Desc=ctnClassPublished then begin
4683 ANode:=SectionNode.FirstChild;
4684 while ANode<>nil do begin
4685 if (ANode.Desc=ctnProcedure) and WithMethods then begin
4686 CurProcName:=CurTool.ExtractProcName(ANode,[]);
4687 {$IFDEF VerboseDanglingComponentEvents}
4688 debugln('TStandardCodeTool.GatherPublishedClassElements CurProcName="',CurProcName,'"');
4689 {$ENDIF}
4690 NewNodeExt:=TCodeTreeNodeExtension.Create;
4691 with NewNodeExt do begin
4692 Node:=ANode;
4693 Txt:=CurProcName;
4694 end;
4695 TreeOfCodeTreeNodeExtension.Add(NewNodeExt);
4696 end
4697 else if (ANode.Desc=ctnVarDefinition) and WithVariables then begin
4698 CurVarName:=CurTool.ExtractDefinitionName(ANode);
4699 NewNodeExt:=TCodeTreeNodeExtension.Create;
4700 with NewNodeExt do begin
4701 Node:=ANode;
4702 Txt:=CurVarName;
4703 end;
4704 TreeOfCodeTreeNodeExtension.Add(NewNodeExt);
4705 end
4706 else if (ANode.Desc=ctnProperty) and WithProperties then begin
4707 CurPropName:=CurTool.ExtractPropName(ANode,false);
4708 NewNodeExt:=TCodeTreeNodeExtension.Create;
4709 with NewNodeExt do begin
4710 Node:=ANode;
4711 Txt:=CurPropName;
4712 end;
4713 TreeOfCodeTreeNodeExtension.Add(NewNodeExt);
4714 end;
4715 ANode:=ANode.NextBrother;
4716 end;
4717 end;
4718 SectionNode:=SectionNode.NextBrother;
4719 end;
4720 Result:=true;
4721 end;
4722
4723 var
4724 ClassNode: TCodeTreeNode;
4725 AncestorList: TFPList;// of PFindContext
4726 i: Integer;
4727 begin
4728 Result:=false;
4729 TreeOfCodeTreeNodeExtension:=nil;
4730 if (TheClassName='') or (length(TheClassName)>255) then
4731 RaiseExceptionFmt(20170421201221,ctsInvalidClassName, [TheClassName]);
4732 {$IFDEF VerboseDanglingComponentEvents}
4733 DebugLn(['TStandardCodeTool.GatherPublishedClassElements BEFORE buildtree']);
4734 {$ENDIF}
4735 BuildTree(lsrImplementationStart);
4736 {$IFDEF VerboseDanglingComponentEvents}
4737 DebugLn(['TStandardCodeTool.GatherPublishedClassElements after buildtree']);
4738 {$ENDIF}
4739 ClassNode:=FindClassNodeInInterface(TheClassName,true,false,
4740 ExceptionOnClassNotFound);
4741 if ClassNode=nil then exit;
4742 AncestorList:=nil;
4743 try
4744 if WithAncestors then begin
4745 if not FindClassAndAncestors(ClassNode,AncestorList,true) then exit;
4746 end else begin
4747 AddFindContext(AncestorList,CreateFindContext(Self,ClassNode));
4748 end;
4749 TreeOfCodeTreeNodeExtension:=TAVLTree.Create(@CompareCodeTreeNodeExt);
4750 for i:=0 to AncestorList.Count-1 do begin
4751 if not Add(PFindContext(AncestorList[i])) then exit;
4752 end;
4753 //debugln(['TStandardCodeTool.GatherPublishedClassElements END']);
4754 finally
4755 FreeListOfPFindContext(AncestorList);
4756 end;
4757 Result:=true;
4758 end;
4759
RetypeClassVariablesnull4760 function TStandardCodeTool.RetypeClassVariables(const AClassName: string;
4761 ListOfTypes: TStringToStringTree; ExceptionOnClassNotFound: boolean;
4762 SourceChangeCache: TSourceChangeCache; SearchImplementationToo: boolean): boolean;
4763 var
4764 ClassNode: TCodeTreeNode;
4765 Node: TCodeTreeNode;
4766 TypeNode: TCodeTreeNode;
4767 OldType: String;
4768 NewType: string;
4769 HasChanged: Boolean;
4770 begin
4771 Result:=false;
4772 if SearchImplementationToo then begin
4773 BuildTree(lsrEnd);
4774 ClassNode:=FindClassNodeInUnit(AClassName,true,false,false,
4775 ExceptionOnClassNotFound)
4776 end
4777 else begin
4778 BuildTree(lsrImplementationStart);
4779 ClassNode:=FindClassNodeInInterface(AClassName,true,false,
4780 ExceptionOnClassNotFound);
4781 end;
4782 if ClassNode=nil then exit;
4783 if (ListOfTypes=nil) or (ListOfTypes.Tree.Count=0) then exit(true);
4784
4785 HasChanged:=false;
4786 Node:=ClassNode.FirstChild;
4787 while (Node<>nil) and (Node.HasAsParent(ClassNode)) do begin
4788 if (Node.Desc=ctnVarDefinition) and (Node.FirstChild<>nil) then begin
4789 TypeNode:=Node.FirstChild;
4790 if TypeNode.Desc=ctnIdentifier then begin
4791 MoveCursorToNodeStart(TypeNode);
4792 ReadNextAtom;
4793 ReadNextAtom;
4794 if CurPos.Flag=cafPoint then begin
4795 // skip unitname
4796 ReadNextAtom;
4797 end else begin
4798 UndoReadNextAtom;
4799 end;
4800 // cursor is now on identifier
4801 OldType:=GetAtom;
4802 if ListOfTypes.Contains(OldType) then begin
4803 NewType:=ListOfTypes[OldType];
4804 if OldType<>NewType then begin
4805 // change type (or case)
4806 if not HasChanged then begin
4807 HasChanged:=true;
4808 SourceChangeCache.MainScanner:=Scanner;
4809 end;
4810 if not SourceChangeCache.Replace(gtNone,gtNone,
4811 CurPos.StartPos,CurPos.EndPos,NewType)
4812 then
4813 exit(false);
4814 end;
4815 end;
4816 end;
4817 Node:=Node.NextSkipChilds;
4818 end else
4819 Node:=Node.Next;
4820 end;
4821 if HasChanged then begin
4822 if not SourceChangeCache.Apply then exit;
4823 end;
4824 Result:=true;
4825 end;
4826
FindDanglingComponentEventsnull4827 function TStandardCodeTool.FindDanglingComponentEvents(
4828 const TheClassName: string; RootComponent: TComponent;
4829 ExceptionOnClassNotFound, SearchInAncestors: boolean; out
4830 ListOfPInstancePropInfo: TFPList;
4831 const OverrideGetMethodName: TOnGetMethodname): boolean;
4832 var
4833 PublishedMethods: TAVLTree;
4834
4835 procedure AddDanglingEvent(Instance: TPersistent; PropInfo: PPropInfo);
4836 var
4837 NewItem: PInstancePropInfo;
4838 begin
4839 New(NewItem);
4840 NewItem^.Instance:=Instance;
4841 NewItem^.PropInfo:=PropInfo;
4842 if ListOfPInstancePropInfo=nil then ListOfPInstancePropInfo:=TFPList.Create;
4843 ListOfPInstancePropInfo.Add(NewItem);
4844 {$IFDEF VerboseDanglingComponentEvents}
4845 debugln('AddDanglingEvent ',DbgSName(Instance),' ',PropInfo^.Name);
4846 {$ENDIF}
4847 end;
4848
4849 procedure CheckMethodsInPersistent(APersistent: TPersistent);
4850 var
4851 TypeInfo: PTypeInfo;
4852 TypeData: PTypeData;
4853 PropInfo: PPropInfo;
4854 PropList: PPropList;
4855 CurCount,i: integer;
4856 PropType: PTypeInfo;
4857 NodeExt: TCodeTreeNodeExtension;
4858 CurMethod: TMethod;
4859 CurMethodName: String;
4860 ObjValue: TObject;
4861 begin
4862 if APersistent=nil then exit;
4863 {$IFDEF VerboseDanglingComponentEvents}
4864 debugln('TStandardCodeTool.FindDanglingComponentEvents.CheckMethodsInPersistent Checking ',DbgSName(APersistent));
4865 {$ENDIF}
4866 // read all properties and remove doubles
4867 TypeInfo:=APersistent.ClassInfo;
4868 repeat
4869 // read all property infos of current class
4870 TypeData:=GetTypeData(TypeInfo);
4871 // read property count
4872 CurCount:=GetPropList(TypeInfo,PropList);
4873 try
4874 {$IFDEF VerboseDanglingComponentEvents}
4875 debugln(' UnitName=',TypeData^.UnitName,' Type=',TypeInfo^.Name,' CurPropCount=',dbgs(CurCount));
4876 {$ENDIF}
4877 // read properties
4878 for i:=0 to CurCount-1 do begin
4879 PropInfo:=PropList^[i];
4880 {$IFDEF VerboseDanglingComponentEvents}
4881 debugln(' Property ',PropInfo^.Name,' Type=',PropInfo^.PropType^.Name);
4882 {$ENDIF}
4883 PropType:=PropInfo^.PropType;
4884
4885 if (PropType^.Kind=tkMethod) then begin
4886 // RTTI property is method
4887 // -> search method in source
4888 CurMethod:=GetMethodProp(APersistent,PropInfo);
4889 if (CurMethod.Data<>nil) or (CurMethod.Code<>nil) then begin
4890 if Assigned(OverrideGetMethodName) then
4891 CurMethodName:=OverrideGetMethodName(CurMethod,RootComponent)
4892 else
4893 CurMethodName:=OnGetMethodName(CurMethod,RootComponent);
4894 {$IFDEF VerboseDanglingComponentEvents}
4895 debugln(' Persistent ',DbgSName(APersistent),' Property ',PropInfo^.Name,' Type=',PropInfo^.PropType^.Name,' CurMethodName="',CurMethodName,'"');
4896 {$ENDIF}
4897 if CurMethodName<>'' then begin
4898 NodeExt:=FindCodeTreeNodeExt(PublishedMethods,CurMethodName);
4899 if NodeExt=nil then begin
4900 // method not found -> dangling event
4901 AddDanglingEvent(APersistent,PropInfo);
4902 end;
4903 end;
4904 end;
4905 end else if (PropType^.Kind=tkClass) then begin
4906 // RTTI property is class instance
4907 ObjValue := TObject(GetObjectProp(APersistent, PropInfo));
4908 if ObjValue is TCollection then begin
4909 // collection
4910
4911 end else if (ObjValue is TPersistent)
4912 and (not (ObjValue is TComponent)
4913 or (csSubComponent in TComponent(ObjValue).ComponentStyle))
4914 then begin
4915 // sub persistent (e.g. Canvas.Font)
4916 //debugln(['CheckMethodsInPersistent sub persistent: ',DbgSName(ObjValue)]);
4917 CheckMethodsInPersistent(TPersistent(ObjValue));
4918 end;
4919 end;
4920 end;
4921 finally
4922 FreeMem(PropList);
4923 end;
4924 TypeInfo:=TypeData^.ParentInfo;
4925 until TypeInfo=nil;
4926 end;
4927
4928 var
4929 i: Integer;
4930 Collector: TComponentChildCollector;
4931 AllComponents: TFPList;
4932 begin
4933 PublishedMethods:=nil;
4934 ListOfPInstancePropInfo:=nil;
4935 Collector:=nil;
4936 AllComponents:=nil;
4937 try
4938 // search all available published methods
4939 {$IFDEF VerboseDanglingComponentEvents}
4940 debugln('TStandardCodeTool.FindDanglingComponentEvents A ',MainFilename,' ',DbgSName(RootComponent));
4941 {$ENDIF}
4942 Result:=GatherPublishedClassElements(TheClassName,ExceptionOnClassNotFound,
4943 false,true,false,SearchInAncestors,
4944 PublishedMethods);
4945 if not Result then exit;
4946 // go through all components
4947 Collector:=TComponentChildCollector.Create;
4948 AllComponents:=Collector.GetComponents(RootComponent,true);
4949 for i:=0 to AllComponents.Count-1 do
4950 CheckMethodsInPersistent(TComponent(AllComponents[i]));
4951 finally
4952 Collector.Free;
4953 DisposeAVLTree(PublishedMethods);
4954 end;
4955 end;
4956
RemoveIdentifierDefinitionnull4957 function TStandardCodeTool.RemoveIdentifierDefinition(
4958 const CursorPos: TCodeXYPosition; SourceChangeCache: TSourceChangeCache
4959 ): boolean;
4960 var
4961 CleanCursorPos: integer;
4962 Node: TCodeTreeNode;
4963 PrevSibling: TCodeTreeNode;
4964 NextSibling: TCodeTreeNode;
4965 DeleteStartPos: LongInt;
4966 DeleteEndPos: LongInt;
4967 DeleteFirstTokenOfLine: Boolean;
4968 begin
4969 Result:=false;
4970 BuildTreeAndGetCleanPos(CursorPos,CleanCursorPos);
4971 Node:=BuildSubTreeAndFindDeepestNodeAtPos(CleanCursorPos,true);
4972 if Node.Desc in AllIdentifierDefinitions then begin
4973 // Examples:
4974 // var i, X: integer; -> var i[, X]: integer;
4975 // var i, X, j: integer; -> var i, [X, ]j: integer;
4976 // var X, i: integer; -> var [X, ]i: integer;
4977 // type X = integer;
4978 // const X = 0;
4979 // const X : integer = 0;
4980 PrevSibling:=nil;
4981 NextSibling:=nil;
4982 if (Node.PriorBrother<>nil) and (Node.PriorBrother.FirstChild=nil) then
4983 PrevSibling:=Node.PriorBrother;
4984 if (Node.FirstChild=nil) and (Node.NextBrother<>nil) then
4985 NextSibling:=Node.NextBrother;
4986 DeleteStartPos:=Node.StartPos;
4987 DeleteEndPos:=Node.StartPos+GetIdentLen(@Src[Node.StartPos]);
4988 if NextSibling<>nil then begin
4989 // var i, X, j: integer; -> var i, [X, ]j: integer;
4990 // var X, i: integer; -> var [X, ]i: integer;
4991 MoveCursorToCleanPos(Node.StartPos);
4992 ReadNextAtom;
4993 AtomIsIdentifierE;
4994 if not ReadNextAtomIsChar(',') then
4995 RaiseCharExpectedButAtomFound(20170421201227,',');
4996 DeleteEndPos:=CurPos.EndPos;
4997 end else if PrevSibling<>nil then begin
4998 // var i, X: integer; -> var i[, X]: integer;
4999 MoveCursorToCleanPos(PrevSibling.StartPos);
5000 ReadNextAtom;
5001 AtomIsIdentifierE;
5002 if not ReadNextAtomIsChar(',') then
5003 RaiseCharExpectedButAtomFound(20170421201233,',');
5004 DeleteStartPos:=CurPos.StartPos;
5005 end else begin
5006 // delete whole declaration
5007 if (Node.Parent.Desc in AllDefinitionSections)
5008 and (Node.PriorBrother=nil) and (Node.NextBrother=nil) then begin
5009 // delete whole section
5010 DeleteStartPos:=Node.Parent.StartPos;
5011 DeleteEndPos:=Node.Parent.EndPos;
5012 end else if Node.Parent.Desc=ctnParameterList then begin
5013 // delete whole parameter including modifier, type and default value
5014 if Node.PriorBrother<>nil then begin
5015 // ... var i: integer; var X: ... -> ... var i: integer[; var X: ...
5016 MoveCursorToCleanPos(Node.PriorBrother.EndPos);
5017 repeat
5018 ReadNextAtom;
5019 if CurPos.Flag=cafSemicolon then begin
5020 DeleteStartPos:=CurPos.EndPos;
5021 break;
5022 end;
5023 until CurPos.StartPos>=Node.StartPos;
5024 end else begin
5025 // (var X: ... -> ([; X: ...
5026 MoveCursorToCleanPos(Node.Parent.StartPos);
5027 ReadNextAtom;
5028 if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then
5029 DeleteStartPos:=CurPos.EndPos;
5030 end;
5031 if Node.NextBrother<>nil then begin
5032 // ... var X: integer; var i: ... -> .. var X: integer;] var i: ...
5033 DeleteEndPos:=Node.PriorBrother.EndPos;
5034 end else begin
5035 // ... var X: integer) -> .. var X: integer])
5036 DeleteEndPos:=Node.EndPos;
5037 end;
5038 end else begin
5039 // keep section, delete whole declaration
5040 DeleteEndPos:=Node.EndPos;
5041 end;
5042 end;
5043 // include corresponding comments
5044 DeleteFirstTokenOfLine:=FindFirstNonSpaceCharInLine(Src,DeleteStartPos)=DeleteStartPos;
5045 //DebugLn(['TStandardCodeTool.RemoveIdentifierDefinition ',dbgstr(copy(Src,FindFirstNonSpaceCharInLine(Src,DeleteStartPos),10))]);
5046 DeleteEndPos:=FindLineEndOrCodeAfterPosition(DeleteEndPos,true,DeleteFirstTokenOfLine);
5047 if DeleteFirstTokenOfLine and (Src[DeleteEndPos-1] in [#10,#13]) then begin
5048 // delete first and last token of line
5049 // => remove the entire line
5050 DeleteStartPos:=GetLineStartPosition(Src,DeleteStartPos);
5051 end;
5052 //DebugLn(['TStandardCodeTool.RemoveIdentifierDefinition "',dbgstr(copy(Src,DeleteStartPos,DeleteEndPos-DeleteStartPos)),'" IncludeLineEnd=',DeleteFirstTokenOfLine]);
5053
5054 // delete
5055 SourceChangeCache.MainScanner:=Scanner;
5056 if not SourceChangeCache.Replace(gtNone,gtNone,DeleteStartPos,DeleteEndPos,'')
5057 then exit;
5058 Result:=SourceChangeCache.Apply;
5059 end;
5060 end;
5061
InsertStatementsnull5062 function TStandardCodeTool.InsertStatements(
5063 InsertPos: TInsertStatementPosDescription; Statements: string;
5064 SourceChangeCache: TSourceChangeCache): boolean;
5065 var
5066 CleanCursorPos: integer;
5067 begin
5068 BeginParsingAndGetCleanPos(lsrEnd,InsertPos.CodeXYPos,CleanCursorPos);
5069 Result:=InsertStatements(CleanCursorPos,Statements,InsertPos.Indent,
5070 InsertPos.FrontGap,InsertPos.AfterGap,SourceChangeCache);
5071 Result:=SourceChangeCache.Apply;
5072 end;
5073
InsertStatementsnull5074 function TStandardCodeTool.InsertStatements(CleanPos: integer;
5075 Statements: string; Indent: integer; FrontGap, AfterGap: TGapTyp;
5076 SourceChangeCache: TSourceChangeCache): boolean;
5077 {
5078 ToDo: check for "uses" in Statements and extend uses section
5079 e.g. "uses unit1, unit2 in 'filename'; statements
5080 ToDo: check for single statement (e.g. for .. do | dosome;) and add begin/end
5081
5082 }
5083 var
5084 Node: TCodeTreeNode;
5085 SameArea: TAtomPosition;
5086 BeautifyFlags: TBeautifyCodeFlags;
5087 begin
5088 Node:=FindDeepestNodeAtPos(CleanPos,true);
5089 if not (Node.Desc in AllPascalStatements) then begin
5090 MoveCursorToCleanPos(CleanPos);
5091 RaiseException(20170421201247,ctsInvalidPositionForInsertionOfStatements);
5092 end;
5093 if Node.Desc=ctnBeginBlock then
5094 Node:=BuildSubTreeAndFindDeepestNodeAtPos(Node,CleanPos,true);
5095
5096 GetCleanPosInfo(Node.StartPos,CleanPos,false,SameArea);
5097 if (SameArea.StartPos>SrcLen) or (not IsSpaceChar[Src[SameArea.StartPos]])
5098 then begin
5099 MoveCursorToCleanPos(CleanPos);
5100 RaiseException(20170421201255,ctsInvalidPositionForInsertionOfStatements);
5101 end;
5102
5103 SourceChangeCache.MainScanner:=Scanner;
5104 BeautifyFlags:=[bcfIndentExistingLineBreaks];
5105 if FrontGap in [gtNone,gtSpace] then
5106 include(BeautifyFlags,bcfDoNotIndentFirstLine);
5107 Statements:=SourceChangeCache.BeautifyCodeOptions.BeautifyStatement(
5108 Statements,Indent,BeautifyFlags);
5109
5110 Result:=SourceChangeCache.Replace(FrontGap,AfterGap,CleanPos,CleanPos,Statements);
5111 end;
5112
FindBlockCounterPartnull5113 function TStandardCodeTool.FindBlockCounterPart(
5114 const CursorPos: TCodeXYPosition;
5115 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
5116 // jump from bracket-open to bracket-close or 'begin' to 'end'
5117 // or 'until' to 'repeat' ...
5118 var CleanCursorPos: integer;
5119 begin
5120 Result:=false;
5121 BeginParsingAndGetCleanPos(lsrEnd,CursorPos,CleanCursorPos);
5122 // read word at cursor
5123 MoveCursorToCleanPos(CleanCursorPos);
5124 if Src[CurPos.StartPos] in ['(','[','{'] then begin
5125 // jump forward to matching bracket
5126 ReadNextAtom;
5127 if not ReadForwardTilAnyBracketClose then exit;
5128 end else if Src[CurPos.StartPos] in [')',']','}'] then begin
5129 // jump backward to matching bracket
5130 ReadNextAtom;
5131 if not ReadBackwardTilAnyBracketClose then exit;
5132 end else begin
5133 if Src[CurPos.StartPos] in [';','.'] then dec(CurPos.StartPos);
5134 while (CurPos.StartPos>2) and IsWordChar[Src[CurPos.StartPos-1]] do
5135 dec(CurPos.StartPos);
5136 MoveCursorToCleanPos(CurPos.StartPos);
5137 ReadNextAtom;
5138 if CurPos.EndPos=CurPos.StartPos then exit;
5139 // read till block keyword counterpart
5140 if UpAtomIs('BEGIN') or UpAtomIs('CASE') or UpAtomIs('ASM')
5141 or UpAtomIs('RECORD') or UpAtomIs('TRY') or UpAtomIs('REPEAT') then begin
5142 // read forward till END, FINALLY, EXCEPT
5143 ReadTilBlockEnd(true,false);
5144 end else if UpAtomIs('END') or UpAtomIs('FINALLY') or UpAtomIs('EXCEPT')
5145 or UpAtomIs('UNTIL') then
5146 begin
5147 // read backward till BEGIN, CASE, ASM, RECORD, REPEAT
5148 ReadBackTilBlockEnd(true);
5149 end else
5150 exit;
5151 end;
5152 // CursorPos now contains the counter block keyword
5153 Result:=CleanPosToCaretAndTopLine(CurPos.StartPos,NewPos,NewTopLine);
5154 end;
5155
FindBlockStartnull5156 function TStandardCodeTool.FindBlockStart(const CursorPos: TCodeXYPosition; out
5157 NewPos: TCodeXYPosition; out NewTopLine: integer; SkipStart: boolean
5158 ): boolean;
5159 // jump to beginning of current block
5160 // e.g. bracket open, 'begin', 'repeat', ...
5161 var CleanCursorPos: integer;
5162 CursorOnStart: Boolean;
5163 Node: TCodeTreeNode;
5164 MinPos: Integer;
5165 begin
5166 Result:=false;
5167 // scan code
5168 BeginParsingAndGetCleanPos(lsrEnd,CursorPos,CleanCursorPos);
5169 // read word at cursor
5170 MoveCursorToCleanPos(CleanCursorPos);
5171 while (CurPos.StartPos>2) and IsWordChar[Src[CurPos.StartPos-1]] do
5172 dec(CurPos.StartPos);
5173 MoveCursorToCleanPos(CurPos.StartPos);
5174 ReadNextAtom;
5175 try
5176 if CurPos.StartPos>=SrcLen then begin
5177 ReadPriorAtom;
5178 if CurPos.StartPos<1 then begin
5179 MoveCursorToCleanPos(1);
5180 exit(true);
5181 end;
5182 end;
5183 Node:=FindDeepestNodeAtPos(CleanCursorPos,false);
5184 //if Node<>nil then debugln(['TStandardCodeTool.FindBlockStart ',Node.DescAsString]);
5185 if (Node=nil)
5186 or (Node.Desc in (AllPascalStatements+AllPascalTypes-AllClasses))
5187 or (Src[CurPos.StartPos] in [')',']','}'])
5188 then begin
5189 MinPos:=1;
5190 if Node<>nil then MinPos:=Node.StartPos;
5191 repeat
5192 //debugln(['TStandardCodeTool.FindBlockStart atom ',CleanPosToStr(CurPos.StartPos),' ',GetAtom]);
5193 if (CurPos.StartPos<0) then begin
5194 // start of source found -> this is always a block start
5195 MoveCursorToCleanPos(1);
5196 exit(true);
5197 end
5198 else if Src[CurPos.StartPos] in [')',']','}'] then begin
5199 // jump backward to matching bracket
5200 CursorOnStart:=(CleanCursorPos=CurPos.StartPos);
5201 if not ReadBackwardTilAnyBracketClose then exit;
5202 if CursorOnStart then exit(true);
5203 end
5204 else if WordIsBlockStatementStart.DoItCaseInsensitive(Src,
5205 CurPos.StartPos,CurPos.EndPos-CurPos.StartPos) then
5206 begin
5207 // block start found
5208 if (CurPos.StartPos<CleanCursorPos) or (not SkipStart) then
5209 exit(true);
5210 end else if UpAtomIs('END') or UpAtomIs('FINALLY') or UpAtomIs('EXCEPT')
5211 or UpAtomIs('UNTIL') then
5212 begin
5213 // read backward till BEGIN, CASE, ASM, RECORD, REPEAT
5214 CursorOnStart:=(CleanCursorPos>=CurPos.StartPos)
5215 and (CleanCursorPos<CurPos.EndPos);
5216 ReadBackTilBlockEnd(true);
5217 if CursorOnStart then exit(true);
5218 end;
5219 ReadPriorAtom;
5220 until CurPos.StartPos<MinPos;
5221 end;
5222 if Node<>nil then begin
5223 if SkipStart and (CleanCursorPos=Node.StartPos) then begin
5224 while (Node<>nil) and (Node.StartPos=CleanCursorPos) do
5225 Node:=Node.Parent;
5226 if Node<>nil then
5227 MoveCursorToCleanPos(Node.StartPos)
5228 else
5229 MoveCursorToCleanPos(1);
5230 exit(true);
5231 end;
5232 if CleanCursorPos>=Node.StartPos then begin
5233 MoveCursorToCleanPos(Node.StartPos);
5234 exit(true);
5235 end;
5236 end;
5237 finally
5238 if Result then begin
5239 // CursorPos now contains the block start atom
5240 Result:=CleanPosToCaretAndTopLine(CurPos.StartPos,NewPos,NewTopLine);
5241 end;
5242 end;
5243 end;
5244
GuessUnclosedBlocknull5245 function TStandardCodeTool.GuessUnclosedBlock(const CursorPos: TCodeXYPosition;
5246 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
5247 { search a block (e.g. begin..end) that looks unclosed, i.e. 'begin'
5248 without 'end' or 'begin' with 'end' in a different column.
5249 This function can be used as GuessNextUnclosedBlock, because it ignores blocks
5250 in front of CursorPos.
5251
5252 Examples for good blocks:
5253
5254 repeat
5255 until
5256
5257 begin end // start and end of block in the same line
5258
5259 if expr then begin // first char in line is relevant, not the block keyword
5260 end
5261
5262 class;
5263
5264
5265 Examples for bad blocks:
5266
5267 begin // block start and end has different indenting
5268 end
5269
5270 asm // 'end.' is source end, never asm end
5271 end.
5272
5273 try // different indenting
5274 finally
5275
5276 repeat // keywords do not match
5277 end
5278
5279 }
5280 var CleanCursorPos: integer;
5281 begin
5282 Result:=false;
5283 BeginParsingAndGetCleanPos(lsrEnd,CursorPos,CleanCursorPos);
5284 // start reading at beginning of code
5285 MoveCursorToCleanPos(1);
5286 BuildBlockKeyWordFuncList;
5287 if ReadTilGuessedUnclosedBlock(CleanCursorPos,false) then
5288 Result:=CleanPosToCaretAndTopLine(CurPos.StartPos,NewPos,NewTopLine);
5289 //WriteDebugTreeReport;
5290 end;
5291
FindBlockCleanBoundsnull5292 function TStandardCodeTool.FindBlockCleanBounds(
5293 const CursorPos: TCodeXYPosition; out BlockCleanStart, BlockCleanEnd: integer
5294 ): boolean;
5295 var
5296 CleanCursorPos: integer;
5297 BlockStartFound: Boolean;
5298 begin
5299 Result:=false;
5300 BlockCleanStart:=0;
5301 BlockCleanEnd:=0;
5302 // scan code
5303 BeginParsingAndGetCleanPos(lsrEnd,CursorPos,CleanCursorPos);
5304 // read word at cursor
5305 MoveCursorToCleanPos(CleanCursorPos);
5306 while (CurPos.StartPos>2) and IsWordChar[Src[CurPos.StartPos-1]] do
5307 dec(CurPos.StartPos);
5308 MoveCursorToCleanPos(CurPos.StartPos);
5309 ReadNextAtom;
5310 BlockStartFound:=false;
5311 repeat
5312 ReadPriorAtom;
5313 if (CurPos.StartPos<0) then begin
5314 // start of source found -> this is always a block start
5315 MoveCursorToCleanPos(1);
5316 BlockStartFound:=true;
5317 break;
5318 end
5319 else if Src[CurPos.StartPos] in [')',']','}'] then begin
5320 // jump backward to matching bracket
5321 if not ReadBackwardTilAnyBracketClose then exit;
5322 end
5323 else if WordIsBlockStatementStart.DoItCaseInsensitive(Src,
5324 CurPos.StartPos,CurPos.EndPos-CurPos.StartPos) then
5325 begin
5326 // block start found
5327 BlockStartFound:=true;
5328 break;
5329 end else if UpAtomIs('END') or UpAtomIs('FINALLY') or UpAtomIs('EXCEPT')
5330 or UpAtomIs('UNTIL') then
5331 begin
5332 // read backward till BEGIN, CASE, ASM, RECORD, REPEAT
5333 ReadBackTilBlockEnd(true);
5334 end;
5335 until false;
5336 if not BlockStartFound then exit;
5337 BlockCleanStart:=CurPos.StartPos;
5338
5339 // read word at cursor
5340 MoveCursorToCleanPos(BlockCleanStart);
5341 if Src[CurPos.StartPos] in ['(','[','{'] then begin
5342 // jump forward to matching bracket
5343 ReadNextAtom;
5344 if not ReadForwardTilAnyBracketClose then exit;
5345 end else begin
5346 if Src[CurPos.StartPos] in [';','.'] then dec(CurPos.StartPos);
5347 while (CurPos.StartPos>2) and IsWordChar[Src[CurPos.StartPos-1]] do
5348 dec(CurPos.StartPos);
5349 MoveCursorToCleanPos(CurPos.StartPos);
5350 ReadNextAtom;
5351 if CurPos.EndPos=CurPos.StartPos then exit;
5352 // read till block keyword counterpart
5353 if UpAtomIs('BEGIN') or UpAtomIs('CASE') or UpAtomIs('ASM')
5354 or UpAtomIs('RECORD') or UpAtomIs('TRY') or UpAtomIs('REPEAT') then begin
5355 // read forward till END, FINALLY, EXCEPT
5356 ReadTilBlockEnd(true,false);
5357 end else
5358 exit;
5359 end;
5360 BlockCleanEnd:=CurPos.StartPos;
5361 Result:=true;
5362 end;
5363
CompleteBlocknull5364 function TStandardCodeTool.CompleteBlock(const CursorPos: TCodeXYPosition;
5365 SourceChangeCache: TSourceChangeCache; OnlyIfCursorBlockIndented: boolean;
5366 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
5367 { For example:
5368 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5369 begin
5370 |
5371 ...
5372 something
5373 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5374 if then begin
5375 |
5376 ...
5377 something
5378 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5379 begin
5380 |
5381
5382 procedure
5383 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5384
5385 Statements:
5386 begin: end;
5387 asm: end;
5388 try: finally end;
5389 finally: end;
5390 except: end;
5391 repeat: until ;
5392 case of: end;
5393 case :: ;
5394 case else: end;
5395 (: )
5396 [: ]
5397
5398 Types:
5399 (: )
5400 [: ]
5401 record: end;
5402 class: end;
5403 object: end;
5404 interface: end;
5405 }
5406 type
5407 TBlockType = (
5408 btNone,
5409 btBegin,
5410 btAsm,
5411 btEdgedBracket,
5412 btRoundBracket,
5413 btTry,
5414 btFinally,
5415 btExcept,
5416 btCase,
5417 btCaseOf,
5418 btCaseColon,
5419 btCaseElse,
5420 btRepeat,
5421 btIf,
5422 btIfElse,
5423 btClass,
5424 btInterface,
5425 btObject,
5426 btRecord
5427 );
5428 TBlock = record
5429 Typ: TBlockType;
5430 StartPos: integer;
5431 InnerIndent: integer;
5432 InnerStartPos: integer;
5433 end;
5434 PBlock = ^TBlock;
5435 TBlockStack = record
5436 Stack: PBlock;
5437 Capacity: integer;
5438 Top: integer;
5439 end;
5440 TExBool = (ebNone, ebTrue, ebFalse);
5441 var
5442 CleanCursorPos: integer;
5443 StartNode: TCodeTreeNode;
5444 InternalCursorAtEmptyLine: TExBool;
5445 Beauty: TBeautifyCodeOptions;
5446
CursorAtEmptyLinenull5447 function CursorAtEmptyLine: Boolean;
5448 // true if cursor in empty line or at line end in front of an empty line
5449 var
5450 p: LongInt;
5451 begin
5452 if InternalCursorAtEmptyLine=ebNone then begin
5453 if (CleanCursorPos>SrcLen) or InEmptyLine(Src,CleanCursorPos) then
5454 InternalCursorAtEmptyLine:=ebTrue
5455 else begin
5456 p:=CleanCursorPos;
5457 while (p<=SrcLen) do begin
5458 case Src[p] of
5459 ' ',#9: inc(p);
5460 #10,#13:
5461 begin
5462 // after cursor the rest of the line is blank
5463 // check the next line
5464 inc(p);
5465 if (p<=SrcLen) and (Src[p] in [#10,#13]) and (Src[p]<>Src[p-1]) then
5466 inc(p);
5467 if (p>SrcLen) or InEmptyLine(Src,p) then
5468 InternalCursorAtEmptyLine:=ebTrue
5469 else
5470 InternalCursorAtEmptyLine:=ebFalse;
5471 break;
5472 end;
5473 else
5474 InternalCursorAtEmptyLine:=ebFalse;
5475 break;
5476 end;
5477 end;
5478 end;
5479 end;
5480 Result:=InternalCursorAtEmptyLine=ebTrue;
5481 end;
5482
5483 procedure InitStack(out Stack: TBlockStack);
5484 begin
5485 FillByte(Stack{%H-},SizeOf(Stack),0);
5486 Stack.Top:=-1;
5487 end;
5488
5489 procedure FreeStack(var Stack: TBlockStack);
5490 begin
5491 ReAllocMem(Stack.Stack,0);
5492 Stack.Capacity:=0;
5493 Stack.Top:=-1;
5494 end;
5495
5496 procedure BeginBlock(var Stack: TBlockStack; Typ: TBlockType;
5497 StartPos: integer);
5498 var
5499 Block: PBlock;
5500 begin
5501 inc(Stack.Top);
5502 if Stack.Top>=Stack.Capacity then begin
5503 if Stack.Capacity=0 then
5504 Stack.Capacity:=16
5505 else
5506 Stack.Capacity:=Stack.Capacity*2;
5507 ReAllocMem(Stack.Stack,SizeOf(TBlock)*Stack.Capacity);
5508 end;
5509 {$IFDEF VerboseCompleteBlock}
5510 DebugLn([GetIndentStr(Stack.Top*2),'BeginBlock ',CleanPosToStr(StartPos),' ',GetAtom]);
5511 {$ENDIF}
5512 Block:=@Stack.Stack[Stack.Top];
5513 Block^.Typ:=Typ;
5514 Block^.StartPos:=StartPos;
5515 Block^.InnerIndent:=-1;
5516 Block^.InnerStartPos:=-1;
5517 end;
5518
5519 procedure EndBlock(var Stack: TBlockStack);
5520 begin
5521 {$IFDEF VerboseCompleteBlock}
5522 DebugLn([GetIndentStr(Stack.Top*2),'EndBlock ',GetAtom,' ',CleanPosToStr(CurPos.StartPos),', started at ',CleanPosToStr(Stack.Stack[Stack.Top].StartPos)]);
5523 {$ENDIF}
5524 dec(Stack.Top);
5525 end;
5526
TopBlockTypenull5527 function TopBlockType(const Stack: TBlockStack): TBlockType;
5528 begin
5529 if Stack.Top>=0 then
5530 Result:=Stack.Stack[Stack.Top].Typ
5531 else
5532 Result:=btNone;
5533 end;
5534
Replacenull5535 function Replace(NewCode: string; FromPos, ToPos, Indent: integer;
5536 FrontGap, AfterGap: TGapTyp; BeautifyFlags: TBeautifyCodeFlags): boolean;
5537 var
5538 p: LongInt;
5539 begin
5540 Result:=false;
5541 if NewCode='' then exit(true);
5542 // try to avoid changing current line
5543 if (FrontGap=gtEmptyLine) then begin
5544 p:=FromPos;
5545 while (p>1) and (Src[p-1] in [' ',#9]) do dec(p);
5546 if (p=1) or (Src[p] in [#10,#13]) then begin
5547 while (p<=SrcLen) and (Src[p] in [' ',#9]) do inc(p);
5548 if (p>SrcLen) or (Src[p] in [#10,#13]) then begin
5549 // inserting in an empty line
5550 inc(p);
5551 if (p<=SrcLen) and (Src[p] in [#10,#13]) and (Src[p]<>Src[p-1]) then
5552 inc(p);
5553 FrontGap:=gtNewLine;
5554 FromPos:=p;
5555 if ToPos<FromPos then ToPos:=FromPos;
5556 end;
5557 end;
5558 end;
5559 // replace trailing spaces
5560 while (ToPos<=SrcLen) and (Src[ToPos] in [' ',#9]) do inc(ToPos);
5561 // use existing semicolon
5562 if (NewCode[length(NewCode)]=';')
5563 and (ToPos<=SrcLen) and (Src[ToPos]=';') then begin
5564 AfterGap:=gtNone;
5565 inc(ToPos);
5566 end;
5567 // use existing "else"
5568 if (NewCode[length(NewCode)]=';') then begin
5569 MoveCursorToCleanPos(ToPos);
5570 ReadNextAtom;
5571 if UpAtomIs('ELSE') then
5572 NewCode:=copy(NewCode,1,length(NewCode)-1);
5573 end;
5574
5575 // adjust indent of first line
5576 if FrontGap in [gtNone,gtSpace] then begin
5577 BeautifyFlags:=BeautifyFlags+[bcfDoNotIndentFirstLine];
5578 NewCode:=Beauty.GetIndentStr(Indent-GetPosInLine(Src,FromPos))+NewCode;
5579 end;
5580 // beautify
5581 NewCode:=Beauty.BeautifyStatement(
5582 NewCode,Indent,BeautifyFlags);
5583
5584 if AfterGap=gtNewLine then begin
5585 // do not reuse existing newline, but always add newline
5586 NewCode:=NewCode+Beauty.LineEnd;
5587 if (ToPos<SrcLen) and (not (Src[ToPos] in [#10,#13])) then
5588 NewCode:=NewCode+Beauty.GetIndentStr(Beauty.GetLineIndent(Src,ToPos));
5589 AfterGap:=gtNone;
5590 end;
5591 {$IFDEF VerboseCompleteBlock}
5592 debugln(['Replace Indent=',Indent,' NewCode="',dbgstr(NewCode),'" Replace: InFront="',DbgStr(copy(Src,FromPos-15,15)),'",Replace="',dbgstr(copy(Src,FromPos,ToPos-FromPos)),'",Behind="',dbgstr(copy(Src,ToPos,15)),'" FrontGap=',dbgs(FrontGap),' AfterGap=',dbgs(AfterGap)]);
5593 {$ENDIF}
5594 // insert
5595 if not SourceChangeCache.Replace(FrontGap,AfterGap,
5596 FromPos,ToPos,NewCode) then exit;
5597 if not SourceChangeCache.Apply then exit;
5598 Result:=true;
5599 end;
5600
CompleteStatementsnull5601 function CompleteStatements(var Stack: TBlockStack): Boolean;
5602 var
5603 CursorBlockLvl: Integer; // the stack level of the cursor
5604 LastPos: Integer;
5605 LineStart: boolean; // Atom is first atom of a line in cursor block (not in sub block)
5606 Indent: Integer;
5607 CursorBlockInnerIndent, CursorBlockOuterIndent: LongInt;
5608 CursorBlock: TBlock;
5609 AtomInFrontOfCursor: TAtomPosition;
5610 BehindCursorBlock: Boolean; // atom is behind cursor block
5611 InCursorBlock: Boolean;
5612 NeedCompletion: integer;
5613 InsertPos: LongInt;
5614 NewCode: String;
5615 AfterGap: TGapTyp;
5616 FrontGap: TGapTyp;
5617 BeautifyFlags: TBeautifyCodeFlags;
5618 BehindPos: LongInt;
5619 CursorInEmptyStatement: Boolean;
5620 FromPos: LongInt;
5621 ToPos: LongInt;
5622 WasInCursorBlock: Boolean;
5623
EndBlockIsOknull5624 function EndBlockIsOk: boolean;
5625 begin
5626 //DebugLn(['EndBlockIsOk ']);
5627 if (NeedCompletion>0) and (CursorBlockLvl>=0)
5628 and (Stack.Top=CursorBlockLvl)
5629 and (Beauty.GetLineIndent(Src,CurPos.StartPos)=CursorBlockOuterIndent) then begin
5630 // cursor block is properly closed => do not complete
5631 {$IFDEF VerboseCompleteBlock}
5632 debugln(['EndBlockIsOk cursor block is properly closed at ',CleanPosToStr(CurPos.StartPos)]);
5633 {$ENDIF}
5634 NeedCompletion:=0;
5635 end;
5636 EndBlock(Stack);
5637 Result:=true;
5638 if (not BehindCursorBlock) and (Stack.Top<CursorBlockLvl) then
5639 BehindCursorBlock:=true;
5640 end;
5641
CloseBracketsnull5642 function CloseBrackets: boolean;
5643 begin
5644 while TopBlockType(Stack) in [btRoundBracket,btEdgedBracket] do begin
5645 if not EndBlockIsOk then exit(false);
5646 end;
5647 Result:=true;
5648 end;
5649
InsertPosAtCursornull5650 function InsertPosAtCursor: integer;
5651 begin
5652 Result:=BasicCodeTools.FindLineEndOrCodeInFrontOfPosition(Src,
5653 CurPos.StartPos,CleanCursorPos,Scanner.NestedComments);
5654 end;
5655
5656 begin
5657 Result:=false;
5658 MoveCursorToNodeStart(StartNode);
5659 CursorBlockLvl:=-2;
5660 LastPos:=-1;
5661 CursorBlockOuterIndent:=0;
5662 CursorBlockInnerIndent:=0;
5663 Indent:=0;
5664 CursorBlock.StartPos:=0;
5665 BehindCursorBlock:=false;
5666 NeedCompletion:=0;
5667 AtomInFrontOfCursor.StartPos:=0;
5668 CursorInEmptyStatement:=false;
5669 repeat
5670 ReadNextAtom;
5671
5672 //DebugLn(['ReadStatements Atom=',GetAtom,' TopTyp=',ord(TopBlockType(Stack)),' Top=',Stack.Top]);
5673 if (Stack.Top>=0) and (Stack.Stack[Stack.Top].InnerIndent<0)
5674 and (not PositionsInSameLine(Src,Stack.Stack[Stack.Top].StartPos,CurPos.StartPos))
5675 then begin
5676 // the first atom of this block is on a new line
5677 Stack.Stack[Stack.Top].InnerIndent:=Beauty.GetLineIndent(Src,CurPos.StartPos);
5678 Stack.Stack[Stack.Top].InnerStartPos:=CurPos.StartPos;
5679 end;
5680
5681 // check if cursor reached
5682 if (CurPos.StartPos>=CleanCursorPos) and (CursorBlockLvl<0) then begin
5683 // reached cursor
5684 CursorBlockLvl:=Stack.Top;
5685 if CursorBlockLvl<0 then begin
5686 // cursor outside blocks or on first atom of first block
5687 {$IFDEF VerboseCompleteBlock}
5688 DebugLn(['ReadStatements no completion: cursor outside blocks or on first atom of first block ',CleanPosToStr(CurPos.StartPos)]);
5689 {$ENDIF}
5690 exit;
5691 end else begin
5692 CursorBlock:=Stack.Stack[CursorBlockLvl];
5693 CursorBlockOuterIndent:=Beauty.GetLineIndent(Src,CursorBlock.StartPos);
5694 CursorBlockInnerIndent:=Stack.Stack[Stack.Top].InnerIndent;
5695 if (CursorBlockInnerIndent<=CursorBlockOuterIndent)
5696 and OnlyIfCursorBlockIndented then begin
5697 // cursor block not indented
5698 {$IFDEF VerboseCompleteBlock}
5699 DebugLn(['ReadStatements no completion: cursor block not indented ',CleanPosToStr(CurPos.StartPos),' CursorBlockOuterIndent=',CursorBlockOuterIndent,' CursorBlockInnerIndent=',CursorBlockInnerIndent]);
5700 {$ENDIF}
5701 exit;
5702 end;
5703 AtomInFrontOfCursor:=LastAtoms.GetPriorAtom;
5704 {$IFDEF VerboseCompleteBlock}
5705 DebugLn(['ReadStatements reached cursor: ',CleanPosToStr(CurPos.StartPos),' CursorBlockOuterIndent=',CursorBlockOuterIndent,' CursorBlockInnerIndent=',CursorBlockInnerIndent,' LastAtom=',GetAtom(AtomInFrontOfCursor),' CurAtom=',GetAtom]);
5706 {$ENDIF}
5707 if (CurPos.Flag=cafSemicolon)
5708 and ((AtomInFrontOfCursor.Flag=cafSemicolon)
5709 or (CursorBlock.StartPos=AtomInFrontOfCursor.StartPos))
5710 and (FindNextNonSpace(Src,AtomInFrontOfCursor.EndPos)=CurPos.StartPos)
5711 then begin
5712 // cursor in empty statement
5713 CursorInEmptyStatement:=true;
5714 end;
5715 end;
5716 //DebugLn(['ReadStatements CursorBlockLvl=',CursorBlockLvl,' Indent=',CursorBlockIndent]);
5717 end;
5718
5719 InCursorBlock:=(CursorBlockLvl>=0) and (CursorBlockLvl=Stack.Top)
5720 and (not BehindCursorBlock);
5721 WasInCursorBlock:=InCursorBlock;
5722
5723 // check if end of node
5724 if (CurPos.StartPos>SrcLen) or (CurPos.StartPos>=StartNode.EndPos) then
5725 begin
5726 if InCursorBlock and (NeedCompletion=0) then begin
5727 {$IFDEF VerboseCompleteBlock}
5728 DebugLn(['ReadStatements NeedCompletion: source end found at ',CleanPosToStr(CurPos.StartPos)]);
5729 {$ENDIF}
5730 NeedCompletion:=CleanCursorPos;
5731 end;
5732 break;
5733 end;
5734
5735 // check if line start vs outer indent
5736 LineStart:=InCursorBlock and (LastPos>0)
5737 and not PositionsInSameLine(Src,LastPos,CurPos.StartPos);
5738 if LineStart then
5739 Indent:=Beauty.GetLineIndent(Src,CurPos.StartPos);
5740 if LineStart and (NeedCompletion=0) then begin
5741 // atom is in same block as cursor (not sub block)
5742 // and first atom of a line
5743 // => check indent
5744 //debugln(['CompleteStatements first atom of line in cursor block: ',GetAtom,' Indent=',Indent,' CursorBlockOuterIndent=',CursorBlockOuterIndent,' CursorBlockOuterIndent=',CursorBlockOuterIndent]);
5745 if (Indent=CursorBlockOuterIndent) then begin
5746 if (CursorBlockLvl>0)
5747 and (Stack.Stack[CursorBlockLvl-1].InnerIndent=Indent)
5748 and (Stack.Stack[CursorBlockLvl-1].InnerStartPos<CurPos.StartPos)
5749 then begin
5750 { for example:
5751 Code;
5752 begin|
5753 Code;
5754 }
5755 {$IFDEF VerboseCompleteBlock}
5756 DebugLn(['ReadStatements NeedCompletion: between same indented ',CleanPosToStr(CurPos.StartPos),' Indent=',Indent,' < CursorBlockOuterIndent=',CursorBlockOuterIndent,' < CursorBlockInnerIndent=',CursorBlockInnerIndent,' Parent.InnerStartPos=',CleanPosToStr(Stack.Stack[CursorBlockLvl-1].InnerStartPos)]);
5757 {$ENDIF}
5758 NeedCompletion:=InsertPosAtCursor;
5759 end;
5760 end else if (Indent<CursorBlockOuterIndent) then begin
5761 // for example:
5762 // begin
5763 // Code;
5764 // |end;
5765 //DebugLn(['ReadStatements Indent=',Indent,' < CursorBlockOuterIndent=',CursorBlockOuterIndent,' CursorBlockInnerIndent=',CursorBlockInnerIndent,' CursorAtEmptyLine=',CursorAtEmptyLine,' CursorInEmptyStatement=',CursorInEmptyStatement]);
5766 if CursorBlockOuterIndent<CursorBlockInnerIndent then begin
5767 // for example:
5768 // begin
5769 // Code;
5770 // |end;
5771 {$IFDEF VerboseCompleteBlock}
5772 DebugLn(['ReadStatements NeedCompletion: at out indented ',CleanPosToStr(CurPos.StartPos),' Indent=',Indent,' < CursorBlockOuterIndent=',CursorBlockOuterIndent,' < CursorBlockInnerIndent=',CursorBlockInnerIndent]);
5773 {$ENDIF}
5774 NeedCompletion:=InsertPosAtCursor;
5775 end else if CursorAtEmptyLine or CursorInEmptyStatement
5776 or (FindNextNonSpace(Src,CleanCursorPos)=CurPos.StartPos) then begin
5777 { for example:
5778 begin
5779 |
5780 Code;
5781 end;
5782
5783 begin
5784 Code;
5785 |
5786 end;
5787 }
5788 {$IFDEF VerboseCompleteBlock}
5789 DebugLn(['ReadStatements NeedCompletion: at empty line ',CleanPosToStr(CleanCursorPos),' Indent=',Indent,' < CursorBlockOuterIndent=',CursorBlockOuterIndent,' < CursorBlockInnerIndent=',CursorBlockInnerIndent]);
5790 {$ENDIF}
5791 NeedCompletion:=CleanCursorPos;
5792 end else begin
5793 { It needs completion, but where?
5794 for example:
5795 begin
5796 begin|
5797 Code;
5798 end;
5799 }
5800 end;
5801 end;
5802 end;
5803
5804 // check block starts/ends
5805 case CurPos.Flag of
5806 cafEnd:
5807 if (CurPos.EndPos<=SrcLen) and (Src[CurPos.EndPos]='.') then begin
5808 { end. of source found
5809 The parsing started in a begin block, valid cases:
5810
5811 program a;
5812 begin|
5813 end.
5814
5815 implementation
5816 begin|
5817 end.
5818 }
5819 if (Stack.Top=0) and (TopBlockType(Stack)=btBegin)
5820 and (StartNode.Desc=ctnBeginBlock)
5821 and ((StartNode.Parent=nil)
5822 or (StartNode.Parent.Desc in AllSourceTypes+[ctnInterface,ctnImplementation]))
5823 then begin
5824 if not EndBlockIsOk then exit; // close main begin
5825 end else begin
5826 // unexpected end of source
5827 {$IFDEF VerboseCompleteBlock}
5828 DebugLn(['ReadStatements unexpected end. at ',CleanPosToStr(CurPos.StartPos)]);
5829 {$ENDIF}
5830 if InCursorBlock and (NeedCompletion=0) then begin
5831 {$IFDEF VerboseCompleteBlock}
5832 DebugLn(['ReadStatements NeedCompletion: unexpected end. at ',CleanPosToStr(CurPos.StartPos)]);
5833 {$ENDIF}
5834 NeedCompletion:=CleanCursorPos;
5835 end;
5836 end;
5837 break;
5838 end else begin
5839 case TopBlockType(Stack) of
5840 btCaseOf,btCaseElse:
5841 begin
5842 if not EndBlockIsOk then exit; // close btCaseOf,btCaseElse
5843 if not EndBlockIsOk then exit; // close btCase
5844 end;
5845 btBegin,btFinally,btExcept,btCase:
5846 if not EndBlockIsOk then exit;
5847 btCaseColon,btRepeat:
5848 begin
5849 // missing semicolon or until
5850 DebugLn(['ReadStatements CursorBlockLvl=',CursorBlockLvl,' Stack.Top=',Stack.Top,' BehindCursorBlock=',BehindCursorBlock]);
5851 DebugLn(['ReadStatements unexpected end at ',CleanPosToStr(CurPos.StartPos),': missing finally ',CleanPosToStr(Stack.Stack[Stack.Top].StartPos)]);
5852 if InCursorBlock and (NeedCompletion=0) then begin
5853 {$IFDEF VerboseCompleteBlock}
5854 DebugLn(['ReadStatements NeedCompletion: unexpected end at ',CleanPosToStr(CurPos.StartPos),': missing semicolon or until ',CleanPosToStr(Stack.Stack[Stack.Top].StartPos)]);
5855 {$ENDIF}
5856 NeedCompletion:=CleanCursorPos;
5857 end;
5858 break;
5859 end;
5860 btTry:
5861 begin
5862 // missing finally/except
5863 DebugLn(['ReadStatements CursorBlockLvl=',CursorBlockLvl,' Stack.Top=',Stack.Top,' BehindCursorBlock=',BehindCursorBlock]);
5864 DebugLn(['ReadStatements unexpected end at ',CleanPosToStr(CurPos.StartPos),': missing finally ',CleanPosToStr(Stack.Stack[Stack.Top].StartPos)]);
5865 if InCursorBlock and (NeedCompletion=0) then begin
5866 {$IFDEF VerboseCompleteBlock}
5867 DebugLn(['ReadStatements NeedCompletion: unexpected end at ',CleanPosToStr(CurPos.StartPos),': missing finally ',CleanPosToStr(Stack.Stack[Stack.Top].StartPos)]);
5868 {$ENDIF}
5869 NeedCompletion:=CleanCursorPos;
5870 end;
5871 break;
5872 end;
5873 btAsm:
5874 if (CurPos.StartPos>1) and (Src[CurPos.StartPos-1]<>'@') then begin
5875 if not EndBlockIsOk then exit;
5876 end;
5877 else
5878 // missing begin
5879 exit;
5880 end;
5881 end;
5882 cafEdgedBracketOpen:
5883 BeginBlock(Stack,btEdgedBracket,CurPos.StartPos);
5884 cafEdgedBracketClose:
5885 if TopBlockType(Stack)=btEdgedBracket then begin
5886 if not EndBlockIsOk then exit;
5887 end else begin
5888 // missing [
5889 exit;
5890 end;
5891 cafRoundBracketOpen:
5892 BeginBlock(Stack,btRoundBracket,CurPos.StartPos);
5893 cafRoundBracketClose:
5894 if TopBlockType(Stack)=btRoundBracket then begin
5895 if not EndBlockIsOk then exit;
5896 end else begin
5897 // missing (
5898 exit;
5899 end;
5900 cafColon:
5901 if TopBlockType(Stack)=btCaseOf then
5902 BeginBlock(Stack,btCaseColon,CurPos.StartPos);
5903 cafSemicolon:
5904 while TopBlockType(Stack)
5905 in [btCaseColon,btIf,btIfElse,btRoundBracket,btEdgedBracket] do begin
5906 if not EndBlockIsOk then exit;
5907 end;
5908 cafWord:
5909 if TopBlockType(Stack)<>btAsm then begin
5910 if UpAtomIs('BEGIN') then
5911 BeginBlock(Stack,btBegin,CurPos.StartPos)
5912 else if UpAtomIs('TRY') then
5913 BeginBlock(Stack,btTry,CurPos.StartPos)
5914 else if UpAtomIs('FINALLY') then begin
5915 if TopBlockType(Stack)=btTry then
5916 if not EndBlockIsOk then exit;
5917 BeginBlock(Stack,btFinally,CurPos.StartPos)
5918 end else if UpAtomIs('EXCEPT') then begin
5919 if TopBlockType(Stack)=btTry then
5920 if not EndBlockIsOk then exit;
5921 BeginBlock(Stack,btExcept,CurPos.StartPos)
5922 end else if UpAtomIs('REPEAT') then
5923 BeginBlock(Stack,btRepeat,CurPos.StartPos)
5924 else if UpAtomIs('UNTIL') then begin
5925 if TopBlockType(Stack)=btRepeat then begin
5926 if not EndBlockIsOk then exit;
5927 end else begin
5928 // until without repeat
5929 DebugLn(['ReadStatements CursorBlockLvl=',CursorBlockLvl,' Stack.Top=',Stack.Top,' BehindCursorBlock=',BehindCursorBlock,' Block=',ord(TopBlockType(Stack))]);
5930 DebugLn(['ReadStatements unexpected until at ',CleanPosToStr(CurPos.StartPos)]);
5931 exit;
5932 end;
5933 end else if UpAtomIs('ASM') then begin
5934 BeginBlock(Stack,btAsm,CurPos.StartPos);
5935 end else if UpAtomIs('IF') then begin
5936 BeginBlock(Stack,btIf,CurPos.StartPos);
5937 end else if UpAtomIs('THEN') then begin
5938 CloseBrackets;
5939 if TopBlockType(Stack)=btIf then begin
5940 Stack.Stack[Stack.Top].InnerIndent:=-1;
5941 Stack.Stack[Stack.Top].InnerStartPos:=-1;
5942 end;
5943 end else if UpAtomIs('CASE') then begin
5944 BeginBlock(Stack,btCase,CurPos.StartPos)
5945 end else if UpAtomIs('OF') then begin
5946 CloseBrackets;
5947 if TopBlockType(Stack)=btCase then
5948 BeginBlock(Stack,btCaseOf,CurPos.StartPos);
5949 end else if UpAtomIs('ELSE') then begin
5950 CloseBrackets;
5951 case TopBlockType(Stack) of
5952 btIf:
5953 begin
5954 if not EndBlockIsOk then exit;
5955 BeginBlock(Stack,btIfElse,CurPos.StartPos);
5956 end;
5957 btCaseOf:
5958 begin
5959 if not EndBlockIsOk then exit;
5960 BeginBlock(Stack,btCaseElse,CurPos.StartPos);
5961 end;
5962 btBegin:
5963 begin
5964 // missing end
5965 if InCursorBlock and (NeedCompletion=0) then begin
5966 {$IFDEF VerboseCompleteBlock}
5967 DebugLn(['ReadStatements NeedCompletion: unexpected else at ',CleanPosToStr(CurPos.StartPos),': missing end. block start: ',CleanPosToStr(Stack.Stack[Stack.Top].StartPos)]);
5968 {$ENDIF}
5969 NeedCompletion:=InsertPosAtCursor;
5970 end;
5971 break;
5972 end;
5973 btCaseColon,btRepeat:
5974 begin
5975 // missing semicolon
5976 if InCursorBlock and (NeedCompletion=0) then begin
5977 {$IFDEF VerboseCompleteBlock}
5978 DebugLn(['ReadStatements NeedCompletion: unexpected else at ',CleanPosToStr(CurPos.StartPos),': missing semicolon or until. block start: ',CleanPosToStr(Stack.Stack[Stack.Top].StartPos)]);
5979 {$ENDIF}
5980 NeedCompletion:=InsertPosAtCursor;
5981 end;
5982 break;
5983 end;
5984 end;
5985 end else if UpAtomIs('PROCEDURE') or UpAtomIs('FUNCTION')
5986 or UpAtomIs('CONSTRUCTOR') or UpAtomIs('DESTRUCTOR')
5987 or UpAtomIs('VAR') or UpAtomIs('TYPE') or UpAtomIs('CONST')
5988 or UpAtomIs('RESOURCESTRING') or UpAtomIs('LABEL') or UpAtomIs('CLASS')
5989 or UpAtomIs('INITIALIZATION') or UpAtomIs('FINALIZATION')
5990 then begin
5991 // unexpected keyword => block not closed
5992 if InCursorBlock and (NeedCompletion=0) then begin
5993 {$IFDEF VerboseCompleteBlock}
5994 DebugLn(['ReadStatements NeedCompletion: unexpected keyword ',GetAtom,' at ',CleanPosToStr(CurPos.StartPos)]);
5995 {$ENDIF}
5996 NeedCompletion:=CleanCursorPos;
5997 end;
5998 break;
5999 end;
6000 end;
6001 end;
6002
6003 // check if line start
6004 if LineStart and WasInCursorBlock and (not BehindCursorBlock) then begin
6005 // atom is first atom of a line
6006 // and atom is in same block as cursor (not sub block)
6007 // (maybe the atom started a new sub block, but it did not close it)
6008 // => check indent
6009 //debugln(['CompleteStatements ',CleanPosToStr(CurPos.StartPos),' Indent=',Indent,' CursorBlockInnerIndent=',CursorBlockInnerIndent,' CursorBlockOuterIndent=',CursorBlockOuterIndent]);
6010 if (Indent<CursorBlockInnerIndent) and (NeedCompletion=0) then begin
6011 if CursorBlockOuterIndent<CursorBlockInnerIndent then begin
6012 // for example:
6013 // begin
6014 // Code;
6015 // |
6016 // Code;
6017 // Code;
6018 //DebugLn(['ReadStatements Indent=',Indent,' < CursorBlockIndent=',CursorBlockIndent]);
6019 {$IFDEF VerboseCompleteBlock}
6020 DebugLn(['ReadStatements NeedCompletion: at ',CleanPosToStr(CurPos.StartPos),' Indent=',Indent,' < CursorBlockInnerIndent=',CursorBlockInnerIndent]);
6021 {$ENDIF}
6022 NeedCompletion:=InsertPosAtCursor;
6023 end else begin
6024 // for example:
6025 // begin
6026 // |
6027 // Code;
6028 {$IFDEF VerboseCompleteBlock}
6029 DebugLn(['ReadStatements NeedCompletion: at ',CleanPosToStr(CleanCursorPos),' Indent=',Indent,' CursorBlockInnerIndent=',CursorBlockInnerIndent]);
6030 {$ENDIF}
6031 NeedCompletion:=CleanCursorPos;
6032 // Note: if the end is coming later, NeedCompletion is disabled
6033 end;
6034 end;
6035 end;
6036
6037 LastPos:=CurPos.StartPos;
6038 until Stack.Top<0;
6039
6040 {$IFDEF VerboseCompleteBlock}
6041 DebugLn(['ReadStatements END Stack.Top=',Stack.Top,' CursorBlockLvl=',CursorBlockLvl,' BehindCursorBlock=',BehindCursorBlock]);
6042 {$ENDIF}
6043
6044 if Stack.Top<0 then begin
6045 // all blocks closed
6046 {$IFDEF VerboseCompleteBlock}
6047 if NeedCompletion>0 then
6048 DebugLn(['ReadStatements all blocks closed: no completion needed']);
6049 {$ENDIF}
6050 NeedCompletion:=0;
6051 end;
6052
6053 if (NeedCompletion>0) then begin
6054 InsertPos:=NeedCompletion;
6055 while (InsertPos>CleanCursorPos) and (IsSpaceChar[Src[InsertPos-1]]) do
6056 dec(InsertPos);
6057 Indent:=CursorBlockOuterIndent;
6058
6059 // check code behind
6060 BehindPos:=FindNextNonSpace(Src,InsertPos);
6061 if BehindPos<=SrcLen then begin
6062 if (not CursorInEmptyStatement)
6063 and PositionsInSameLine(Src,InsertPos,BehindPos) then begin
6064 // target line not empty
6065 {$IFDEF VerboseCompleteBlock}
6066 DebugLn(['CompleteStatements target line not empty => skip']);
6067 {$ENDIF}
6068 exit;
6069 end;
6070 if (Beauty.GetLineIndent(Src,BehindPos)>Indent) then begin
6071 // code behind is more indented
6072 // for example
6073 // repeat
6074 // |
6075 // DoSomething;
6076 debugln(['CompleteStatements BehindPos ',dbgstr(copy(Src,BehindPos-8,8)),'|',dbgstr(copy(Src,BehindPos,8))]);
6077 {$IFDEF VerboseCompleteBlock}
6078 DebugLn(['CompleteStatements code behind is indented more (Behind=',Beauty.GetLineIndent(Src,BehindPos),' > Indent=',Indent,') => skip']);
6079 {$ENDIF}
6080 exit;
6081 end;
6082 end;
6083
6084 NewCode:=';';
6085 FrontGap:=gtEmptyLine;
6086 AfterGap:=gtNewLine;
6087 FromPos:=InsertPos;
6088 ToPos:=InsertPos;
6089 BeautifyFlags:=[bcfIndentExistingLineBreaks];
6090 if CursorInEmptyStatement and (BehindPos<=SrcLen) then begin
6091 // replace the empty statement
6092 FrontGap:=gtNewLine;
6093 ToPos:=BehindPos;
6094 end;
6095 case CursorBlock.Typ of
6096 btBegin,btFinally,btExcept,btAsm,btCaseOf,btCaseElse:
6097 NewCode:='end'+NewCode;
6098 btRepeat:
6099 NewCode:='until '+NewCode;
6100 btTry:
6101 NewCode:='finally'+SourceChangeCache.BeautifyCodeOptions.LineEnd
6102 +'end'+NewCode;
6103 btCaseColon:
6104 begin
6105 FrontGap:=gtNone;
6106 AfterGap:=gtNone;
6107 end;
6108 else
6109 exit;
6110 end;
6111 if (CursorBlockLvl=0) and (AfterGap=gtNewLine) then begin
6112 // top level => insert empty lines between top level structures
6113 AfterGap:=gtEmptyLine;
6114 end;
6115 if not Replace(NewCode,FromPos,ToPos,Indent,FrontGap,AfterGap,
6116 BeautifyFlags) then exit;
6117 end;
6118 Result:=true;
6119 end;
6120
CompleteClassSectionnull6121 function CompleteClassSection: Boolean;
6122 { type
6123 TMyClass = class
6124 |
6125 }
6126 var
6127 LastIndent: LongInt;
6128 Indent: LongInt;
6129 InsertPos: LongInt;
6130 NeedCompletion: Integer;
6131 begin
6132 Result:=false;
6133 if CleanCursorPos<StartNode.StartPos then exit;
6134 LastIndent:=Beauty.GetLineIndent(Src,StartNode.Parent.StartPos);
6135 MoveCursorToNodeStart(StartNode);
6136 //debugln(['CompleteClassSection ',dbgstr(copy(Src,StartNode.StartPos-10,10)),'|',dbgstr(copy(Src,StartNode.StartPos,10))]);
6137 Indent:=Beauty.GetLineIndent(Src,CurPos.StartPos);
6138 if Indent<LastIndent then
6139 LastIndent:=Indent;
6140 ReadNextAtom;
6141 NeedCompletion:=0;
6142 if (CurPos.StartPos>SrcLen) then begin
6143 { For example:
6144 TMyClass = class
6145 <EOF>
6146 }
6147 NeedCompletion:=CleanCursorPos;
6148 end else if CurPos.Flag=cafWord then begin
6149 if AtomIsIdentifier then begin
6150 ReadNextAtom;
6151 if CurPos.Flag=cafEqual then begin
6152 { For example:
6153 TMyClass = class
6154
6155 TIdentifier =
6156 }
6157 NeedCompletion:=CleanCursorPos;
6158 end else
6159 exit(true);
6160 end else begin
6161 Indent:=Beauty.GetLineIndent(Src,CurPos.StartPos);
6162 if Indent<LastIndent then begin
6163 { For example:
6164 TMyClass = class
6165
6166 type
6167 }
6168 NeedCompletion:=CleanCursorPos;
6169 end;
6170 end;
6171 end else
6172 exit(true);
6173 //debugln(['CompleteClassSection NeedCompletion=',NeedCompletion]);
6174 if NeedCompletion>0 then begin
6175 InsertPos:=NeedCompletion;
6176 Result:=Replace('end;',InsertPos,InsertPos,LastIndent,
6177 gtNewLine,gtEmptyLine,
6178 [bcfIndentExistingLineBreaks]);
6179 end else
6180 Result:=true;
6181 end;
6182
CompleteClassInterfacenull6183 function CompleteClassInterface: Boolean;
6184 { type
6185 TMyClass = interface
6186 |
6187 }
6188 var
6189 LastIndent: LongInt;
6190 Indent: LongInt;
6191 InsertPos: LongInt;
6192 begin
6193 Result:=false;
6194 if CleanCursorPos<StartNode.StartPos then exit;
6195 LastIndent:=Beauty.GetLineIndent(Src,StartNode.StartPos);
6196 MoveCursorToNodeStart(StartNode);
6197 ReadNextAtom;
6198 if CleanCursorPos<CurPos.EndPos then exit(true);
6199 ReadNextAtom;
6200 if CurPos.Flag=cafEnd then exit(true);
6201 if CleanCursorPos<=CurPos.StartPos then begin
6202 Indent:=Beauty.GetLineIndent(Src,CurPos.StartPos);
6203 InsertPos:=CleanCursorPos;
6204 if Indent<LastIndent then begin
6205 if not Replace('end;',InsertPos,InsertPos,LastIndent,
6206 gtNewLine,gtEmptyLine,
6207 [bcfIndentExistingLineBreaks])
6208 then
6209 exit;
6210 end;
6211 end;
6212 Result:=true;
6213 end;
6214
CompleteRecordnull6215 function CompleteRecord: Boolean;
6216 { type
6217 TMyClass = record
6218 |
6219 }
6220 var
6221 LastIndent: LongInt;
6222 Indent: LongInt;
6223 InsertPos: LongInt;
6224 begin
6225 Result:=false;
6226 if CleanCursorPos<StartNode.StartPos then exit;
6227 LastIndent:=Beauty.GetLineIndent(Src,StartNode.StartPos);
6228 MoveCursorToNodeStart(StartNode);
6229 ReadNextAtom; // record
6230 if CleanCursorPos<CurPos.EndPos then exit(true);
6231 ReadNextAtom;
6232 if CurPos.Flag=cafEnd then exit(true);
6233 if CleanCursorPos<=CurPos.StartPos then begin
6234 Indent:=Beauty.GetLineIndent(Src,CurPos.StartPos);
6235 InsertPos:=CleanCursorPos;
6236 if Indent<=LastIndent then begin
6237 if not Replace('end;',InsertPos,InsertPos,LastIndent,
6238 gtNewLine,gtEmptyLine,
6239 [bcfIndentExistingLineBreaks])
6240 then
6241 exit;
6242 end;
6243 end;
6244 Result:=true;
6245 end;
6246
6247 var
6248 Stack: TBlockStack;
6249 CommentStart, CommentEnd: integer;
6250 begin
6251 Result:=false;
6252 NewPos:=CursorPos;
6253 NewTopLine:=-1;
6254 BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanCursorPos,
6255 [btSetIgnoreErrorPos]);
6256 StartNode:=FindDeepestNodeAtPos(CleanCursorPos,true);
6257 if CleanPosIsInComment(CleanCursorPos,StartNode.StartPos,CommentStart,CommentEnd) then begin
6258 {$IFDEF VerboseCompleteBlock}
6259 debugln(['TStandardCodeTool.CompleteBlock cursor (',CursorPos.Y,',',CursorPos.X,') cleanpos=[',CleanPosToStr(CleanCursorPos),'] in comment Start=[',CleanPosToStr(CommentStart),'] End=[',CleanPosToStr(CommentEnd),']']);
6260 {$ENDIF}
6261 exit;
6262 end;
6263
6264 InternalCursorAtEmptyLine:=ebNone;
6265 SourceChangeCache.MainScanner:=Scanner;
6266 Beauty:=SourceChangeCache.BeautifyCodeOptions;
6267 InitStack(Stack);
6268 try
6269 {$IFDEF VerboseCompleteBlock}
6270 DebugLn(['TStandardCodeTool.CompleteBlock ',StartNode.DescAsString]);
6271 {$ENDIF}
6272
6273 if StartNode.Desc in AllPascalStatements then begin
6274 while (StartNode.Parent<>nil)
6275 and (StartNode.Parent.Desc in AllPascalStatements) do
6276 StartNode:=StartNode.Parent;
6277 if not CompleteStatements(Stack) then exit;
6278 end
6279 else if (StartNode.Desc in AllClassSections)
6280 or ((StartNode.Desc in AllClassSubSections) and (StartNode.Parent.Desc in AllClassSections))
6281 then begin
6282 if not CompleteClassSection then exit;
6283 end
6284 else if StartNode.Desc in AllClassInterfaces then begin
6285 if not CompleteClassInterface then exit;
6286 end
6287 else if StartNode.Desc=ctnRecordType then begin
6288 if not CompleteRecord then exit;
6289 end;
6290 finally
6291 FreeStack(Stack);
6292 end;
6293
6294 Result:=true;
6295 end;
6296
GuessMisplacedIfdefEndifnull6297 function TStandardCodeTool.GuessMisplacedIfdefEndif(
6298 const CursorPos: TCodeXYPosition;
6299 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
6300 var
6301 StartCursorPos, EndCursorPos: integer;
6302 StartCode, EndCode: Pointer;
6303 begin
6304 Result:=false;
6305 try
6306 BeginParsing(lsrEnd);
6307 except
6308 // ignore scanner and parser errors
6309 on e: ELinkScannerError do ;
6310 on e: ECodeToolError do ;
6311 end;
6312 if Scanner<>nil then begin
6313 CursorPos.Code.LineColToPosition(CursorPos.Y,CursorPos.X,StartCursorPos);
6314 StartCode:=CursorPos.Code;
6315 Result:=Scanner.GuessMisplacedIfdefEndif(StartCursorPos,StartCode,
6316 EndCursorPos,EndCode);
6317 if Result then begin
6318 NewPos.Code:=TCodeBuffer(EndCode);
6319 NewPos.Code.AbsoluteToLineCol(EndCursorPos,NewPos.Y,NewPos.X);
6320 if JumpSingleLinePos>0 then begin
6321 NewTopLine:=NewPos.Y-(VisibleEditorLines*JumpSingleLinePos div 100);
6322 if NewTopLine<1 then NewTopLine:=1;
6323 end else
6324 NewTopLine:=NewPos.Y;
6325 end;
6326 end;
6327 end;
6328
TStandardCodeTool.FindEnclosingIncludeDirectivenull6329 function TStandardCodeTool.FindEnclosingIncludeDirective(
6330 const CursorPos: TCodeXYPosition; out NewPos: TCodeXYPosition; out
6331 NewTopLine: integer): boolean;
6332 var
6333 CleanCursorPos, LinkIndex, NewCleanPos: integer;
6334 begin
6335 Result:=false;
6336 NewPos:=CleanCodeXYPosition;
6337 NewTopLine:=-1;
6338 try
6339 BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanCursorPos,
6340 [btSetIgnoreErrorPos]);
6341 LinkIndex:=Scanner.LinkIndexAtCleanPos(CleanCursorPos);
6342 LinkIndex:=Scanner.FindParentLink(LinkIndex);
6343 if LinkIndex<0 then
6344 // this is no include file
6345 exit;
6346 NewPos.Code:=TCodeBuffer(Scanner.Links[LinkIndex].Code);
6347 // calculate the directive end bracket
6348 NewCleanPos:=Scanner.Links[LinkIndex].CleanedPos+Scanner.LinkSize(LinkIndex)-1;
6349 Result:=CleanPosToCaretAndTopLine(NewCleanPos,NewPos,NewTopLine);
6350 finally
6351 ClearIgnoreErrorAfter;
6352 end;
6353 end;
6354
FindModeDirectivenull6355 function TStandardCodeTool.FindModeDirective(DoBuildTree: boolean;
6356 out ACleanPos: integer): boolean;
6357 var
6358 ParamPos: Integer;
6359 begin
6360 Result:=false;
6361 ACleanPos:=0;
6362 if DoBuildTree then BuildTree(lsrMainUsesSectionStart);
6363 ACleanPos:=FindNextCompilerDirectiveWithName(Src,1,'Mode',
6364 Scanner.NestedComments,ParamPos);
6365 if ParamPos=0 then ;
6366 Result:=(ACleanPos>0) and (ACleanPos<=SrcLen);
6367 end;
6368
FindResourceDirectivenull6369 function TStandardCodeTool.FindResourceDirective(DoBuildTree: boolean;
6370 var ACleanPos: integer; const Filename: string): boolean;
6371 var
6372 ParamPos: Integer;
6373 FilenameStartPos: Integer;
6374 FilenameEndPos: LongInt;
6375 begin
6376 Result:=false;
6377 if DoBuildTree then BuildTree(lsrEnd);
6378 ACleanPos:=1;
6379 repeat
6380 ACleanPos:=FindNextCompilerDirectiveWithName(Src,ACleanPos,'R',
6381 Scanner.NestedComments,ParamPos);
6382 if ParamPos=0 then ;
6383 if (ACleanPos<1) or (ACleanPos>SrcLen) then
6384 exit(false);
6385 if Filename='' then begin
6386 // searching any filename -> found
6387 exit(true);
6388 end;
6389 FilenameStartPos:=ACleanPos+length('{$R ');
6390 FilenameEndPos:=FilenameStartPos;
6391 while (FilenameEndPos<=SrcLen) and (Src[FilenameEndPos]<>'}') do
6392 inc(FilenameEndPos);
6393 if CompareText(PChar(Pointer(Filename)),length(Filename),
6394 @Src[FilenameStartPos],FilenameEndPos-FilenameStartPos,
6395 true,false)=0
6396 then begin
6397 // filename found
6398 exit(true);
6399 end;
6400 ACleanPos:=FilenameEndPos+1;
6401 until ACleanPos>SrcLen;
6402 end;
6403
FindResourceDirectivenull6404 function TStandardCodeTool.FindResourceDirective(
6405 const CursorPos: TCodeXYPosition; out NewPos: TCodeXYPosition;
6406 out NewTopLine: integer; const Filename: string): boolean;
6407 var
6408 CleanCursorPos: integer;
6409 begin
6410 Result:=false;
6411 BuildTreeAndGetCleanPos(CursorPos,CleanCursorPos);
6412 if not FindResourceDirective(false,CleanCursorPos,Filename) then begin
6413 //DebugLn('TStandardCodeTool.FindResourceDirective resource directive not found');
6414 exit;
6415 end;
6416 Result:=CleanPosToCaretAndTopLine(CleanCursorPos,NewPos,NewTopLine);
6417 end;
6418
TStandardCodeTool.AddResourceDirectivenull6419 function TStandardCodeTool.AddResourceDirective(const Filename: string;
6420 SourceChangeCache: TSourceChangeCache; const NewSrc: string): boolean;
6421 var
6422 ANode: TCodeTreeNode;
6423 Indent: LongInt;
6424 InsertPos: Integer;
6425 AddSrc: String;
6426 Beauty: TBeautifyCodeOptions;
6427 begin
6428 Result:=false;
6429 BuildTree(lsrEnd);
6430 Beauty:=SourceChangeCache.BeautifyCodeOptions;
6431 // find an insert position
6432 ANode:=FindImplementationNode;
6433 if ANode<>nil then begin
6434 Indent:=Beauty.GetLineIndent(Src,ANode.StartPos);
6435 InsertPos:=ANode.StartPos+length('implementation');
6436 end else begin
6437 ANode:=FindMainBeginEndNode;
6438 if ANode<>nil then begin
6439 Indent:=Beauty.GetLineIndent(Src,ANode.StartPos);
6440 InsertPos:=ANode.StartPos;
6441 end else begin
6442 ANode:=FindMainUsesNode;
6443 if ANode<>nil then begin
6444 Indent:=Beauty.GetLineIndent(Src,ANode.StartPos);
6445 InsertPos:=ANode.StartPos;
6446 end else begin
6447 Indent:=0;
6448 InsertPos:=1;
6449 end;
6450 end;
6451 end;
6452
6453 // insert directive
6454 SourceChangeCache.MainScanner:=Scanner;
6455 if NewSrc<>'' then
6456 AddSrc:=NewSrc
6457 else
6458 AddSrc:=Beauty.GetIndentStr(Indent)+'{$R '+Filename+'}';
6459 if not SourceChangeCache.Replace(gtEmptyLine,gtEmptyLine,InsertPos,InsertPos,
6460 AddSrc) then exit;
6461 if not SourceChangeCache.Apply then exit;
6462
6463 Result:=true;
6464 end;
6465
FindIncludeDirectivenull6466 function TStandardCodeTool.FindIncludeDirective(DoBuildTree: boolean;
6467 var ACleanPos: integer; const Filename: string): boolean;
6468 var
6469 FilenameStartPos: Integer;
6470 FilenameEndPos: LongInt;
6471 CommentStart: integer;
6472 CommentEnd: integer;
6473 begin
6474 Result:=false;
6475 if DoBuildTree then BuildTree(lsrEnd);
6476 ACleanPos:=1;
6477 repeat
6478 ACleanPos:=FindNextIncludeDirective(Src,ACleanPos,Scanner.NestedComments,
6479 FilenameStartPos,FilenameEndPos,CommentStart,CommentEnd);
6480 if (ACleanPos<1) or (ACleanPos>SrcLen) then
6481 exit(false);
6482 if Filename='' then begin
6483 // searching any filename -> found
6484 exit(true);
6485 end;
6486 if CompareText(PChar(Pointer(Filename)),length(Filename),
6487 @Src[FilenameStartPos],FilenameEndPos-FilenameStartPos,
6488 true,false)=0
6489 then begin
6490 // filename found
6491 exit(true);
6492 end;
6493 ACleanPos:=FilenameEndPos+1;
6494 until ACleanPos>SrcLen;
6495 end;
6496
FindIncludeDirectivenull6497 function TStandardCodeTool.FindIncludeDirective(
6498 const CursorPos: TCodeXYPosition; out NewPos: TCodeXYPosition; out
6499 NewTopLine: integer; const Filename: string): boolean;
6500 var
6501 CleanCursorPos: integer;
6502 begin
6503 Result:=false;
6504 BuildTreeAndGetCleanPos(CursorPos,CleanCursorPos);
6505 if not FindIncludeDirective(false,CleanCursorPos,Filename) then begin
6506 //DebugLn('TStandardCodeTool.FindIncludeDirective resource directive not found');
6507 exit;
6508 end;
6509 Result:=CleanPosToCaretAndTopLine(CleanCursorPos,NewPos,NewTopLine);
6510 end;
6511
TStandardCodeTool.AddIncludeDirectiveForInitnull6512 function TStandardCodeTool.AddIncludeDirectiveForInit(const Filename: string;
6513 SourceChangeCache: TSourceChangeCache; const NewSrc: string): boolean;
6514 var
6515 ANode: TCodeTreeNode;
6516 Indent: LongInt;
6517 InsertPos: Integer;
6518 AddSrc: String;
6519 Beauty: TBeautifyCodeOptions;
6520 begin
6521 Result:=false;
6522 BuildTree(lsrEnd);
6523 Beauty:=SourceChangeCache.BeautifyCodeOptions;
6524 // find an insert position
6525 ANode:=FindInitializationNode;
6526 if ANode<>nil then begin
6527 Indent:=Beauty.GetLineIndent(Src,ANode.StartPos)+Beauty.Indent;
6528 InsertPos:=ANode.StartPos+length('initialization');
6529 end else begin
6530 ANode:=FindMainBeginEndNode;
6531 if ANode<>nil then begin
6532 MoveCursorToNodeStart(ANode);
6533 ReadNextAtom;
6534 //debugln(['TStandardCodeTool.AddIncludeDirective ',GetAtom]);
6535 Indent:=Beauty.GetLineIndent(Src,CurPos.StartPos)+Beauty.Indent;
6536 InsertPos:=CurPos.EndPos;
6537 end else begin
6538 debugln(['TStandardCodeTool.AddIncludeDirective ToDo: add initialization / begin..end']);
6539 exit;
6540 end;
6541 end;
6542
6543 // insert directive
6544 SourceChangeCache.MainScanner:=Scanner;
6545 if NewSrc<>'' then
6546 AddSrc:=NewSrc
6547 else
6548 AddSrc:=Beauty.GetIndentStr(Indent)+'{$I '+Filename+'}';
6549 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,InsertPos,InsertPos,
6550 AddSrc) then exit;
6551 if not SourceChangeCache.Apply then exit;
6552
6553 Result:=true;
6554 end;
6555
AddUnitWarnDirectivenull6556 function TStandardCodeTool.AddUnitWarnDirective(WarnID, Comment: string;
6557 TurnOn: boolean; SourceChangeCache: TSourceChangeCache): boolean;
6558 const
6559 DirectiveFlagValue: array[boolean] of string = ('off','on');
6560 var
6561 ACleanPos, DirEndPos, InsertStartPos, MaxPos: Integer;
6562 Node: TCodeTreeNode;
6563 p, IDStartPos, IDEndPos, ParamPos: PChar;
6564 NewCode: String;
6565 begin
6566 Result:=false;
6567 if WarnID='' then
6568 raise Exception.Create('TStandardCodeTool.AddUnitWarnDirective missing WarnID');
6569 InsertStartPos:=0;
6570 BuildTree(lsrMainUsesSectionStart);
6571 SourceChangeCache.MainScanner:=Scanner;
6572
6573 // fix comment
6574 if Comment<>'' then begin
6575 for ACleanPos:=1 to length(Comment) do
6576 if Comment[ACleanPos] in [#0..#8,#11,#12,#14..#31,'{','}'] then
6577 Comment[ACleanPos]:='?';
6578 if not (Comment[1] in [' ',#9,#10,#13]) then Comment:=' '+Comment;
6579 end;
6580
6581 // insert in front of first node after source name
6582 Node:=Tree.Root;
6583 MaxPos:=Node.StartPos;
6584 if Node.Desc in AllSourceTypes then
6585 Node:=Node.Next;
6586 if (Node<>nil) and (Node.Desc=ctnSrcName) then begin
6587 MaxPos:=Node.EndPos;
6588 Node:=Node.NextSkipChilds;
6589 end;
6590 if Node<>nil then
6591 MaxPos:=Node.StartPos;
6592 MaxPos:=FindLineEndOrCodeAfterPosition(MaxPos,true,true);
6593
6594 // find existing directive for replacement
6595 ACleanPos:=1;
6596 repeat
6597 ACleanPos:=FindNextCompilerDirective(Src,ACleanPos,Scanner.NestedComments);
6598 if (ACleanPos<1) or (ACleanPos>MaxPos) then
6599 break;
6600 DirEndPos:=FindCommentEnd(Src,ACleanPos,Scanner.NestedComments)+1;
6601 p:=@Src[ACleanPos+2];
6602 if CompareIdentifiers(p,'warn')=0 then begin
6603 IDStartPos:=p+4;
6604 while IDStartPos^ in [' ',#9,#10,#13] do
6605 inc(IDStartPos);
6606 IDEndPos:=IDStartPos;
6607 while IDEndPos^ in ['0'..'9','A'..'Z','a'..'z','_'] do
6608 inc(IDEndPos);
6609 if CompareText(PChar(Pointer(WarnID)),length(WarnID),
6610 IDStartPos,IDEndPos-IDStartPos,false)=0
6611 then begin
6612 // warn directive found
6613 p:=IDEndPos;
6614 while p^ in [' ',#9,#10,#13] do
6615 inc(p);
6616 ParamPos:=p;
6617 while p^ in ['+','-','a'..'z','A'..'Z'] do
6618 inc(p);
6619 if not SourceChangeCache.Replace(gtSpace,gtNone,
6620 ParamPos-PChar(Src)+1,p-PChar(Src)+1,DirectiveFlagValue[TurnOn])
6621 then
6622 exit;
6623 Result:=SourceChangeCache.Apply;
6624 exit;
6625 end;
6626 end else if (CompareIdentifiers(p,'i')=0) or (CompareIdentifiers(p,'include')=0)
6627 then begin
6628 // insert before include file
6629 if MaxPos>ACleanPos then MaxPos:=ACleanPos;
6630 break;
6631 end;
6632 ACleanPos:=DirEndPos;
6633 until ACleanPos>MaxPos;
6634
6635 // there was no such directive yet -> find nice insert pos
6636 InsertStartPos:=FindLineEndOrCodeInFrontOfPosition(MaxPos,true,true);
6637 NewCode:='{$WARN '+WarnID+' '+DirectiveFlagValue[TurnOn]+Comment+'}';
6638 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,
6639 InsertStartPos,InsertStartPos,NewCode)
6640 then
6641 exit;
6642 Result:=SourceChangeCache.Apply;
6643 end;
6644
TStandardCodeTool.FixIncludeFilenamesnull6645 function TStandardCodeTool.FixIncludeFilenames(Code: TCodeBuffer;
6646 SourceChangeCache: TSourceChangeCache;
6647 out FoundIncludeFiles: TStrings;
6648 var MissingIncludeFilesCodeXYPos: TFPList): boolean;
6649 var
6650 ASource: String;
6651
6652 {procedure WriteMissingIncludeFilesCodeXYPos;
6653 var
6654 CodePos: PCodeXYPosition;
6655 i: Integer;
6656 begin
6657 if MissingIncludeFilesCodeXYPos<>nil then begin
6658 for i:=0 to MissingIncludeFilesCodeXYPos.Count-1 do begin
6659 CodePos:=PCodeXYPosition(MissingIncludeFilesCodeXYPos[i]);
6660 DebugLn('TStandardCodeTool.FixMissingUnits ',dbgs(CodePos));
6661 DebugLn('TStandardCodeTool.FixMissingUnits ',CodePos^.Code.Filename);
6662 debugln(CodePos^.Code.Filename
6663 +'('+IntToStr(CodePos^.y)+','+IntToStr(CodePos^.x)+')'
6664 +' missing include file');
6665 end;
6666 end;
6667 end;}
6668
6669 procedure Add(FilenameSrcPos: integer; const AFilename: string; Found: boolean);
6670 var
6671 NewFilename: String;
6672 p: PCodeXYPosition;
6673 begin
6674 if Found then begin
6675 if FoundIncludeFiles=nil then
6676 FoundIncludeFiles:=TStringList.Create;
6677 NewFilename:=TrimFilename(AFilename);
6678 if FoundIncludeFiles.IndexOf(NewFilename)<0 then
6679 FoundIncludeFiles.Add(NewFilename);
6680 end else begin
6681 if MissingIncludeFilesCodeXYPos=nil then
6682 MissingIncludeFilesCodeXYPos:=TFPList.Create;
6683 New(p);
6684 p^.Code:=Code;
6685 Code.AbsoluteToLineCol(FilenameSrcPos,p^.y,p^.x);
6686 MissingIncludeFilesCodeXYPos.Add(p);
6687 ///DebugLn('TStandardCodeTool.FixIncludeFilenames.Add "',p^.Code.Filename,'" ',dbgs(p),' X=',dbgs(p^.X),' Y=',dbgs(p^.Y));
6688 //WriteMissingIncludeFilesCodeXYPos;
6689 end;
6690 end;
6691
SearchIncludeFilenamenull6692 function SearchIncludeFilename(FilenameSrcPos: integer; const AFilename: string): string;
6693 var
6694 AFilePath: String;
6695 BaseDir: String;
6696 CurFilename: String;
6697 IncludePath: String;
6698 PathDivider: String;
6699 ACodeBuf: TCodeBuffer;
6700 begin
6701 Result:=TrimFilename(AFilename);
6702 if FilenameIsAbsolute(Result) then begin
6703 Result:=DirectoryCache.Pool.FindDiskFilename(Result,true);
6704 Add(FilenameSrcPos,Result,FileExistsCached(Result));
6705 //DebugLn('SearchIncludeFilename AbsoluteFilename="',Result,'"');
6706 end else begin
6707 BaseDir:=ExtractFilePath(MainFilename);
6708 //DebugLn('SearchIncludeFilename BaseDir="',BaseDir,'"');
6709 if FilenameIsAbsolute(BaseDir) then begin
6710 // unit has normal path -> not virtual
6711 AFilePath:=ExtractFilePath(Result);
6712 if AFilePath<>'' then begin
6713 // search relative to unit
6714 //debugln(['SearchIncludeFilename BaseDir+Result=',BaseDir+Result]);
6715 CurFilename:=DirectoryCache.Pool.FindDiskFilename(BaseDir+Result,true);
6716 //debugln(['SearchIncludeFilename DiskFilename=',CurFilename]);
6717 Result:=CreateRelativePath(CurFilename,BaseDir);
6718 //debugln(['SearchIncludeFilename RelativeDiskFilename=',Result]);
6719 if FileExistsCached(CurFilename) then
6720 Add(FilenameSrcPos,CurFilename,true)
6721 else
6722 Add(FilenameSrcPos,Result,false);
6723 //DebugLn('SearchIncludeFilename relative filename="',CurFilename,'"');
6724 end else begin
6725 // search in path
6726 IncludePath:='';
6727 PathDivider:=':;';
6728 if (Scanner.Values<>nil) then begin
6729 IncludePath:=Scanner.Values.Variables[ExternalMacroStart+'INCPATH'];
6730 if Scanner.Values.IsDefined('DELPHI') then
6731 PathDivider:=':'
6732 end;
6733 CurFilename:=SearchFileInPath(Result,BaseDir,IncludePath,PathDivider, ctsfcAllCase);
6734 if CurFilename<>'' then begin
6735 // found
6736 Result:=CreateRelativePath(CurFilename,BaseDir);
6737 Add(FilenameSrcPos,CurFilename,true);
6738 end else begin
6739 // not found
6740 Add(FilenameSrcPos,Result,false);
6741 end;
6742 //DebugLn('SearchIncludeFilename search in include path="',IncludePath,'" Result="',Result,'"');
6743 end;
6744 end else begin
6745 // unit has no path -> virtual unit -> search in virtual files
6746 ACodeBuf:=TCodeBuffer(Scanner.LoadSourceCaseLoUp(Result));
6747 if ACodeBuf<>nil then begin
6748 Result:=ACodeBuf.Filename;
6749 Add(FilenameSrcPos,Result,true);
6750 end else begin
6751 Add(FilenameSrcPos,Result,false);
6752 end;
6753 end;
6754 end;
6755 end;
6756
6757 procedure FixFilename(StartPos, EndPos: integer);
6758 var
6759 OldFilename: String;
6760 AFilename: String;
6761 begin
6762 OldFilename:=GetForcedPathDelims(copy(ASource,StartPos,EndPos-StartPos));
6763 //DebugLn('FixFilename ',dbgs(StartPos),' ',dbgs(EndPos),' ',OldFilename);
6764 AFilename:=OldFilename;
6765 if ExtractFileExt(AFilename)='' then begin
6766 // add default extension
6767 if (Scanner.CompilerMode=cmDELPHI) then
6768 AFilename:=AFilename+'.pas'
6769 else
6770 AFilename:=AFilename+'.pp';
6771 end;
6772 AFilename:=SearchIncludeFilename(StartPos,AFilename);
6773 if OldFilename<>AFilename then begin
6774 DebugLn('TStandardCodeTool.FixIncludeFilenames.FixFilename replacing in '
6775 +Code.Filename+' include directive "',OldFilename,'" with "',AFilename,'"');
6776 SourceChangeCache.ReplaceEx(gtNone,gtNone,0,0,Code,StartPos,EndPos,AFilename);
6777 end;
6778 end;
6779
6780 var
6781 p: Integer;
6782 NestedComments: Boolean;
6783 FilenameStartPos, FileNameEndPos, CommentStartPos, CommentEndPos: integer;
6784 begin
6785 Result:=false;
6786 FoundIncludeFiles:=nil;
6787 if (Scanner=nil) or (Scanner.MainCode=nil) then exit;
6788 ASource:=Code.Source;
6789 Scanner.Scan(lsrInit,false);
6790 SourceChangeCache.MainScanner:=Scanner;
6791
6792 Result:=true;
6793 NestedComments:=Scanner.NestedComments;
6794 p:=1;
6795 repeat
6796 p:=BasicCodeTools.FindNextIncludeDirective(ASource,p,NestedComments,
6797 FilenameStartPos, FileNameEndPos, CommentStartPos, CommentEndPos);
6798 if (p<1) or (p>length(ASource)) then break;
6799 if (CommentStartPos=0) and (CommentEndPos=0) then ;
6800 FixFilename(FilenameStartPos,FilenameEndPos);
6801 p:=FindCommentEnd(ASource,p,NestedComments);
6802 //DebugLn('TStandardCodeTool.FixIncludeFilenames ',dbgs(p));
6803 until false;
6804 //WriteMissingIncludeFilesCodeXYPos;
6805
6806 Result:=SourceChangeCache.Apply;
6807 end;
6808
ReadTilGuessedUnclosedBlocknull6809 function TStandardCodeTool.ReadTilGuessedUnclosedBlock(
6810 MinCleanPos: integer; ReadOnlyOneBlock: boolean): boolean;
6811 // returns true if unclosed block found
6812 var BlockType, CurBlockWord: TBlockKeyword;
6813 BlockStart: integer;
6814 begin
6815 Result:=false;
6816 BlockType:=bkwNone;
6817 BlockStart:=-1;
6818 // read til this block is closed
6819 while (CurPos.StartPos<=SrcLen) do begin
6820 if BlockKeywordFuncList.DoItCaseInsensitive(Src,
6821 CurPos.StartPos,CurPos.EndPos-CurPos.StartPos) then
6822 begin
6823 for CurBlockWord:=Low(TBlockKeyword) to High(TBlockKeyword) do
6824 if UpAtomIs(BlockKeywords[CurBlockWord]) then
6825 break;
6826 if (CurBlockWord=bkwInterface) and (not LastAtomIs(0,'=')) then
6827 CurBlockWord:=bkwNone;
6828
6829 if (CurBlockWord=bkwEnd) then begin
6830 ReadNextAtom;
6831 if AtomIsChar('.') then begin
6832 // source end found
6833 if BlockType in [bkwBegin,bkwNone] then begin
6834 MoveCursorToCleanPos(SrcLen+1);
6835 exit;
6836 end else begin
6837 MoveCursorToCleanPos(BlockStart);
6838 Result:=true;
6839 exit;
6840 end;
6841 end else
6842 UndoReadNextAtom;
6843 end;
6844
6845 if BlockType=bkwNone then begin
6846 case CurBlockWord of
6847
6848 bkwBegin, bkwAsm, bkwRepeat, bkwCase, bkwTry, bkwRecord:
6849 begin
6850 BlockType:=CurBlockWord;
6851 BlockStart:=CurPos.StartPos;
6852 end;
6853
6854 bkwClass, bkwObject, bkwInterface, bkwDispInterface:
6855 begin
6856 ReadNextAtom;
6857 if AtomIsChar(';') then begin
6858 // forward class
6859 end else if ((CurBlockWord=bkwClass) and UpAtomIs('OF')) then begin
6860 // 'class of'
6861 end else if ((CurBlockWord=bkwClass)
6862 and (UpAtomIs('FUNCTION') or UpAtomIs('PROCEDURE'))) then begin
6863 // 'class procedure'
6864 end else if ((CurBlockWord=bkwObject) and LastUpAtomIs(0,'OF')) then
6865 begin
6866 // or 'of object'
6867 end else begin
6868 BlockType:=CurBlockWord;
6869 BlockStart:=LastAtoms.GetPriorAtom.StartPos;
6870 // read ancestor list class(...)
6871 if CurPos.Flag=cafRoundBracketOpen then begin
6872 repeat
6873 ReadNextAtom;
6874 if AtomIsIdentifier then begin
6875 ReadNextAtom;
6876 if CurPos.Flag=cafPoint then begin
6877 ReadNextAtom;
6878 AtomIsIdentifierE;
6879 end;
6880 end;
6881 if CurPos.Flag=cafRoundBracketClose then break;
6882 if CurPos.Flag<>cafComma then begin
6883 exit(false);
6884 end;
6885 until false;
6886 ReadNextAtom;
6887 end;
6888 // a semicolon directly behind the ancestor list ends the class
6889 if (CurPos.Flag in [cafEnd,cafSemicolon]) then begin
6890 // class ends
6891 BlockType:=bkwNone;
6892 end else begin
6893 // class continues
6894 UndoReadNextAtom;
6895 end;
6896 end;
6897 end;
6898
6899 bkwEnd, bkwUntil:
6900 begin
6901 // close block keywords found, but no block was opened
6902 // -> unclosed block found
6903 Result:=true;
6904 exit;
6905 end;
6906
6907 end;
6908 end
6909 else
6910 if ((BlockType in [bkwBegin, bkwAsm, bkwCase, bkwRecord, bkwClass,
6911 bkwObject, bkwFinally, bkwExcept, bkwInterface, bkwDispInterface])
6912 and (CurBlockWord=bkwEnd))
6913 or ((BlockType=bkwRepeat) and (CurBlockWord=bkwUntil)) then begin
6914 // block end found
6915 if (MinCleanPos<=CurPos.StartPos)
6916 and (Beautifier.GetLineIndent(Src,CurPos.StartPos)<>Beautifier.GetLineIndent(Src,BlockStart))
6917 then begin
6918 // different indent -> unclosed block found
6919 if Beautifier.GetLineIndent(Src,BlockStart)>Beautifier.GetLineIndent(Src,CurPos.StartPos)
6920 then begin
6921 // the current block is more indented than the next block
6922 // -> probably the current block misses a block end
6923 MoveCursorToCleanPos(BlockStart);
6924 end;
6925 Result:=true;
6926 exit;
6927 end;
6928 // end block
6929 if (BlockType=bkwRecord) and (CurBlockWord=bkwCase) then begin
6930 // the 'end' keyword is the end for the case block and the record block
6931 UndoReadNextAtom;
6932 end;
6933 BlockType:=bkwNone;
6934 if ReadOnlyOneBlock then break;
6935 end
6936 else
6937 if (BlockType=bkwTry) and (CurBlockWord in [bkwFinally,bkwExcept]) then
6938 begin
6939 // try..finally, try..except found
6940 if (MinCleanPos<=CurPos.StartPos)
6941 and (Beautifier.GetLineIndent(Src,CurPos.StartPos)<>Beautifier.GetLineIndent(Src,BlockStart))
6942 then begin
6943 // different indent -> unclosed block found
6944 // probably a block start is missing, so the error position is
6945 // here at block end
6946 Result:=true;
6947 exit;
6948 end;
6949 // change blocktype
6950 BlockType:=CurBlockWord;
6951 BlockStart:=CurPos.StartPos;
6952 end
6953 else
6954 if ((BlockType in [bkwBegin,bkwRepeat,bkwTry,bkwFinally,bkwExcept,
6955 bkwCase])
6956 and (CurBlockWord in [bkwBegin,bkwRepeat,bkwTry,bkwCase,bkwAsm]))
6957 or ((BlockType in [bkwClass,bkwInterface,bkwDispInterface,bkwObject,
6958 bkwRecord])
6959 and (CurBlockWord in [bkwRecord])) then
6960 begin
6961 // sub blockstart found -> read recursively
6962 Result:=ReadTilGuessedUnclosedBlock(MinCleanPos,true);
6963 if Result then exit;
6964 end
6965 else
6966 if (BlockType=bkwRecord) and (CurBlockWord=bkwCase) then begin
6967 // variant record
6968 end
6969 else
6970 if (BlockType=bkwClass) and (CurBlockWord=bkwClass) then begin
6971 // class method
6972 end
6973 else
6974 begin
6975 // unexpected keyword found
6976 if Beautifier.GetLineIndent(Src,BlockStart)>=Beautifier.GetLineIndent(Src,CurPos.StartPos)
6977 then begin
6978 // the current block is more or equal indented than the next block
6979 // -> probably the current block misses a block end
6980 MoveCursorToCleanPos(BlockStart);
6981 end;
6982 Result:=true;
6983 exit;
6984 end;
6985 end;
6986 ReadNextAtom;
6987 end;
6988 end;
6989
RemoveApplicationScaledStatementnull6990 function TStandardCodeTool.RemoveApplicationScaledStatement(
6991 SourceChangeCache: TSourceChangeCache): boolean;
6992 begin
6993 Result := RemoveApplicationStatement('SCALED', SourceChangeCache);
6994 end;
6995
TStandardCodeTool.RemoveApplicationStatementnull6996 function TStandardCodeTool.RemoveApplicationStatement(const APropertyUpCase: string;
6997 SourceChangeCache: TSourceChangeCache): boolean;
6998 var
6999 StartPos, ConstStartPos, EndPos: integer;
7000 OldExists: Boolean;
7001 FromPos: Integer;
7002 ToPos: Integer;
7003 begin
7004 Result:=false;
7005 // search old Application.XYZ:= statement
7006 OldExists:=FindApplicationStatement(APropertyUpCase,StartPos,ConstStartPos,EndPos);
7007 if not OldExists then
7008 exit(true);
7009 // -> delete whole line
7010 FromPos:=FindLineEndOrCodeInFrontOfPosition(StartPos);
7011 ToPos:=FindLineEndOrCodeAfterPosition(EndPos);
7012 SourceChangeCache.MainScanner:=Scanner;
7013 if not SourceChangeCache.Replace(gtNone,gtNone,FromPos,ToPos,'') then exit;
7014 if not SourceChangeCache.Apply then exit;
7015 Result:=true;
7016 end;
7017
TStandardCodeTool.ReadForwardTilAnyBracketClosenull7018 function TStandardCodeTool.ReadForwardTilAnyBracketClose: boolean;
readsnull7019 // this function reads any bracket
7020 // (the ReadTilBracketClose function reads only brackets in code, not comments)
7021 var OpenBracket: char;
7022 begin
7023 Result:=false;
7024 OpenBracket:=Src[CurPos.StartPos];
7025 if OpenBracket='{' then begin
7026 // read til end of comment
7027 MoveCursorToCleanPos(FindCommentEnd(Src,CurPos.StartPos,Scanner.NestedComments));
7028 Result:=CurPos.StartPos<=SrcLen;
7029 end else if OpenBracket='(' then begin
7030 if (CurPos.StartPos<SrcLen) and (Src[CurPos.StartPos+1]='*') then begin
7031 // read til end of comment
7032 MoveCursorToCleanPos(FindCommentEnd(Src,CurPos.StartPos,Scanner.NestedComments));
7033 Result:=CurPos.StartPos<=SrcLen;
7034 end else begin
7035 // round bracket operator
7036 Result:=ReadTilBracketClose(false);
7037 end;
7038 end else if OpenBracket='[' then begin
7039 Result:=ReadTilBracketClose(false);
7040 end;
7041 end;
7042
TStandardCodeTool.ReadBackwardTilAnyBracketClosenull7043 function TStandardCodeTool.ReadBackwardTilAnyBracketClose: boolean;
readsnull7044 // this function reads any bracket
7045 // (the ReadBackTilBracketClose function reads only brackets in code,
7046 // not comments)
7047 var OpenBracket: char;
7048 CommentLvl: integer;
7049 begin
7050 Result:=false;
7051 OpenBracket:=Src[CurPos.StartPos];
7052 if OpenBracket='}' then begin
7053 // read backwards til end of comment
7054 dec(CurPos.StartPos);
7055 if (CurPos.StartPos>0) and (Src[CurPos.StartPos]=#3) then begin
7056 // codetools skip comment
7057 dec(CurPos.StartPos);
7058 while (CurPos.StartPos>=1) do begin
7059 if (Src[CurPos.StartPos]=#3) and (CurPos.StartPos>1)
7060 and (Src[CurPos.StartPos-1]='}') then begin
7061 dec(CurPos.StartPos,2);
7062 break;
7063 end;
7064 dec(CurPos.StartPos);
7065 end;
7066 end else begin
7067 // pascal comment
7068 CommentLvl:=1;
7069 while (CurPos.StartPos>=1) and (CommentLvl>0) do begin
7070 case Src[CurPos.StartPos] of
7071 '}': if Scanner.NestedComments then inc(CommentLvl);
7072 '{':
7073 if CommentLvl=1 then begin
7074 Result:=true;
7075 break;
7076 end else
7077 dec(CommentLvl);
7078 end;
7079 dec(CurPos.StartPos);
7080 end;
7081 end;
7082 end else if OpenBracket=')' then begin
7083 if (CurPos.StartPos>1) and (Src[CurPos.StartPos-1]='*') then begin
7084 // read til end of comment
7085 dec(CurPos.StartPos,3);
7086 while true do begin
7087 if (CurPos.StartPos>=1)
7088 and ((Src[CurPos.StartPos+1]='*') and (Src[CurPos.StartPos]='(')) then
7089 begin
7090 Result:=true;
7091 exit;
7092 end;
7093 dec(CurPos.StartPos);
7094 end;
7095 end else begin
7096 Result:=ReadBackTilBracketOpen(false);
7097 end;
7098 end else if OpenBracket=']' then begin
7099 Result:=ReadBackTilBracketOpen(false);
7100 end;
7101 end;
7102
Explorenull7103 function TStandardCodeTool.Explore(WithStatements: boolean;
7104 Range: TLinkScannerRange): boolean;
7105 var
7106 Node: TCodeTreeNode;
7107 begin
7108 Result:=true;
7109 BuildTree(Range);
7110 Node:=Tree.Root;
7111 while Node<>nil do begin
7112 case Node.Desc of
7113 ctnProcedure,ctnProcedureHead:
7114 BuildSubTreeForProcHead(Node);
7115 ctnBeginBlock:
7116 if WithStatements then
7117 BuildSubTreeForBeginBlock(Node);
7118 ctnImplementation:
7119 if ord(Range)<ord(lsrImplementationStart) then exit;
7120 end;
7121 Node:=Node.Next;
7122 end;
7123 end;
7124
Explorenull7125 function TStandardCodeTool.Explore(WithStatements: boolean;
7126 OnlyInterface: boolean): boolean;
7127 begin
7128 if OnlyInterface then
7129 Result:=Explore(WithStatements,lsrImplementationStart)
7130 else
7131 Result:=Explore(WithStatements,lsrEnd);
7132 end;
7133
7134 finalization
7135 FreeAndNil(BlockKeywordFuncList);
7136
7137 end.
7138
7139
7140