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 TExtractProcTool enhances TCodeCompletionCodeTool.
25 TExtractProcTool provides functions to extract statements from procedures
26 and to move them to new procedure, sub procedures or methods. Parameter
27 list is auto created and local variables are automatically created and/or
28 removed.
29 Note: Extracting a procedure from a method needs manual fixing of used
30 method variables.
31
32 ToDo:
33 - check if selection bounds on statement bounds
34 - with statements
35
36 Explode With Blocks todos:
37 - check if selection bounds on statement bounds
38 - keep Begin..End in case
39 - support Expressions
40 - with Canvas do with Self do (e.g. shape.inc)
41 - dialog in cody to replace a long expression with a short local variable
42 - bug: shape.inc : with Self do
43 }
44 unit ExtractProcTool;
45
46 {$mode objfpc}{$H+}
47
48 { $define CTDEBUG}
49 {off $Define VerboseAddWithBlock}
50
51 interface
52
53 uses
54 Classes, SysUtils, math, Laz_AVL_Tree,
55 // Codetools
56 FileProcs, CodeToolsStrConsts, CodeTree, CodeAtom,
57 CodeCache, CustomCodeTool, PascalReaderTool,
58 PascalParserTool, CodeCompletionTool, KeywordFuncLists, BasicCodeTools,
59 LinkScanner, SourceChanger, FindDeclarationTool;
60
61 type
62 TExtractedProcVariableType = (
63 epvtParameter,
64 epvtLocalVar
65 //epvtExternVar // variable is defined outside (e.g. a global variable or a class member)
66 );
67
68 TExtractedProcVariable = class
69 public
70 Node: TCodeTreeNode;
71 Tool: TFindDeclarationTool;
72 VarType: TExtractedProcVariableType;
73 ReadInSelection: boolean;
74 WriteInSelection: boolean;
75 UsedInNonSelection: boolean;
76 ReadAfterSelection: boolean;
77 ReadAfterSelectionValid: boolean;
78 RemovedFromOldProc: boolean;
UsedInSelectionnull79 function UsedInSelection: boolean;
80 end;
81
82 { TExtractCodeTool }
83
84 TExtractProcType = (
85 eptProcedure,
86 eptProcedureWithInterface,
87 eptSubProcedure,
88 eptSubProcedureSameLvl,
89 eptPrivateMethod,
90 eptProtectedMethod,
91 eptPublicMethod,
92 eptPublishedMethod
93 );
94
95 TExtractCodeTool = class(TCodeCompletionCodeTool)
96 protected
ScanNodesForVariablesnull97 function ScanNodesForVariables(const StartPos, EndPos: TCodeXYPosition;
98 out BlockStartPos, BlockEndPos: integer; // the selection
99 out BlockNode: TCodeTreeNode;
100 VarTree: TAVLTree; // tree of TExtractedProcVariable
101 IgnoreIdentifiers: TAVLTree; // tree of PCodeXYPosition
102 MissingIdentifiers: TAVLTree // tree of PCodeXYPosition
103 ): boolean;
CheckIfRangeOnSameLevelnull104 function CheckIfRangeOnSameLevel(const StartPos, EndPos: TCodeXYPosition;
105 out CleanStartPos, CleanEndPos: integer; out StartNode: TCodeTreeNode): boolean;
InitExtractProcnull106 function InitExtractProc(const StartPos, EndPos: TCodeXYPosition;
107 out MethodPossible, SubProcPossible, SubProcSameLvlPossible: boolean): boolean;
108 public
CheckExtractProcnull109 function CheckExtractProc(const StartPos, EndPos: TCodeXYPosition;
110 out MethodPossible, SubProcPossible, SubProcSameLvlPossible: boolean;
111 out MissingIdentifiers: TAVLTree; // tree of PCodeXYPosition
112 VarTree: TAVLTree = nil // tree of TExtractedProcVariable
113 ): boolean;
ExtractProcnull114 function ExtractProc(const StartPos, EndPos: TCodeXYPosition;
115 ProcType: TExtractProcType; const ProcName: string;
116 IgnoreIdentifiers: TAVLTree; // tree of PCodeXYPosition
117 out NewPos: TCodeXYPosition; out NewTopLine, BlockTopLine, BlockBottomLine: integer;
118 SourceChangeCache: TSourceChangeCache;
119 FunctionResultVariableStartPos: integer = 0): boolean;
120
RemoveWithBlocknull121 function RemoveWithBlock(const CursorPos: TCodeXYPosition;
122 SourceChangeCache: TSourceChangeCache): boolean;
AddWithBlocknull123 function AddWithBlock(const StartPos, EndPos: TCodeXYPosition;
124 const WithExpr: string; // if empty: collect Candidates
125 Candidates: TStrings; SourceChangeCache: TSourceChangeCache): boolean;
126
127 procedure CalcMemSize(Stats: TCTMemStats); override;
128 end;
129
130 const
131 ExtractProcTypeNames: array[TExtractProcType] of string = (
132 'Procedure',
133 'ProcedureWithInterface',
134 'SubProcedure',
135 'SubProcedureSameLvl',
136 'PrivateMethod',
137 'ProtectedMethod',
138 'PublicMethod',
139 'PublishedMethod'
140 );
141
CreateExtractProcVariableTreenull142 function CreateExtractProcVariableTree: TAVLTree;
143 procedure ClearExtractProcVariableTree(VarTree: TAVLTree; FreeTree: boolean);
144
145 implementation
146
CompareExtractedProcVariablesnull147 function CompareExtractedProcVariables(V1, V2: TExtractedProcVariable): integer;
148 var
149 cmp: Integer;
150 begin
151 cmp:=V2.Node.StartPos-V1.Node.StartPos;
152 if cmp<0 then
153 Result:=-1
154 else if cmp>0 then
155 Result:=1
156 else
157 Result:=0;
158 end;
159
CompareNodeWithExtractedProcVariablenull160 function CompareNodeWithExtractedProcVariable(Node: TCodeTreeNode;
161 V: TExtractedProcVariable): integer;
162 var
163 cmp: Integer;
164 begin
165 cmp:=V.Node.StartPos-Node.StartPos;
166 if cmp<0 then
167 Result:=-1
168 else if cmp>0 then
169 Result:=1
170 else
171 Result:=0;
172 end;
173
CreateExtractProcVariableTreenull174 function CreateExtractProcVariableTree: TAVLTree;
175 begin
176 Result:=TAVLTree.Create(TListSortCompare(@CompareExtractedProcVariables));
177 end;
178
179 procedure ClearExtractProcVariableTree(VarTree: TAVLTree; FreeTree: boolean);
180 begin
181 if VarTree=nil then exit;
182 VarTree.FreeAndClear;
183 if FreeTree then
184 VarTree.Free;
185 end;
186
187 { TExtractedProcVariable }
188
TExtractedProcVariable.UsedInSelectionnull189 function TExtractedProcVariable.UsedInSelection: boolean;
190 begin
191 Result:=ReadInSelection or WriteInSelection;
192 end;
193
194 { TExtractCodeTool }
195
TExtractCodeTool.InitExtractProcnull196 function TExtractCodeTool.InitExtractProc(const StartPos,
197 EndPos: TCodeXYPosition; out MethodPossible, SubProcPossible,
198 SubProcSameLvlPossible: boolean): boolean;
199 var
200 CleanStartPos, CleanEndPos: integer;
201 StartNode: TCodeTreeNode;
202 ANode: TCodeTreeNode;
203 ProcLvl: Integer;
204 begin
205 Result:=false;
206 MethodPossible:=false;
207 SubProcPossible:=false;
208 SubProcSameLvlPossible:=false;
209 {$IFDEF CTDebug}
210 DebugLn('TExtractProcTool.InitExtractProc syntax and cursor check ..');
211 {$ENDIF}
212 Result:=CheckIfRangeOnSameLevel(StartPos,EndPos,CleanStartPos,CleanEndPos,
213 StartNode);
214 // check if start not in a statement
215 // ToDo
216 // check if end not in a statement
217 // ToDo
218 {$IFDEF CTDebug}
219 DebugLn('TExtractProcTool.InitExtractProc Method check ..');
220 {$ENDIF}
221 // check if in a method body
222 ANode:=StartNode;
223 ProcLvl:=0;
224 while ANode<>nil do begin
225 if (ANode.Desc=ctnProcedure) then begin
226 SubProcPossible:=true;
227 inc(ProcLvl);
228 if NodeIsInAMethod(ANode) then begin
229 MethodPossible:=true;
230 end;
231 end;
232 ANode:=ANode.Parent;
233 end;
234 SubProcSameLvlPossible:=(ProcLvl>1);
235 {$IFDEF CTDebug}
236 DebugLn('TExtractProcTool.InitExtractProc END');
237 {$ENDIF}
238 Result:=true;
239 end;
240
CheckExtractProcnull241 function TExtractCodeTool.CheckExtractProc(const StartPos,
242 EndPos: TCodeXYPosition; out MethodPossible, SubProcPossible,
243 SubProcSameLvlPossible: boolean; out MissingIdentifiers: TAVLTree;
244 VarTree: TAVLTree): boolean;
245 var
246 BlockStartPos: integer;
247 BlockEndPos: integer;
248 ProcNode: TCodeTreeNode;
249 begin
250 Result:=false;
251 MissingIdentifiers:=nil;
252 ActivateGlobalWriteLock;
253 try
254 if not InitExtractProc(StartPos,EndPos,MethodPossible,
255 SubProcPossible,SubProcSameLvlPossible)
256 then exit;
257 MissingIdentifiers:=CreateTreeOfPCodeXYPosition;
258 if not ScanNodesForVariables(StartPos,EndPos,BlockStartPos,BlockEndPos,
259 ProcNode,VarTree,nil,MissingIdentifiers) then exit;
260 finally
261 DeactivateGlobalWriteLock;
262 end;
263 Result:=true;
264 end;
265
TExtractCodeTool.ExtractProcnull266 function TExtractCodeTool.ExtractProc(const StartPos, EndPos: TCodeXYPosition;
267 ProcType: TExtractProcType; const ProcName: string;
268 IgnoreIdentifiers: TAVLTree; out NewPos: TCodeXYPosition; out NewTopLine,
269 BlockTopLine, BlockBottomLine: integer;
270 SourceChangeCache: TSourceChangeCache; FunctionResultVariableStartPos: integer
271 ): boolean;
272 const
273 ShortProcFormat = [phpWithoutClassKeyword];
274 var
275 BlockStartPos, BlockEndPos: integer; // the selection
276 MainBlockNode: TCodeTreeNode; // the main proc node of the selection, or main begin block of program
277 VarTree: TAVLTree;
278 ResultNode: TCodeTreeNode;
279 Beauty: TBeautifyCodeOptions;
280
FindFunctionResultNodenull281 function FindFunctionResultNode: boolean;
282 var
283 AVLNode: TAVLTreeNode;
284 ProcVar: TExtractedProcVariable;
285 begin
286 Result:=false;
287 ResultNode:=nil;
288 if FunctionResultVariableStartPos<1 then exit(true); // create a proc, not a function
AVLNodenull289 AVLNode:=VarTree.FindLowest;
290 while AVLNode<>nil do begin
291 ProcVar:=TExtractedProcVariable(AVLNode.Data);
292 if ProcVar.Node.StartPos=FunctionResultVariableStartPos then begin
293 ProcVar.UsedInNonSelection:=true;
294 ProcVar.ReadAfterSelection:=true;
295 Result:=true;
296 ResultNode:=ProcVar.Node;
297 exit;
298 end;
299 AVLNode:=VarTree.FindSuccessor(AVLNode);
300 end;
301 end;
302
ReplaceSelectionWithCallnull303 function ReplaceSelectionWithCall: boolean;
304 var
305 Indent: Integer;
306 CallCode: String;
307 ParamListCode: String;
308 AVLNode: TAVLTreeNode;
309 ProcVar: TExtractedProcVariable;
310 begin
311 Result:=false;
312 {$IFDEF CTDebug}
313 DebugLn('TExtractProcTool.ReplaceSelectionWithCall A');
314 {$ENDIF}
315 Indent:=Beauty.GetLineIndent(Src,BlockStartPos);
316 ParamListCode:='';
317 // gather all variables, that are used in the selection and in the rest of
318 // the old proc (in front or behind). These are the parameters for the new proc.
319 if (VarTree<>nil) and (ProcType<>eptSubProcedure) then begin
320 AVLNode:=VarTree.FindLowest;
321 while AVLNode<>nil do begin
322 ProcVar:=TExtractedProcVariable(AVLNode.Data);
323 {$IFDEF CTDebug}
324 DebugLn('TExtractProcTool.ReplaceSelectionWithCall B ',GetIdentifier(@Src[ProcVar.Node.StartPos]),
325 ' ReadInSelection=',dbgs(ProcVar.ReadInSelection),
326 ' WriteInSelection=',dbgs(ProcVar.WriteInSelection),
327 ' UsedInNonSelection=',dbgs(ProcVar.UsedInNonSelection),
328 ' ReadAfterSelection=',dbgs(ProcVar.ReadAfterSelection),
329 '');
330 {$ENDIF}
331 if (ProcVar.UsedInSelection and ProcVar.UsedInNonSelection)
332 and (ResultNode<>ProcVar.Node) then begin
333 // parameter
334 if ParamListCode<>'' then ParamListCode:=ParamListCode+',';
335 ParamListCode:=ParamListCode+GetIdentifier(@Src[ProcVar.Node.StartPos]);
336 end;
337 AVLNode:=VarTree.FindSuccessor(AVLNode);
338 end;
339 end;
340 if ParamListCode<>'' then
341 ParamListCode:='('+ParamListCode+')';
342 CallCode:=ProcName+ParamListCode+';';
343 if ResultNode<>nil then begin
344 CallCode:=GetIdentifier(@Src[ResultNode.StartPos])+':='+CallCode;
345 end;
346 CallCode:=Beauty.BeautifyStatement(CallCode,Indent);
347 {$IFDEF CTDebug}
348 DebugLn('TExtractProcTool.ReplaceSelectionWithCall C "',CallCode,'" Indent=',dbgs(Indent));
349 {$ENDIF}
350 SourceChangeCache.Replace(gtNewLine,gtNewLine,BlockStartPos,BlockEndPos,
351 CallCode);
352 Result:=true;
353 end;
354
DeleteLocalVariablenull355 function DeleteLocalVariable(ProcVar: TExtractedProcVariable): boolean;
356
VariableNodeShouldBeDeletednull357 function VariableNodeShouldBeDeleted(VarNode: TCodeTreeNode;
358 out CurProcVar: TExtractedProcVariable): boolean;
359 var
360 AVLNode: TAVLTreeNode;
361 begin
362 CurProcVar:=nil;
363 AVLNode:=VarTree.FindKey(VarNode,
364 TListSortCompare(@CompareNodeWithExtractedProcVariable));
365 if AVLNode=nil then begin
366 Result:=false;
367 end else begin
368 CurProcVar:=TExtractedProcVariable(AVLNode.Data);
369 Result:=(not CurProcVar.UsedInNonSelection)
370 and CurProcVar.UsedInSelection;
371 end;
372 end;
373
VarSectionIsEmptynull374 function VarSectionIsEmpty: boolean;
375 var
376 VarNode: TCodeTreeNode;
377 SectionNode: TCodeTreeNode;
378 CurProcVar: TExtractedProcVariable;
379 begin
380 Result:=false;
381 SectionNode:=ProcVar.Node;
382 if SectionNode.Desc=ctnVarDefinition then
383 SectionNode:=SectionNode.Parent;
384 if SectionNode.Desc<>ctnVarSection then exit;
385 VarNode:=SectionNode.FirstChild;
386 while VarNode<>nil do begin
387 CurProcVar:=nil;
388 if not VariableNodeShouldBeDeleted(VarNode,CurProcVar) then exit;
389 if not CurProcVar.RemovedFromOldProc then exit;
390 VarNode:=VarNode.NextBrother;
391 end;
392 Result:=true;
393 end;
394
395 var
396 VarNode: TCodeTreeNode;
397 FirstVarNode: TCodeTreeNode;
398 LastVarNode: TCodeTreeNode;
399 DeleteCompleteDefinition: Boolean;
400 DeleteStartPos: Integer;
401 DeleteEndPos: Integer;
402 CurProcVar: TExtractedProcVariable;
403 FrontGap: TGapTyp;
404 begin
405 Result:=false;
406 if not ProcVar.RemovedFromOldProc then begin
407 // check all variables of the definition (e.g. 'i,j,k: integer')
408 FirstVarNode:=ProcVar.Node;
409 while (FirstVarNode.PriorBrother<>nil)
410 and (FirstVarNode.PriorBrother.Desc=ctnVarDefinition)
411 and (FirstVarNode.PriorBrother.FirstChild=nil) do
412 FirstVarNode:=FirstVarNode.PriorBrother;
413 LastVarNode:=FirstVarNode;
414 while (LastVarNode.NextBrother<>nil)
415 and (LastVarNode.NextBrother.Desc=ctnVarDefinition)
416 and (LastVarNode.FirstChild=nil) do
417 LastVarNode:=LastVarNode.NextBrother;
418 VarNode:=FirstVarNode;
419 // delete variables
420 DeleteCompleteDefinition:=true;
421 DeleteStartPos:=0;
422 DeleteEndPos:=0;
423 repeat
424 if VariableNodeShouldBeDeleted(VarNode,CurProcVar) then begin
425 // delete variable name and comma
426 // if the whole definition is deleted, this is handled behind the
427 // loop. Examples:
428 // var i, X: integer; -> var i[, X]: integer;
429 // var i, X, j: integer; -> var i, [X, ]j: integer;
430 // var X, i: integer; -> var [X, ]i: integer;
431 if DeleteStartPos<1 then
432 DeleteStartPos:=VarNode.StartPos;
433 MoveCursorToNodeStart(VarNode);
434 ReadNextAtom;
435 AtomIsIdentifierE;
436 ReadNextAtom;
437 if CurPos.Flag=cafComma then begin
438 // there is a next variable in the same var definition
439 ReadNextAtom;
440 DeleteEndPos:=CurPos.StartPos;
441 end else if CurPos.Flag=cafColon then begin
442 // this is the last variable in the definition
443 DeleteEndPos:=CurPos.StartPos;
444 if (DeleteStartPos=VarNode.StartPos)
445 and (VarNode<>FirstVarNode) then begin
446 // there is a variable in front in the same definition, that is
447 // not deleted. Delete also the comma in front. Example:
448 // var i, X: integer; -> var i[, X]: integer;
449 MoveCursorToNodeStart(VarNode.PriorBrother);
450 ReadNextAtom; // prior identifier
451 ReadNextAtom; // comma
452 DeleteStartPos:=CurPos.StartPos;
453 end;
454 end;
455 // mark as removed
456 CurProcVar.RemovedFromOldProc:=true;
457 end else begin
458 // this variable is kept
459 DeleteCompleteDefinition:=false;
460 if DeleteStartPos>0 then begin
461 // delete variables in front
462 {$IFDEF CTDebug}
463 DebugLn('DeleteLocalVariable Delete last vars: "',copy(Src,DeleteStartPos,DeleteEndPos-DeleteStartPos),'"');
464 {$ENDIF}
465 if not SourceChangeCache.Replace(gtNone,gtNone,
466 DeleteStartPos,DeleteEndPos,'')
467 then
468 exit;
469 DeleteStartPos:=0;
470 DeleteEndPos:=0;
471 end;
472 end;
473 if VarNode=LastVarNode then break;
474 VarNode:=VarNode.NextBrother;
475 until VarNode=nil;
476 FrontGap:=gtNone;
477 if DeleteCompleteDefinition and (DeleteStartPos>0) then begin
478 // all variables of the definition should be deleted
479 // -> delete type declaration
480 DeleteEndPos:=FindLineEndOrCodeAfterPosition(LastVarNode.EndPos);
481 if VarSectionIsEmpty then begin
482 // all variables of the 'var' section are deleted
483 // -> delete var section
484 DeleteStartPos:=FirstVarNode.Parent.StartPos;
485 end else if FirstVarNode.PriorBrother=nil then begin
486 // keep a space between 'var' and the next identifier
487 FrontGap:=gtSpace;
488 end;
489 DeleteStartPos:=FindLineEndOrCodeInFrontOfPosition(DeleteStartPos,true);
490 end;
491 if DeleteStartPos>0 then begin
492 {$IFDEF CTDebug}
493 DebugLn('DeleteLocalVariable Delete Rest: "',copy(Src,DeleteStartPos,DeleteEndPos-DeleteStartPos),'"');
494 {$ENDIF}
495 if not SourceChangeCache.Replace(FrontGap,gtNone,
496 DeleteStartPos,DeleteEndPos,'')
497 then
498 exit;
499 end;
500 end;
501 Result:=true;
502 end;
503
DeleteMovedLocalVariablesnull504 function DeleteMovedLocalVariables: boolean;
505 var
506 AVLNode: TAVLTreeNode;
507 ProcVar: TExtractedProcVariable;
508 begin
509 Result:=false;
510 {$IFDEF CTDebug}
511 DebugLn('TExtractProcTool.DeleteMovedLocalVariables A');
512 {$ENDIF}
513 // gather all variables, that are used in the selection, but not in the
514 // rest of the old proc. These are local variables, that are moved to the
515 // new proc.
516 if (VarTree<>nil) then begin
517 AVLNode:=VarTree.FindLowest;
518 while AVLNode<>nil do begin
519 ProcVar:=TExtractedProcVariable(AVLNode.Data);
520 {$IFDEF CTDebug}
521 DebugLn('TExtractProcTool.DeleteMovedLocalVariables B ',GetIdentifier(@Src[ProcVar.Node.StartPos]),
522 ' ReadInSelection=',dbgs(ProcVar.ReadInSelection),
523 ' WriteInSelection=',dbgs(ProcVar.WriteInSelection),
524 ' UsedInNonSelection=',dbgs(ProcVar.UsedInNonSelection),
525 ' ReadAfterSelection=',dbgs(ProcVar.ReadAfterSelection),
526 '');
527 {$ENDIF}
528 if ProcVar.UsedInSelection and (not ProcVar.UsedInNonSelection) then
529 begin
530 if not DeleteLocalVariable(ProcVar) then exit;
531 end;
532 AVLNode:=VarTree.FindSuccessor(AVLNode);
533 end;
534 end;
535 {$IFDEF CTDebug}
536 DebugLn('DeleteMovedLocalVariables END ');
537 {$ENDIF}
538 Result:=true;
539 end;
540
CreateProcNamePartsnull541 function CreateProcNameParts(out ProcClassName: string;
542 out ProcClassNode: TCodeTreeNode): boolean;
543 begin
544 Result:=false;
545 ProcClassName:='';
546 ProcClassNode:=nil;
547 if ProcType in [eptPrivateMethod,eptProtectedMethod,eptPublicMethod,
548 eptPublishedMethod] then
549 begin
550 {$IFDEF CTDebug}
551 DebugLn('CreateProcNameParts A searching class name ..');
552 {$ENDIF}
553 if (MainBlockNode=nil) or (MainBlockNode.Desc<>ctnProcedure) then begin
554 debugln(['CreateProcNameParts not in a procedure']);
555 exit;
556 end;
557 ProcClassName:=ExtractClassNameOfProcNode(MainBlockNode);
558 if ProcClassName='' then begin
559 debugln(['CreateProcNameParts not in a method']);
560 exit;
561 end;
562 ProcClassNode:=FindClassNodeInUnit(ProcClassName,
563 true,false,false,true);
564 if ProcClassNode=nil then begin
565 debugln(['CreateProcNameParts class not found ',ProcClassName]);
566 exit;
567 end;
568 ProcClassName:=ExtractClassName(ProcClassNode,false);
569 end;
570 {$IFDEF CTDebug}
571 DebugLn('CreateProcNameParts END ProcClassName="',ProcClassName,'"');
572 {$ENDIF}
573 Result:=true;
574 end;
575
CreateProcParamListnull576 function CreateProcParamList(
577 out CompleteParamListCode, // including modifiers, brackets and result type
578 BaseParamListCode: string // without modifiers and result type
579 ): boolean;
580 var
581 AVLNode: TAVLTreeNode;
582 ProcVar: TExtractedProcVariable;
583 ParamName: String;
584 ParamTypeCode: String;
585 ParamSpecifier: String;
586 ResultType: String;
587 begin
588 Result:=false;
589 CompleteParamListCode:='';
590 BaseParamListCode:='';
591 // gather all variables, that are used in the selection and in the rest of
592 // the old proc. These are the parameters for the new proc.
593 if (VarTree<>nil) and (ProcType<>eptSubProcedure) then begin
594 AVLNode:=VarTree.FindLowest;
595 while AVLNode<>nil do begin
596 ProcVar:=TExtractedProcVariable(AVLNode.Data);
597 {$IFDEF CTDebug}
598 DebugLn('TExtractProcTool.CreateProcParamList B ',GetIdentifier(@Src[ProcVar.Node.StartPos]),
599 ' ReadInSelection=',dbgs(ProcVar.ReadInSelection),
600 ' WriteInSelection=',dbgs(ProcVar.WriteInSelection),
601 ' UsedInNonSelection=',dbgs(ProcVar.UsedInNonSelection),
602 ' ReadAfterSelection=',dbgs(ProcVar.ReadAfterSelection),
603 '');
604 {$ENDIF}
605 if ProcVar.UsedInSelection and ProcVar.UsedInNonSelection
606 and (ProcVar.Node<>ResultNode) then begin
607 // extract identifier and type
608 if CompleteParamListCode<>'' then
609 CompleteParamListCode:=CompleteParamListCode+';';
610 if BaseParamListCode<>'' then
611 BaseParamListCode:=BaseParamListCode+';';
612 ParamName:=GetIdentifier(@Src[ProcVar.Node.StartPos]);
613 ParamTypeCode:=ExtractDefinitionNodeType(ProcVar.Node);
614 {$IFDEF CTDebug}
615 DebugLn('TExtractProcTool.CreateProcParamList C ParamName="',ParamName,'" ParamType="',ParamTypeCode,'"');
616 {$ENDIF}
617 // ToDo: ParamSpecifier 'var ' and none
618 if ProcVar.WriteInSelection then
619 ParamSpecifier:=''
620 else
621 ParamSpecifier:='const ';
622 if ProcVar.ReadAfterSelection then
623 ParamSpecifier:='var ';
624 CompleteParamListCode:=CompleteParamListCode
625 +ParamSpecifier+ParamName+':'+ParamTypeCode;
626 BaseParamListCode:=BaseParamListCode+':'+ParamTypeCode;
627 end;
628 AVLNode:=VarTree.FindSuccessor(AVLNode);
629 end;
630 end;
631 if CompleteParamListCode<>'' then begin
632 CompleteParamListCode:='('+CompleteParamListCode+')';
633 BaseParamListCode:='('+BaseParamListCode+')';
634 end;
635 if ResultNode<>nil then begin
636 ResultType:=ExtractDefinitionNodeType(ResultNode);
637 CompleteParamListCode:=CompleteParamListCode+':'+ResultType;
638 end;
639 {$IFDEF CTDebug}
640 DebugLn('CreateProcParamList END CompleteParamListCode="',CompleteParamListCode,'"');
641 {$ENDIF}
642 Result:=true;
643 end;
644
CreateProcVarSectionnull645 function CreateProcVarSection(out VarSectionCode: string): boolean;
646 var
647 AVLNode: TAVLTreeNode;
648 ProcVar: TExtractedProcVariable;
649 VariableName: String;
650 VariableTypeCode: String;
651 VarTypeNode: TCodeTreeNode;
652 TypeDefEndPos: Integer;
653 begin
654 Result:=false;
655 VarSectionCode:='';
656 // gather all variables, that are used in the selection, but not in the
657 // rest of the old proc. These are the local variables of the new proc.
658 if (VarTree<>nil) then begin
659 AVLNode:=VarTree.FindLowest;
660 while AVLNode<>nil do begin
661 ProcVar:=TExtractedProcVariable(AVLNode.Data);
662 {$IFDEF CTDebug}
663 DebugLn('TExtractProcTool.CreateProcVarSection B ',GetIdentifier(@Src[ProcVar.Node.StartPos]),
664 ' ReadInSelection=',dbgs(ProcVar.ReadInSelection),
665 ' WriteInSelection=',dbgs(ProcVar.WriteInSelection),
666 ' UsedInNonSelection=',dbgs(ProcVar.UsedInNonSelection),
667 ' ReadAfterSelection=',dbgs(ProcVar.ReadAfterSelection),'');
668 {$ENDIF}
669 if ProcVar.UsedInSelection
670 and ((not ProcVar.UsedInNonSelection) or (ProcVar.Node=ResultNode)) then
671 begin
672 // extract identifier and type
673 if VarSectionCode='' then
674 VarSectionCode:='var'+Beauty.LineEnd;
675 VarSectionCode:=VarSectionCode+Beauty.GetIndentStr(Beauty.Indent);
676 VariableName:=GetIdentifier(@Src[ProcVar.Node.StartPos]);
677 VarTypeNode:=FindTypeNodeOfDefinition(ProcVar.Node);
678 {$IFDEF CTDebug}
679 DebugLn('TExtractProcTool.CreateProcVarSection VarTypeNode=',copy(Src,VarTypeNode.StartPos,VarTypeNode.EndPos-VarTypeNode.StartPos));
680 {$ENDIF}
681 TypeDefEndPos:=FindLineEndOrCodeAfterPosition(VarTypeNode.EndPos);
682 {$IFDEF CTDebug}
683 DebugLn('TExtractProcTool.CreateProcVarSection PlusComment=',copy(Src,VarTypeNode.StartPos,TypeDefEndPos-VarTypeNode.StartPos));
684 {$ENDIF}
685 VariableTypeCode:=copy(Src,VarTypeNode.StartPos,
686 TypeDefEndPos-VarTypeNode.StartPos);
687 {$IFDEF CTDebug}
688 DebugLn('TExtractProcTool.CreateProcVarSection C VariableName="',VariableName,'" VariableType="',VariableTypeCode,'"');
689 {$ENDIF}
690 VarSectionCode:=VarSectionCode+VariableName+':'+VariableTypeCode
691 +Beauty.LineEnd;
692 end;
693 AVLNode:=VarTree.FindSuccessor(AVLNode);
694 end;
695 end;
696 {$IFDEF CTDebug}
697 DebugLn('TExtractProcTool.CreateProcVarSection END VarSectionCode="',VarSectionCode,'"');
698 {$ENDIF}
699 VarSectionCode:=Beauty.BeautifyStatement(VarSectionCode,0);
700 Result:=true;
701 end;
702
CreateProcBeginEndBlocknull703 function CreateProcBeginEndBlock(out BeginEndCode: string): boolean;
704 var
705 DirtyStartPos, DirtyEndPos: integer;
706 le, s: String;
707 Indent: Integer;
708 DirtySelection: String;
709 begin
710 Result:=false;
711 BeginEndCode:='';
712 le:=Beauty.LineEnd;
713 // extract dirty source, so that compiler directives are moved too
714 StartPos.Code.LineColToPosition(StartPos.Y,StartPos.X,DirtyStartPos);
715 StartPos.Code.LineColToPosition(EndPos.Y,EndPos.X,DirtyEndPos);
716 DirtySelection:=copy(StartPos.Code.Source,
717 DirtyStartPos,DirtyEndPos-DirtyStartPos);
718 // append line end
719 if (DirtySelection<>'')
720 and (not (DirtySelection[length(DirtySelection)] in [#10,#13])) then
721 DirtySelection:=DirtySelection+le;
722 // trim empty lines at start and end
723 DirtySelection:=TrimLineEnds(DirtySelection,true,true);
724 // adjust indent
725 Indent:=GetBlockMinIndent(DirtySelection,1,length(DirtySelection));
726 IndentText(DirtySelection,
727 Beauty.Indent-Indent,
728 Beauty.TabWidth,
729 s);
730 DirtySelection:=s;
731 if ResultNode<>nil then begin
732 DirtySelection:=DirtySelection
733 +Beauty.GetIndentStr(Beauty.Indent)
734 +'Result:='+GetIdentifier(@Src[ResultNode.StartPos])+';'+le;
735 end;
736 // create Begin..End block
737 BeginEndCode:='begin'+le
738 +DirtySelection
739 +'end;';
740 {$IFDEF CTDebug}
741 DebugLn('TExtractProcTool.CreateProcBeginEndBlock END BeginEndCode="',BeginEndCode,'"');
742 {$ENDIF}
743 Result:=true;
744 end;
745
FindInsertPositionForProcBodynull746 function FindInsertPositionForProcBody(
747 out InsertPos, Indent: integer): boolean;
748 var
749 BeginNode: TCodeTreeNode;
750 ANode: TCodeTreeNode;
751 InsertNode: TCodeTreeNode;
752 begin
753 Result:=false;
754 case ProcType of
755
756 eptSubProcedure:
757 begin
758 if MainBlockNode.Desc<>ctnProcedure then begin
759 debugln(['FindInsertPositionForProcBody subprocedure: not in a procedure']);
760 exit;
761 end;
762 BeginNode:=MainBlockNode.LastChild;
763 while BeginNode.Desc<>ctnBeginBlock do
764 BeginNode:=BeginNode.PriorBrother;
765 InsertPos:=BeginNode.StartPos;
766 Indent:=Beauty.GetLineIndent(Src,InsertPos)+Beauty.Indent;
767 end;
768
769 eptSubProcedureSameLvl:
770 begin
771 // -> insert in front of old proc
772 InsertPos:=FindLineEndOrCodeInFrontOfPosition(MainBlockNode.StartPos);
773 Indent:=Beauty.GetLineIndent(Src,MainBlockNode.StartPos);
774 end;
775
776 eptProcedure,eptProcedureWithInterface:
777 begin
778 // insert in front of top level proc
779 InsertNode:=MainBlockNode;
780 ANode:=InsertNode;
781 while (ANode<>nil) do begin
782 if ANode.Desc=ctnProcedure then
783 InsertNode:=ANode;
784 ANode:=ANode.Parent;
785 end;
786 if NodeIsMethodBody(InsertNode) then begin
787 // insert in front of all methods
788 while (InsertNode.PriorBrother<>nil)
789 and (InsertNode.PriorBrother.Desc=ctnProcedure)
790 and (NodeIsMethodBody(InsertNode)) do
791 InsertNode:=InsertNode.PriorBrother;
792 end;
793 // -> insert in front of top level proc
794 Indent:=Beauty.GetLineIndent(Src,InsertNode.StartPos);
795 if InsertNode.PriorBrother<>nil then begin
796 InsertPos:=FindLineEndOrCodeAfterPosition(
797 InsertNode.PriorBrother.EndPos);
798 end else if InsertNode.Parent.Desc=ctnImplementation then begin
799 MoveCursorToNodeStart(InsertNode.Parent);
800 ReadNextAtom;
801 InsertPos:=FindLineEndOrCodeAfterPosition(CurPos.EndPos);
802 end else begin
803 InsertPos:=FindLineEndOrCodeInFrontOfPosition(InsertNode.StartPos,true);
804 end;
805 end;
806
807 eptPublishedMethod,eptPrivateMethod,eptProtectedMethod,eptPublicMethod:
808 begin
809 // set default values
810 InsertPos:=FindLineEndOrCodeInFrontOfPosition(MainBlockNode.StartPos);
811 Indent:=Beauty.GetLineIndent(Src,MainBlockNode.StartPos);
812 end;
813
814 else
815 exit;
816 end;
817 Result:=true;
818 end;
819
FindInsertPositionForProcIntfnull820 function FindInsertPositionForProcIntf(
821 out IntfInsertPos, IntfIndent: integer): boolean;
822 begin
823 Result:=false;
824 IntfInsertPos:=0;
825 IntfIndent:=0;
826 case ProcType of
827
828 eptProcedureWithInterface:
829 begin
830 FindInsertPositionForProcInterface(IntfIndent,IntfInsertPos,
831 SourceChangeCache);
832 end;
833
834 end;
835
836 Result:=true;
837 end;
838
NewProcAlreadyExistsnull839 function NewProcAlreadyExists(const ProcClassName, BaseParamList: string;
840 InsertPos: integer): boolean;
841 var
842 ContextNode: TCodeTreeNode;
843 ConflictProcNode: TCodeTreeNode;
844 ProcHead: String;
845 begin
846 // find context at insert position
847 ContextNode:=FindDeepestNodeAtPos(InsertPos,true);
848 if (ContextNode.Parent<>nil) then
849 ContextNode:=ContextNode.FirstChild;
850 // search proc in context
851 if ProcClassName<>'' then
852 ProcHead:=ProcClassName+'.'
853 else
854 ProcHead:='';
855 ProcHead:=ProcHead+ProcName+BaseParamList;
856 ConflictProcNode:=FindProcNode(ContextNode,ProcHead,mgMethod,
857 ShortProcFormat+[phpIgnoreForwards]);
858 Result:=ConflictProcNode<>nil;
859 if Result then begin
860 RaiseException(20170421201925,'New procedure "'+ProcName+'" exists already');
861 end;
862 {$IFDEF CTDebug}
863 DebugLn('NewProcAlreadExists END ProcHead="',ProcHead,'" Found=',dbgs(Result));
864 {$ENDIF}
865 end;
866
InsertProcIntfnull867 function InsertProcIntf(IntfInsertPos, IntfIndent: integer;
868 const CompleteParamList, BaseParamList, ProcCode: string;
869 ProcClassNode: TCodeTreeNode): boolean;
870 var
871 ProcHeader: String;
872 FrontGap: TGapTyp;
873 AfterGap: TGapTyp;
874 InsertNode: TCodeTreeNode;
875 MethodDefinition: String;
876 CleanMethodDefinition: String;
877 NewClassPart: TNewClassPart;
878 Keyword: String;
879 begin
880 Result:=false;
881 if ResultNode=nil then
882 Keyword:='procedure'
883 else
884 Keyword:='function';
885
886 case ProcType of
887
888 eptProcedureWithInterface:
889 begin
890 ProcHeader:=Keyword+' '+ProcName+CompleteParamList+';';
891 ProcHeader:=Beauty.BeautifyStatement(ProcHeader,IntfIndent);
892 {$IFDEF CTDebug}
893 DebugLn('TExtractProcTool.InsertProcIntf END ProcHeader="',ProcHeader,'"');
894 {$ENDIF}
895 FrontGap:=gtEmptyLine;
896 AfterGap:=gtEmptyLine;
897 InsertNode:=FindDeepestNodeAtPos(IntfInsertPos,false);
898 if (InsertNode<>nil) then begin
899 if (InsertNode.Desc=ctnProcedure) then
900 AfterGap:=gtNewLine;
901 if (InsertNode.PriorBrother<>nil)
902 and (InsertNode.PriorBrother.Desc=ctnProcedure) then
903 FrontGap:=gtNewLine;
904 end;
905 if not SourceChangeCache.Replace(FrontGap,AfterGap,
906 IntfInsertPos,IntfInsertPos,ProcHeader)
907 then exit;
908 end;
909
910 eptPublishedMethod,eptPrivateMethod,eptProtectedMethod,eptPublicMethod:
911 begin
912 // initialize class for code completion
913 CodeCompleteClassNode:=ProcClassNode;
914 CodeCompleteSrcChgCache:=SourceChangeCache;
915
916 // insert new method to class
917 MethodDefinition:=Keyword+' '+ProcName+CompleteParamList+';';
918 CleanMethodDefinition:=Keyword+' '+ProcName+BaseParamList+';';
919 if ProcExistsInCodeCompleteClass(CleanMethodDefinition) then exit;
920 case ProcType of
921 eptPrivateMethod: NewClassPart:=ncpPrivateProcs;
922 eptProtectedMethod: NewClassPart:=ncpProtectedProcs;
923 eptPublicMethod: NewClassPart:=ncpPublicProcs;
924 else NewClassPart:=ncpPublishedProcs;
925 end;
926 AddClassInsertion(CleanMethodDefinition, MethodDefinition,
927 ProcName, NewClassPart, nil, ProcCode);
928 if not InsertAllNewClassParts then
929 RaiseException(20170421201927,ctsErrorDuringInsertingNewClassParts);
930 end;
931
932 end;
933 Result:=true;
934 end;
935
CreateProcBodynull936 function CreateProcBody(const ProcClassName, ParamList,
937 VarSection, BeginEndCode: string; out ProcCode: string): boolean;
938 var
939 le: String;
940 ProcHeader: String;
941 begin
942 le:=Beauty.LineEnd;
943 if ResultNode=nil then
944 ProcHeader:='procedure '
945 else
946 ProcHeader:='function ';
947 if ProcClassName<>'' then
948 ProcHeader:=ProcHeader+ProcClassName+'.';
949 ProcHeader:=ProcHeader+ProcName+ParamList+';'+le;
950 ProcHeader:=Beauty.BeautifyStatement(ProcHeader,0);
951 ProcCode:=ProcHeader+VarSection+BeginEndCode;
952 Result:=true;
953 end;
954
InsertProcBodynull955 function InsertProcBody(InsertPos,Indent: integer;
956 const ProcCode: string): boolean;
957 var
958 TabWidth: Integer;
959 IndentedProcCode: string;
960 begin
961 Result:=false;
962 if ProcType in [eptPublishedMethod,eptPrivateMethod,eptProtectedMethod,
963 eptPublicMethod] then
964 begin
965 if not CreateMissingClassProcBodies(false) then
966 RaiseException(20170421201930,ctsErrorDuringCreationOfNewProcBodies);
967 end else begin
968 TabWidth:=Beauty.TabWidth;
969 IndentText(ProcCode,Indent,TabWidth,IndentedProcCode);
970 {$IFDEF CTDebug}
971 DebugLn('TExtractProcTool.InsertProcBody END ProcCode="',ProcCode,'"');
972 {$ENDIF}
973 if not SourceChangeCache.Replace(gtEmptyLine,gtEmptyLine,
974 InsertPos,InsertPos,IndentedProcCode) then exit;
975 end;
976 Result:=true;
977 end;
978
CreatePathForNewProcnull979 function CreatePathForNewProc(InsertPos: integer;
980 const ProcClassName, BaseParamList: string;
981 var NewProcPath: TStrings): boolean;
982 var
983 ContextNode: TCodeTreeNode;
984 ProcHead: String;
985 begin
986 Result:=false;
987 // find context at insert position
988 ContextNode:=FindDeepestNodeAtPos(InsertPos,true);
989 if (ContextNode.Desc=ctnProcedure) and (ContextNode.StartPos=InsertPos)
990 or ((ContextNode.LastChild<>nil) and (ContextNode.LastChild.StartPos<InsertPos))
991 then
992 // ContextNode is a procedure below or above the insert position
993 // => after the insert the new proc will not be a child
994 // -> it will become a child of its parent
995 ContextNode:=ContextNode.Parent;
996 NewProcPath:=CreateSubProcPath(ContextNode,ShortProcFormat);
997 // add new proc
998 if ProcClassName<>'' then
999 ProcHead:=ProcClassName+'.'
1000 else
1001 ProcHead:='';
1002 ProcHead:=ProcHead+ProcName+BaseParamList+';';
1003 NewProcPath.Add(ProcHead);
1004 Result:=true;
1005 end;
1006
FindJumpPointToNewProcnull1007 function FindJumpPointToNewProc(SubProcPath: TStrings): boolean;
1008 var
1009 NewProcNode: TCodeTreeNode;
1010 begin
1011 Result:=false;
1012 // reparse code and find jump point into new proc
1013 BuildTree(lsrInitializationStart);
1014 NewProcNode:=FindSubProcPath(SubProcPath,ShortProcFormat,true);
1015 {$IFDEF CTDebug}
1016 DebugLn('FindJumpPointToNewProc A found=',dbgs(NewProcNode<>nil));
1017 {$ENDIF}
1018 if NewProcNode=nil then exit;
1019 Result:=FindJumpPointInProcNode(NewProcNode,NewPos,NewTopLine,BlockTopLine,BlockBottomLine);
1020 {$IFDEF CTDebug}
1021 DebugLn('FindJumpPointToNewProc END ',NewProcNode.DescAsString,' ',dbgs(Result),' ',dbgs(NewPos.X),',',dbgs(NewPos.Y),' ',dbgs(NewTopLine));
1022 {$ENDIF}
1023 end;
1024
1025 var
1026 MethodPossible: Boolean;
1027 SubProcSameLvlPossible: boolean;
1028 ProcClassName, CompleteParamList, BaseParamList, VarSection,
1029 BeginEndCode: string;
1030 InsertPos, Indent: integer;
1031 IntfInsertPos, IntfIndent: integer;
1032 NewProcPath: TStrings;
1033 ProcClassNode: TCodeTreeNode;
1034 ProcCode: string;
1035 SubProcPossible: boolean;
1036 begin
1037 Result:=false;
1038 {$IFDEF CTDebug}
1039 DebugLn(['ExtractProc A ProcName="',ProcName,'" ProcType=',ExtractProcTypeNames[ProcType],' FunctionResultVariableStartPos=',FunctionResultVariableStartPos]);
1040 {$ENDIF}
1041 if not InitExtractProc(StartPos,EndPos,MethodPossible,
1042 SubProcPossible,SubProcSameLvlPossible)
1043 then exit;
1044 if (not MethodPossible) and (ProcType in [eptPrivateMethod,eptProtectedMethod,
1045 eptPublicMethod,eptPublishedMethod])
1046 then
1047 exit;
1048 if (not SubProcPossible)
1049 and (ProcType in [eptSubProcedure,eptSubProcedureSameLvl]) then
1050 exit;
1051 if (not SubProcSameLvlPossible) and (ProcType=eptSubProcedureSameLvl) then
1052 exit;
1053 CodeCompleteSrcChgCache:=SourceChangeCache;
1054 Beauty:=SourceChangeCache.BeautifyCodeOptions;
1055
1056 VarTree:=CreateExtractProcVariableTree;
1057 NewProcPath:=nil;
1058 try
1059 if not ScanNodesForVariables(StartPos,EndPos,BlockStartPos,BlockEndPos,
1060 MainBlockNode,VarTree,IgnoreIdentifiers,nil) then exit;
1061 if not FindFunctionResultNode then exit;
1062 if not ReplaceSelectionWithCall then exit;
1063 if not DeleteMovedLocalVariables then exit;
1064 if not CreateProcNameParts(ProcClassName,ProcClassNode) then exit;
1065 if not CreateProcParamList(CompleteParamList,BaseParamList) then exit;
1066 if not CreateProcVarSection(VarSection) then exit;
1067 if not CreateProcBeginEndBlock(BeginEndCode) then exit;
1068 if not FindInsertPositionForProcIntf(IntfInsertPos,IntfIndent) then exit;
1069 if not FindInsertPositionForProcBody(InsertPos,Indent) then exit;
1070 if NewProcAlreadyExists(ProcClassName,BaseParamList,InsertPos) then exit;
1071 if not CreateProcBody(ProcClassName,CompleteParamList,
1072 VarSection,BeginEndCode,ProcCode) then exit;
1073 if not InsertProcIntf(IntfInsertPos,IntfIndent,CompleteParamList,
1074 BaseParamList,ProcCode,ProcClassNode) then exit;
1075 if not InsertProcBody(InsertPos,Indent,ProcCode) then exit;
1076 if not CreatePathForNewProc(InsertPos,ProcClassName,BaseParamList,
1077 NewProcPath) then exit;
1078 if not SourceChangeCache.Apply then exit;
1079 if not FindJumpPointToNewProc(NewProcPath) then exit;
1080 finally
1081 ClearExtractProcVariableTree(VarTree,true);
1082 NewProcPath.Free;
1083 end;
1084 Result:=true;
1085 end;
1086
TExtractCodeTool.RemoveWithBlocknull1087 function TExtractCodeTool.RemoveWithBlock(const CursorPos: TCodeXYPosition;
1088 SourceChangeCache: TSourceChangeCache): boolean;
1089 type
1090 TWithVarCache = record
1091 WithVarNode: TCodeTreeNode;
1092 VarEndPos: integer;
1093 WithVarExpr: TExpressionType;
1094 end;
1095 PWithVarCache = ^TWithVarCache;
1096
1097 var
1098 WithVarNode: TCodeTreeNode;
1099 StatementNode: TCodeTreeNode;
1100 WithIdentifiers: TAVLTree; // identifiers to change
1101 WithVarCache: TFPList; // list of PWithVarCache
1102 WithVarEndPos: LongInt;
1103 Beauty: TBeautifyCodeOptions;
1104 WithKeyWord, DoKeyWord, BeginKeyWord, EndKeyWord: TAtomPosition;
1105 EndSemiColon: integer; // position of the ending semicolon, 0=not there
1106 IndentWith: integer; // indent of the line containing the WITH keyword
1107 IndentInnerWith: integer; // indent of the first statement in the WITH
1108 DeleteHeaderEndPos, DeleteFooterStartPos: integer;
1109 KeepBeginEnd: boolean;
1110
1111 procedure AddIdentifier(CleanPos: integer);
1112 var
1113 p: Pointer;
1114 begin
1115 p:={%H-}Pointer(PtrUInt(CleanPos));
1116 if WithIdentifiers=nil then WithIdentifiers:=TAVLTree.Create;
1117 if WithIdentifiers.Find(p)<>nil then exit;
1118 {$IFDEF CTDEBUG}
1119 debugln(['AddIdentifier ',GetIdentifier(@Src[CleanPos])]);
1120 {$ENDIF}
1121 WithIdentifiers.Add(p);
1122 end;
1123
IdentifierDefinedByWithnull1124 function IdentifierDefinedByWith(CleanPos: integer;
1125 WithVarNode: TCodeTreeNode): boolean;
1126 var
1127 i: Integer;
1128 Cache: PWithVarCache;
1129 ParentParams, Params: TFindDeclarationParams;
1130 begin
1131 Result:=false;
1132
1133 ParentParams := TFindDeclarationParams.Create(Self,WithVarNode);
1134 try
1135 // check cache
1136 if WithVarCache=nil then
1137 WithVarCache:=TFPList.Create;
1138 i:=WithVarCache.Count-1;
1139 while (i>=0) and (PWithVarCache(WithVarCache[i])^.WithVarNode<>WithVarNode) do
1140 dec(i);
1141 if i>=0 then begin
1142 Cache:=PWithVarCache(WithVarCache[i]);
1143 end else begin
1144 // resolve type of With variable
1145 {$IFDEF CTDEBUG}
1146 debugln(['IdentifierDefinedByWith NEW WithVar']);
1147 {$ENDIF}
1148 New(Cache);
1149 WithVarCache.Add(Cache);
1150 Cache^.WithVarNode:=WithVarNode;
1151 Cache^.WithVarExpr:=CleanExpressionType;
1152 Cache^.VarEndPos:=FindEndOfTerm(WithVarNode.StartPos,false,true);
1153 Params:=TFindDeclarationParams.Create(ParentParams);
1154 try
1155 Params.ContextNode:=WithVarNode;
1156 Params.Flags:=[fdfExceptionOnNotFound,fdfFunctionResult,fdfFindChildren];
1157 Cache^.WithVarExpr:=FindExpressionTypeOfTerm(WithVarNode.StartPos,-1,Params,true);
1158 if (Cache^.WithVarExpr.Desc<>xtContext)
1159 or (Cache^.WithVarExpr.Context.Node=nil)
1160 or (not (Cache^.WithVarExpr.Context.Node.Desc
1161 in (AllClasses+[ctnEnumerationType])))
1162 then begin
1163 MoveCursorToCleanPos(Cache^.WithVarNode.StartPos);
1164 RaiseException(20170421201932,ctsExprTypeMustBeClassOrRecord);
1165 end;
1166 {$IFDEF CTDEBUG}
1167 debugln(['IdentifierDefinedByWith WithVarExpr=',ExprTypeToString(Cache^.WithVarExpr)]);
1168 {$ENDIF}
1169 finally
1170 Params.Free;
1171 end;
1172 end;
1173
1174 if CleanPos<=Cache^.VarEndPos then exit;
1175
1176 // search identifier in with var context
1177 Params:=TFindDeclarationParams.Create(ParentParams);
1178 try
1179 Params.SetIdentifier(Self,@Src[CleanPos],nil);
1180 Params.Flags:=[fdfSearchInAncestors,fdfSearchInHelpers];
1181 Params.ContextNode:=Cache^.WithVarExpr.Context.Node;
1182 Result:=Cache^.WithVarExpr.Context.Tool.FindIdentifierInContext(Params);
1183 {$IFDEF CTDEBUG}
1184 debugln(['IdentifierDefinedByWith Identifier=',GetIdentifier(@Src[CleanPos]),' FoundInWith=',Result,' WithVar="',dbgstr(Src,WithVarNode.StartPos,10),'"']);
1185 {$ENDIF}
1186 finally
1187 Params.Free;
1188 end;
1189 finally
1190 ParentParams.Free;
1191 end;
1192 end;
1193
1194 procedure CheckIdentifierAtCursor;
1195 var
1196 IdentifierCleanPos: LongInt;
1197 Node: TCodeTreeNode;
1198 begin
1199 IdentifierCleanPos:=CurPos.StartPos;
1200 // search identifier in all WITH contexts
1201 Node:=FindDeepestNodeAtPos(IdentifierCleanPos,true);
1202 while Node<>nil do begin
1203 if Node.Desc=ctnWithVariable then begin
1204 if IdentifierDefinedByWith(IdentifierCleanPos,Node) then begin
1205 if Node=WithVarNode then begin
1206 // identifier uses the removing WITH
1207 // ToDo: check if it resolves without the WITH to the same
1208 AddIdentifier(IdentifierCleanPos);
1209 end else begin
1210 // identifier is defined in a sub With
1211 break;
1212 end;
1213 end;
1214 // next
1215 if Node=WithVarNode then
1216 break
1217 else if (Node.PriorBrother<>nil)
1218 and (Node.PriorBrother.Desc=ctnWithVariable)
1219 and (Node.PriorBrother.FirstChild=nil) then
1220 // e.g. with A,B do
1221 Node:=Node.PriorBrother
1222 else
1223 Node:=Node.Parent;
1224 end else
1225 Node:=Node.Parent;
1226 end;
1227 end;
1228
NeedBracketsnull1229 function NeedBrackets(StartPos, EndPos: integer): boolean;
1230 begin
1231 Result:=false;
1232 MoveCursorToCleanPos(StartPos);
1233 repeat
1234 ReadNextAtom;
1235 if WordIsTermOperator.DoItCaseInsensitive(Src,
1236 CurPos.StartPos,CurPos.EndPos-CurPos.StartPos)
1237 then exit(true);
1238 until (CurPos.StartPos>=EndPos) or (CurPos.StartPos>SrcLen);
1239 end;
1240
FindBoundsnull1241 function FindBounds: boolean;
1242 var
1243 p: Integer;
1244 NeedBeginEnd: Boolean;
1245 begin
1246 Result:=false;
1247 WithKeyWord:=CleanAtomPosition;
1248 DoKeyWord:=CleanAtomPosition;
1249 BeginKeyWord:=CleanAtomPosition;
1250 EndKeyWord:=CleanAtomPosition;
1251 EndSemiColon:=0;
1252 KeepBeginEnd:=false;
1253 NeedBeginEnd:=false;
1254 MoveCursorToNodeStart(WithVarNode.Prior);
1255 repeat
1256 ReadNextAtom;
1257 if (CurPos.StartPos<WithVarNode.StartPos) then begin
1258 NeedBeginEnd:=UpAtomIs('DO') or UpAtomIs('THEN') or UpAtomIs('ELSE');
1259 if NeedBeginEnd then
1260 ReadNextAtom;
1261 if UpAtomIs('WITH') then begin
1262 WithKeyWord:=CurPos;
1263 KeepBeginEnd:=NeedBeginEnd;
1264 end;
1265 end else if (DoKeyword.EndPos=0) and (WithKeyWord.StartPos>0) and UpAtomIs('DO')
1266 then begin
1267 DoKeyWord:=CurPos;
1268 ReadNextAtom;
1269 if UpAtomIs('BEGIN') then begin
1270 BeginKeyWord:=CurPos;
1271 ReadTilBlockEnd(false,false);
1272 EndKeyWord:=CurPos;
1273 ReadNextAtom;
1274 if CurPos.Flag=cafSemicolon then
1275 EndSemiColon:=CurPos.StartPos;
1276 end;
1277 break;
1278 end;
1279 until (CurPos.StartPos>SrcLen) or (CurPos.StartPos>StatementNode.EndPos);
1280 IndentWith:=Beauty.GetLineIndent(Src,WithKeyWord.StartPos);
1281 p:=FindLineEndOrCodeAfterPosition(Max(DoKeyWord.EndPos,BeginKeyWord.EndPos),true,true);
1282 IndentInnerWith:=Beauty.GetLineIndent(Src,p);
1283 Result:=true;
1284 end;
1285
RemoveWithHeadernull1286 function RemoveWithHeader: boolean;
1287 var
1288 StartPos: LongInt;
1289 EndPos: LongInt;
1290 begin
1291 DeleteHeaderEndPos:=0;
1292 DeleteFooterStartPos:=SrcLen;
1293 if (WithVarNode.FirstChild<>nil)
1294 and ((WithVarNode.PriorBrother=nil)
1295 or (WithVarNode.PriorBrother.Desc<>ctnWithVariable)
1296 or (WithVarNode.PriorBrother.FirstChild<>nil))
1297 then begin
1298 // remove WITH header and footer
1299 // e.g. with A do
1300 // with A do begin end;
1301 // remove 'with .. do [begin..end;]'
1302 StartPos:=FindLineEndOrCodeInFrontOfPosition(WithKeyword.StartPos);
1303 EndPos:=DoKeyWord.EndPos;
1304 if (not KeepBeginEnd) and (BeginKeyWord.StartPos>0) then
1305 EndPos:=BeginKeyWord.EndPos;
1306 EndPos:=FindLineEndOrCodeAfterPosition(EndPos);
1307 if not SourceChangeCache.Replace(gtSpace,gtNone,StartPos,EndPos,'')
1308 then exit(false);
1309 DeleteHeaderEndPos:=EndPos;
1310
1311 // remove 'end;'
1312 if (not KeepBeginEnd) and (EndKeyWord.StartPos>0) then begin
1313 StartPos:=FindLineEndOrCodeInFrontOfPosition(EndKeyWord.StartPos);
1314 EndPos:=Max(StatementNode.EndPos,EndSemiColon+1);
1315 EndPos:=FindLineEndOrCodeAfterPosition(EndPos);
1316 if not SourceChangeCache.Replace(gtSpace,gtNone,StartPos,EndPos,'')
1317 then exit(false);
1318 DeleteFooterStartPos:=StartPos;
1319 end;
1320 end else begin
1321 // remove only variable
1322 // e.g. with A,B do
1323 StartPos:=WithVarNode.StartPos;
1324 EndPos:=WithVarEndPos;
1325 if Src[EndPos]=',' then begin
1326 inc(EndPos);
1327 end else if (WithVarNode.PriorBrother<>nil)
1328 and (WithVarNode.PriorBrother.Desc=ctnWithVariable)
1329 and (WithVarNode.PriorBrother.FirstChild=nil) then begin
1330 StartPos:=FindEndOfTerm(WithVarNode.PriorBrother.StartPos,true,true);
1331 StartPos:=FindLineEndOrCodeAfterPosition(StartPos);
1332 end;
1333 EndPos:=FindLineEndOrCodeAfterPosition(EndPos,true);
1334 StartPos:=FindLineEndOrCodeInFrontOfPosition(StartPos);
1335 if not SourceChangeCache.Replace(gtSpace,gtNone,StartPos,EndPos,'') then
1336 exit(false);
1337 end;
1338 Result:=true;
1339 end;
1340
PrefixSubIdentifiersnull1341 function PrefixSubIdentifiers: boolean;
1342 var
1343 WithVar: String;
1344 AVLNode: TAVLTreeNode;
1345 CleanPos: Integer;
1346 begin
1347 // insert all 'variable.'
1348 if WithIdentifiers<>nil then begin
1349 WithVar:=ExtractCode(WithVarNode.StartPos,WithVarEndPos,[]);
1350 if NeedBrackets(WithVarNode.StartPos,WithVarEndPos) then
1351 WithVar:='('+WithVar+')';
1352 WithVar:=WithVar+'.';
1353 //debugln(['Replace WithVar="',dbgstr(WithVar),'"']);
1354
1355 AVLNode:=WithIdentifiers.FindLowest;
1356 while AVLNode<>nil do begin
1357 CleanPos:=integer({%H-}PtrUInt(AVLNode.Data));
1358 //debugln(['Replace Prefix identifier: ',GetIdentifier(@Src[CleanPos])]);
1359 if not SourceChangeCache.Replace(gtNone,gtNone,CleanPos,CleanPos,WithVar)
1360 then
1361 exit(false);
1362 AVLNode:=WithIdentifiers.FindSuccessor(AVLNode);
1363 end;
1364 end;
1365 Result:=true;
1366 end;
1367
UnindentAndEncloseSkippedCodenull1368 function UnindentAndEncloseSkippedCode: boolean;
1369
UnIndentnull1370 function UnIndent(FromPos,ToPos: integer): boolean;
1371 begin
1372 Result:=true;
1373 FromPos:=Max(FromPos,DeleteHeaderEndPos);
1374 ToPos:=Min(ToPos,DeleteFooterStartPos);
1375 if FromPos>=ToPos then exit;
1376 if IndentWith>=IndentInnerWith then exit;
1377 // unindent
1378 FromPos:=FindLineEndOrCodeAfterPosition(FromPos,true,true);
1379 //debugln(['UnIndent FromPos=',CleanPosToStr(FromPos),' ToPos=',CleanPosToStr(ToPos),' Src="',dbgstr(Src,FromPos,ToPos),'"']);
1380 if not SourceChangeCache.IndentBlock(FromPos,ToPos,IndentWith-IndentInnerWith)
1381 then begin
1382 debugln(['UnindentAndEncloseSkippedCode.UnIndent failed: ']);
1383 exit(false);
1384 end;
1385 end;
1386
1387 var
1388 p: Integer;
1389 EndPos: Integer;
1390 WithHeader: String;
1391 InsertPos: Integer;
1392 WithFooter: String;
1393 StartPos: Integer;
1394 begin
1395 // enclose all $ELSE code in WITH blocks
1396 Result:=false;
1397 WithHeader:='';
1398 WithFooter:='';
1399 p:=Max(StatementNode.StartPos,BeginKeyWord.EndPos);
1400 EndPos:=StatementNode.EndPos;
1401 if EndPos>SrcLen then EndPos:=SrcLen;
1402 StartPos:=p;
1403 while (p<EndPos) do begin
1404 if (Src[p]='{') and (Src[p+1]=#3) then begin
1405 if not Unindent(StartPos,p) then exit;
1406 // start of skipped code
1407 if WithHeader='' then begin
1408 // Header: WITH <var> DO [BEGIN]
1409 WithHeader:=ExtractCode(WithVarNode.StartPos,WithVarEndPos,[]);
1410 if NeedBrackets(WithVarNode.StartPos,WithVarEndPos) then
1411 WithHeader:='('+WithHeader+')';
1412 WithHeader:=GetAtom(WithKeyWord)+' '+WithHeader+' '+GetAtom(DoKeyWord)+' ';
1413 if BeginKeyWord.StartPos>0 then
1414 WithHeader+=GetAtom(BeginKeyWord)
1415 else
1416 WithHeader+=Beauty.BeautifyKeyWord('begin');
1417 end;
1418 InsertPos:=FindLineEndOrCodeAfterPosition(p+2);
1419 //debugln(['EncloseSkippedCode Header=',dbgstr(WithHeader)]);
1420 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,InsertPos,InsertPos,
1421 Beauty.GetIndentStr(IndentWith)+WithHeader)
1422 then
1423 exit(false);
1424 p:=FindCommentEnd(Src,p,Scanner.NestedComments);
1425 // end of skipped code
1426 InsertPos:=p-2;
1427 if WithFooter='' then begin
1428 // Footer: END;
1429 if EndKeyWord.StartPos>0 then
1430 WithFooter:=GetAtom(EndKeyWord)
1431 else
1432 WithFooter:=Beauty.BeautifyKeyWord('end');
1433 WithFooter+=';';
1434 end;
1435 //debugln(['EncloseSkippedCode Footer=',dbgstr(WithFooter)]);
1436 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,InsertPos,InsertPos,
1437 Beauty.GetIndentStr(IndentWith)+WithFooter)
1438 then
1439 exit(false);
1440 StartPos:=p;
1441 end;
1442 inc(p);
1443 end;
1444 Result:=Unindent(StartPos,p);
1445 end;
1446
1447 var
1448 CleanPos: integer;
1449 LastAtom: TAtomPosition;
1450 i: Integer;
1451 Cache: PWithVarCache;
1452 begin
1453 Result:=false;
1454 WithIdentifiers:=nil;
1455 WithVarCache:=nil;
1456 BuildTreeAndGetCleanPos(CursorPos,CleanPos);
1457 WithVarNode:=FindDeepestNodeAtPos(CleanPos,true);
1458 if WithVarNode.Desc<>ctnWithVariable then begin
1459 debugln(['TExtractProcTool.RemoveWithBlock cursor not at a with variable, but ',WithVarNode.DescAsString]);
1460 exit;
1461 end;
1462 StatementNode:=WithVarNode;
1463 while (StatementNode<>nil) and (StatementNode.FirstChild=nil) do
1464 StatementNode:=StatementNode.NextBrother;
1465 if StatementNode=nil then begin
1466 debugln(['TExtractProcTool.RemoveWithBlock missing statement']);
1467 exit;
1468 end;
1469 Beauty:=SourceChangeCache.BeautifyCodeOptions;
1470 // parse block
1471 WithVarEndPos:=FindEndOfTerm(WithVarNode.StartPos,false,true);
1472 MoveCursorToCleanPos(WithVarEndPos);
1473 ReadNextAtom;
1474 try
1475 repeat
1476 LastAtom:=CurPos;
1477 ReadNextAtom;
1478 if AtomIsIdentifier and (LastAtom.Flag<>cafPoint) then begin
1479 LastAtom:=CurPos;
1480 CheckIdentifierAtCursor;
1481 // restore cursor
1482 MoveCursorToAtomPos(LastAtom);
1483 end;
1484 until (CurPos.StartPos>SrcLen) or (CurPos.StartPos>=StatementNode.EndPos);
1485 {$IFDEF CTDEBUG}
1486 debugln(['TExtractProcTool.RemoveWithBlock Statement=',copy(Src,StatementNode.StartPos,StatementNode.EndPos-StatementNode.StartPos)]);
1487 {$ENDIF}
1488
1489 // RemoveWithHeader
1490 SourceChangeCache.MainScanner:=Scanner;
1491 if not FindBounds then begin
1492 debugln(['TExtractProcTool.RemoveWithBlock FindBounds failed']);
1493 exit;
1494 end;
1495 if not RemoveWithHeader then begin
1496 debugln(['TExtractProcTool.RemoveWithBlock RemoveWithHeader failed']);
1497 exit;
1498 end;
1499 if not UnindentAndEncloseSkippedCode then begin
1500 debugln(['TExtractProcTool.RemoveWithBlock UnindentAndEncloseSkippedCode failed']);
1501 exit;
1502 end;
1503 if not PrefixSubIdentifiers then begin
1504 debugln(['TExtractProcTool.RemoveWithBlock PrefixSubIdentifiers failed']);
1505 exit;
1506 end;
1507
1508 Result:=SourceChangeCache.Apply;
1509 //debugln(['TExtractProcTool.RemoveWithBlock SOURCE:']);
1510 //debugln(TCodeBuffer(Scanner.MainCode).Source);
1511 finally
1512 WithIdentifiers.Free;
1513 if WithVarCache<>nil then begin
1514 for i:=0 to WithVarCache.Count-1 do begin
1515 Cache:=PWithVarCache(WithVarCache[i]);
1516 Dispose(Cache);
1517 end;
1518 WithVarCache.Free;
1519 end;
1520 end;
1521 end;
1522
TExtractCodeTool.AddWithBlocknull1523 function TExtractCodeTool.AddWithBlock(const StartPos, EndPos: TCodeXYPosition;
1524 const WithExpr: string; Candidates: TStrings;
1525 SourceChangeCache: TSourceChangeCache): boolean;
1526 var
1527 CleanStartPos: integer;
1528 CleanEndPos: integer;
1529 StartNode: TCodeTreeNode;
1530 Beauty: TBeautifyCodeOptions;
1531
Addnull1532 function Add(IdentifierStart, IdentifierEnd: integer;
1533 const Identifier: string): boolean;
1534 var
1535 i: Integer;
1536 begin
1537 Result:=true;
1538 if (IdentifierStart<CleanStartPos) or (IdentifierEnd>CleanEndPos) then
1539 exit;
1540 if WithExpr<>'' then begin
1541 if CompareText(Identifier,WithExpr)=0 then begin
1542 if not SourceChangeCache.Replace(gtNone,gtNone,
1543 IdentifierStart,IdentifierEnd,'')
1544 then
1545 exit(false);
1546 end;
1547 end else begin
1548 if Candidates=nil then exit;
1549 {$IFDEF VerboseAddWithBlock}
1550 debugln(['TExtractProcTool.AddWithBlock.Add Candidate="',Identifier,'"']);
1551 {$ENDIF}
1552 i:=Candidates.IndexOf(Identifier);
1553 if i<0 then
1554 Candidates.AddObject(Identifier,TObject(Pointer(1)))
1555 else
1556 Candidates.Objects[i]:=TObject(PtrUInt(Candidates.Objects[i])+1);
1557 end;
1558 end;
1559
ReadBlocknull1560 function ReadBlock(Code: PAnsiString): boolean;
1561 var
1562 LastPos: TAtomPosition;
1563 Identifier: String;
1564 StartFlag: TCommonAtomFlag;
1565 IdentifierStart, aStartPos: Integer;
1566 begin
1567 {$IFDEF VerboseAddWithBlock}
1568 debugln(['TExtractProcTool.AddWithBlock.ReadBlock START Atom=',GetAtom]);
1569 {$ENDIF}
1570 Result:=false;
1571 StartFlag:=CurPos.Flag;
1572 aStartPos:=CurPos.StartPos;
1573 while true do begin
1574 {$IFDEF VerboseAddWithBlock}
1575 debugln([' ReadBlock Atom="',GetAtom,'"']);
1576 {$ENDIF}
1577 if (CurPos.EndPos>CleanEndPos) or (CurPos.StartPos>SrcLen)
1578 or (CurPos.StartPos>StartNode.EndPos) then
1579 break;
1580 case CurPos.Flag of
1581 cafRoundBracketOpen,cafEdgedBracketOpen:
1582 if (CurPos.StartPos>aStartPos) then begin
1583 // nested brackets
1584 if not ReadBlock(Code) then exit;
1585 end;
1586 cafRoundBracketClose:
1587 if (StartFlag=cafRoundBracketOpen) then
1588 break
1589 else if StartFlag=cafEdgedBracketOpen then
1590 RaiseCharExpectedButAtomFound(20170421201936,']')
1591 else
1592 RaiseStringExpectedButAtomFound(20170421201938,'end');
1593 cafEdgedBracketClose:
1594 if (StartFlag=cafEdgedBracketOpen) then
1595 break
1596 else if StartFlag=cafRoundBracketOpen then
1597 RaiseCharExpectedButAtomFound(20170421201942,')')
1598 else
1599 RaiseStringExpectedButAtomFound(20170421201946,'end');
1600 end;
1601 if AtomIsIdentifier then begin
1602 LastPos:=LastAtoms.GetPriorAtom;
1603 if not ((LastPos.Flag in [cafPoint]) or LastAtomIs(0,'^')
1604 or LastUpAtomIs(0,'INHERITED'))
1605 then begin
1606 // start of identifier
1607 {$IFDEF VerboseAddWithBlock}
1608 debugln([' ReadBlock identifier START Atom="',GetAtom,'"']);
1609 {$ENDIF}
1610 Identifier:=GetAtom;
1611 IdentifierStart:=CurPos.StartPos;
1612 repeat
1613 ReadNextAtom;
1614 {$IFDEF VerboseAddWithBlock}
1615 debugln([' ReadBlock identifier NEXT Atom="',GetAtom,'" Identifier="',Identifier,'"']);
1616 {$ENDIF}
1617 if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then
1618 begin
1619 if not ReadBlock(@Identifier) then exit;
1620 end else if (CurPos.Flag=cafPoint) then begin
1621 if not Add(IdentifierStart,CurPos.EndPos,Identifier) then exit;
1622 end else if AtomIsChar('^') then begin
1623 end else if AtomIsIdentifier and (LastAtomIs(0,'.')) then begin
1624 end else begin
1625 break;
1626 end;
1627 Identifier:=Identifier+GetAtom;
1628 until false;
1629 {$IFDEF VerboseAddWithBlock}
1630 debugln([' ReadBlock identifier END Atom="',GetAtom,'" Identifier="',Identifier,'"']);
1631 {$ENDIF}
1632 if Code<>nil then
1633 Code^:=Code^+Identifier;
1634 continue;
1635 end;
1636 end;
1637 if Code<>nil then
1638 Code^:=Code^+GetAtom;
1639 ReadNextAtom;
1640 end;
1641 {$IFDEF VerboseAddWithBlock}
1642 debugln(['ReadBlock END Atom="',GetAtom,'"']);
1643 {$ENDIF}
1644 Result:=true;
1645 end;
1646
1647 var
1648 Code: String;
1649 Indent: Integer;
1650 begin
1651 Result:=false;
1652 if not CheckIfRangeOnSameLevel(StartPos,EndPos,CleanStartPos,CleanEndPos,
1653 StartNode) then exit;
1654 {$IFDEF VerboseAddWithBlock}
1655 debugln(['TExtractProcTool.AddWithBlock ',SrcLen,' ',CleanStartPos,' ',CleanEndPos]);
1656 debugln(['TExtractProcTool.AddWithBlock Src="',copy(Src,CleanStartPos,CleanEndPos-CleanStartPos),'"']);
1657 {$ENDIF}
1658 MoveCursorToNodeStart(StartNode);
1659 if WithExpr<>'' then
1660 SourceChangeCache.MainScanner:=Scanner;
1661 ReadNextAtom;
1662 if not ReadBlock(nil) then exit;
1663
1664 // ToDo: check if identifiers are variables
1665
1666 Beauty:=SourceChangeCache.BeautifyCodeOptions;
1667 if WithExpr<>'' then begin
1668 // add 'with expr do begin'
1669 Indent:=Beauty.GetLineIndent(Src,CleanStartPos);
1670 Code:='with '+WithExpr+' do begin';
1671 Code:=Beauty.BeautifyStatement(Code,Indent);
1672 {$IFDEF VerboseAddWithBlock}
1673 debugln(['TExtractProcTool.AddWithBlock Header=',Code]);
1674 {$ENDIF}
1675 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,
1676 CleanStartPos,CleanStartPos,Code) then exit;
1677 // add 'end;'
1678 Code:='end;';
1679 Code:=Beauty.BeautifyStatement(Code,Indent);
1680 {$IFDEF VerboseAddWithBlock}
1681 debugln(['TExtractProcTool.AddWithBlock Footer=',Code]);
1682 {$ENDIF}
1683 if not SourceChangeCache.Replace(gtNewLine,gtNewLine,
1684 CleanEndPos,CleanEndPos,Code) then exit;
1685 // indent all between
1686 {$IFDEF VerboseAddWithBlock}
1687 debugln(['TExtractProcTool.AddWithBlock Indent...']);
1688 {$ENDIF}
1689 if not SourceChangeCache.IndentBlock(CleanStartPos,CleanEndPos,
1690 Beauty.Indent) then exit;
1691 {$IFDEF VerboseAddWithBlock}
1692 debugln(['TExtractProcTool.AddWithBlock Apply']);
1693 {$ENDIF}
1694 if not SourceChangeCache.Apply then exit;
1695 end;
1696 Result:=true;
1697 end;
1698
1699 procedure TExtractCodeTool.CalcMemSize(Stats: TCTMemStats);
1700 begin
1701 inherited CalcMemSize(Stats);
1702 end;
1703
ScanNodesForVariablesnull1704 function TExtractCodeTool.ScanNodesForVariables(const StartPos,
1705 EndPos: TCodeXYPosition; out BlockStartPos, BlockEndPos: integer;
1706 out BlockNode: TCodeTreeNode;
1707 VarTree: TAVLTree; // tree of TExtractedProcVariable
1708 IgnoreIdentifiers: TAVLTree; // tree of PCodeXYPosition
1709 MissingIdentifiers: TAVLTree// tree of PCodeXYPosition
1710 ): boolean;
1711 type
1712 TParameterType = (ptNone, ptConst, ptVar, ptOut, ptNoSpecifier);
1713 var
1714 {$IFDEF CTDebug}
1715 s: string;
1716 {$ENDIF}
1717 VarCandidates: TAVLTree; // tree of PChar
1718
1719 procedure ScanForLocalVariables(Node: TCodeTreeNode);
1720 begin
1721 if Node=nil then exit;
1722 if Node.Desc=ctnVarDefinition then begin
1723 VarCandidates.Add(@Src[Node.StartPos]);
1724 end;
1725 Node:=Node.FirstChild;
1726 while Node<>nil do begin
1727 ScanForLocalVariables(Node);
1728 Node:=Node.NextBrother;
1729 end;
1730 end;
1731
1732 procedure AddVariableToTree(VarNode: TCodeTreeNode; IsInSelection,
1733 IsAfterSelection, IsChanged: boolean; ParameterType: TParameterType);
1734 var
1735 AVLNode: TAVLTreeNode;
1736 ProcVar: TExtractedProcVariable;
1737 begin
1738 {$IFDEF CTDebug}
1739 WriteStr(s, ParameterType);
1740 DebugLn(['AddVariableToTree A Ident=',GetIdentifier(@Src[VarNode.StartPos]),
1741 ' IsInSelection=',dbgs(IsInSelection),' ParameterType=',s]);
1742 {$ENDIF}
1743 if VarTree=nil then exit;
1744
1745 AVLNode:=VarTree.FindKey(VarNode,TListSortCompare(@CompareNodeWithExtractedProcVariable));
1746 if AVLNode<>nil then begin
1747 ProcVar:=TExtractedProcVariable(AVLNode.Data);
1748 end else begin
1749 ProcVar:=TExtractedProcVariable.Create;
1750 ProcVar.Node:=VarNode;
1751 ProcVar.Tool:=Self;
1752 end;
1753 ProcVar.ReadInSelection:=ProcVar.ReadInSelection or IsInSelection;
1754 ProcVar.WriteInSelection:=ProcVar.WriteInSelection
1755 or (IsInSelection and IsChanged);
1756 ProcVar.UsedInNonSelection:=ProcVar.UsedInNonSelection
1757 or (not IsInSelection) or (ParameterType<>ptNone);
1758 if (not ProcVar.ReadAfterSelectionValid) then begin
1759 // a) variable is a var or out parameter
1760 // => the variable value IS needed after the extracted proc
1761 // b) just after the selection the variable is read
1762 // => the variable value IS needed after the extracted proc
1763 // c) just after the selection the variable is written
1764 // => the variable value IS NOT needed after the extracted proc
1765 if (ParameterType in [ptOut,ptVar]) then begin
1766 ProcVar.ReadAfterSelectionValid:=true;
1767 ProcVar.ReadAfterSelection:=true;
1768 end else if (not IsInSelection) and IsAfterSelection then begin
1769 ProcVar.ReadAfterSelectionValid:=true;
1770 ProcVar.ReadAfterSelection:=not IsChanged;
1771 end;
1772 end;
1773 if AVLNode=nil then begin
1774 if ParameterType<>ptNone then
1775 ProcVar.VarType:=epvtParameter
1776 else
1777 ProcVar.VarType:=epvtLocalVar;
1778 VarTree.Add(ProcVar);
1779 end;
1780 end;
1781
VariableIsChangednull1782 function VariableIsChanged(VarStartPos: integer): boolean;
1783 begin
1784 Result:=false;
1785 MoveCursorToCleanPos(VarStartPos);
1786 // read identifier
1787 ReadNextAtom;
1788 if CurPos.Flag in [cafRoundBracketOpen] then
1789 ReadTilBracketClose(true);
1790 // read next atom
1791 ReadNextAtom;
1792 if AtomIs(':=') or AtomIs('+=') or AtomIs('-=') or AtomIs('*=')
1793 or AtomIs('/=') then begin
1794 Result:=true;
1795 exit;
1796 end;
1797 end;
1798
CheckVariableAtCursornull1799 function CheckVariableAtCursor: boolean;
1800 // find declaration of identifier at cursor and add to variable tree
1801 var
1802 Params: TFindDeclarationParams;
1803 VarStartPos: Integer;
1804 VarNode: TCodeTreeNode;
1805 IsInSelection: Boolean;
1806 ClosestProcNode: TCodeTreeNode;
1807 IsParameter: boolean;
1808 IsChanged: Boolean;
1809 IsAfterSelection: Boolean;
1810 ParameterType: TParameterType;
1811 NewCodePos: TCodeXYPosition;
1812 begin
1813 Result:=false;
1814
1815 // check if there is a local variable with this name
1816 if VarCandidates.Find(@Src[CurPos.StartPos])=nil then exit(true);
1817
1818 // now do a real search
1819
1820 // find start of variable
1821 VarStartPos:=FindStartOfTerm(CurPos.StartPos,false);
1822 if (IgnoreIdentifiers<>nil) then begin
1823 if not CleanPosToCaret(VarStartPos,NewCodePos) then exit;
1824 if IgnoreIdentifiers.Find(@NewCodePos)<>nil then exit(true);
1825 end;
1826
1827 IsInSelection:=(VarStartPos>=BlockStartPos) and (VarStartPos<BlockEndPos);
1828 IsAfterSelection:=(VarStartPos>=BlockEndPos);
1829 MoveCursorToCleanPos(VarStartPos);
1830 VarNode:=FindDeepestNodeAtPos(VarStartPos,true);
1831 Params:=TFindDeclarationParams.Create(Self, VarNode);
1832 try
1833 // find declaration
1834 Params.ContextNode:=VarNode;
1835 Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound,
1836 fdfTopLvlResolving,fdfSearchInAncestors,fdfSearchInHelpers];
1837 Params.SetIdentifier(Self,@Src[VarStartPos],@CheckSrcIdentifier);
1838 {$IFDEF CTDebug}
1839 DebugLn('AddVariableAtCursor Searching ',GetIdentifier(Params.Identifier));
1840 {$ENDIF}
1841 try
1842 FindDeclarationOfIdentAtParam(Params);
1843 except
1844 on E: ECodeToolError do begin
1845 {$IFDEF CTDebug}
1846 DebugLn('AddVariableAtCursor identifier not found ',GetIdentifier(@Src[VarStartPos]));
1847 {$ENDIF}
1848 if MissingIdentifiers=nil then
1849 raise;
1850 // collect missing identifiers
1851 if not CleanPosToCaret(VarStartPos,NewCodePos) then exit;
1852 AddCodePosition(MissingIdentifiers,NewCodePos);
1853 Result:=true;
1854 exit;
1855 end;
1856 end;
1857 // check if declaration is local variable
1858 if (Params.NewCodeTool=Self) and (Params.NewNode<>nil) then begin
1859 VarNode:=Params.NewNode;
1860 if (VarNode.Desc=ctnVarDefinition)
1861 and (VarNode.HasAsParent(BlockNode)) then begin
1862 // Now we know: VarNode is a variable defined in the main proc
1863 // or one of its sub procs
1864 ClosestProcNode:=VarNode.GetNodeOfType(ctnProcedure);
1865 if ClosestProcNode=BlockNode then begin
1866 // VarNode is a variable defined by the main proc
1867 IsParameter:=VarNode.GetNodeOfType(ctnProcedureHead)<>nil;
1868 ParameterType:=ptNone;
1869 if IsParameter then begin
1870 MoveCursorToParameterSpecifier(VarNode);
1871 if UpAtomIs('CONST') then
1872 ParameterType:=ptConst
1873 else if UpAtomIs('VAR') then
1874 ParameterType:=ptVar
1875 else if UpAtomIs('OUT') and (cmsOut in Scanner.CompilerModeSwitches) then
1876 ParameterType:=ptOut
1877 else
1878 ParameterType:=ptNoSpecifier;
1879 end;
1880 IsChanged:=VariableIsChanged(VarStartPos);
1881 AddVariableToTree(VarNode,IsInSelection,IsAfterSelection,IsChanged,
1882 ParameterType);
1883 end;
1884 end;
1885 end;
1886 finally
1887 Params.Free;
1888 end;
1889 Result:=true;
1890 end;
1891
ScanSourceForVariablesnull1892 function ScanSourceForVariables(CleanStartPos, CleanEndPos: integer): boolean;
1893 // scan part of the source for variables
1894 var
1895 LastAtomType: TCommonAtomFlag;
1896 OldCursor: Integer;
1897 begin
1898 Result:=false;
1899 {$IFDEF CTDebug}
1900 DebugLn('TExtractProcTool.ScanSourceForVariables A "',copy(Src,CleanStartPos,CleanEndPos-CleanStartPos),'"');
1901 {$ENDIF}
1902 MoveCursorToNearestAtom(CleanStartPos);
1903 while CurPos.StartPos<CleanEndPos do begin
1904 LastAtomType:=CurPos.Flag;
1905 ReadNextAtom;
1906 if AtomIsIdentifier and (LastAtomType<>cafPoint) then begin
1907 // this could be the start of a variable -> check
1908 {$IFDEF CTDebug}
1909 DebugLn('ScanSourceForVariables B Identifier=',GetAtom);
1910 {$ENDIF}
1911 OldCursor:=CurPos.StartPos;
1912 if not CheckVariableAtCursor then exit;
1913 // restore cursor
1914 MoveCursorToCleanPos(OldCursor);
1915 ReadNextAtom;
1916 end;
1917 end;
1918 Result:=true;
1919 end;
1920
ScanNodesForVariablesRecursivenull1921 function ScanNodesForVariablesRecursive(StartNode: TCodeTreeNode): boolean;
1922 // scan recursively all statements for variables
1923 var
1924 ChildNode: TCodeTreeNode;
1925 begin
1926 {$IFDEF CTDebug}
1927 DebugLn('ScanNodesForVariablesRecursive A Node=',StartNode.DescAsString);
1928 {$ENDIF}
1929 Result:=false;
1930 ChildNode:=StartNode.FirstChild;
1931 while ChildNode<>nil do begin
1932 if (ChildNode.Desc in [ctnBeginBlock,ctnAsmBlock]) then begin
1933 if not ScanSourceForVariables(ChildNode.StartPos,ChildNode.EndPos) then
1934 exit;
1935 end else if not ScanNodesForVariablesRecursive(ChildNode) then
1936 exit;
1937 ChildNode:=ChildNode.NextBrother;
1938 end;
1939 Result:=true;
1940 end;
1941
1942 begin
1943 Result:=false;
1944 ActivateGlobalWriteLock;
1945 VarCandidates:=TAVLTree.Create(@CompareIdentifierPtrs);
1946 try
1947 if CaretToCleanPos(StartPos,BlockStartPos)<>0 then exit;
1948 if CaretToCleanPos(EndPos,BlockEndPos)<>0 then exit;
1949 BuildSubTree(BlockStartPos);
1950 BlockNode:=FindDeepestNodeAtPos(BlockStartPos,true);
1951 while BlockNode<>nil do begin
1952 if BlockNode.Desc in [ctnInitialization,ctnFinalization,ctnProcedure]
1953 then break;
1954 if (BlockNode.Desc=ctnBeginBlock)
1955 and (BlockNode.Parent.Desc in AllSourceTypes) then
1956 break;
1957 BlockNode:=BlockNode.Parent;
1958 end;
1959
1960 if BlockNode=nil then begin
1961 debugln(['TExtractProcTool.ScanNodesForVariables invalid context ',FindDeepestNodeAtPos(BlockStartPos,false).DescAsString]);
1962 exit;
1963 end;
1964
1965 // collect local variables to speed up search
1966 ScanForLocalVariables(BlockNode);
1967
1968 if not ScanNodesForVariablesRecursive(BlockNode) then exit;
1969 finally
1970 VarCandidates.Free;
1971 DeactivateGlobalWriteLock;
1972 end;
1973 Result:=true;
1974 end;
1975
CheckIfRangeOnSameLevelnull1976 function TExtractCodeTool.CheckIfRangeOnSameLevel(const StartPos,
1977 EndPos: TCodeXYPosition; out CleanStartPos, CleanEndPos: integer; out
1978 StartNode: TCodeTreeNode): boolean;
1979 var
1980 BeginBlockNode: TCodeTreeNode;
1981 BlockCleanStart: Integer;
1982 BlockCleanEnd: Integer;
1983 begin
1984 Result:=false;
1985 {$IFDEF CTDebug}
1986 DebugLn('TExtractProcTool.CheckIfRangeOnSameLevel syntax and cursor check ..');
1987 {$ENDIF}
1988 CleanStartPos:=0;
1989 CleanEndPos:=0;
1990 StartNode:=nil;
1991 // check syntax
1992 BuildTreeAndGetCleanPos(StartPos,CleanStartPos);
1993 if CaretToCleanPos(EndPos,CleanEndPos)<>0 then exit;
1994 if CleanStartPos>=CleanEndPos then exit;
1995 {$IFDEF CTDebug}
1996 debugln('TExtractProcTool.CheckIfRangeOnSameLevel Selection="',copy(Src,CleanStartPos,CleanEndPos-CleanStartPos),'"');
1997 DebugLn('TExtractProcTool.CheckIfRangeOnSameLevel node check ..');
1998 {$ENDIF}
1999 // check if in a Begin..End block
2000 StartNode:=FindDeepestNodeAtPos(CleanStartPos,true);
2001 if StartNode=nil then exit;
2002 BeginBlockNode:=StartNode.GetNodeOfType(ctnBeginBlock);
2003 if BeginBlockNode=nil then exit;
2004 {$IFDEF CTDebug}
2005 DebugLn('TExtractProcTool.CheckIfRangeOnSameLevel Start/End check ..');
2006 {$ENDIF}
2007 // check if Start and End on same block level
2008 MoveCursorToNodeStart(StartNode);
2009 // check every block in selection
2010 while true do begin
2011 ReadNextAtom;
2012 if (CurPos.EndPos>CleanEndPos) or (CurPos.StartPos>SrcLen)
2013 or (CurPos.StartPos>StartNode.EndPos) then
2014 exit(true);
2015 //debugln('TExtractProcTool.CheckIfRangeOnSameLevel A "',GetAtom,'"');
2016 if WordIsBlockStatementStart.DoItCaseInsensitive(Src,
2017 CurPos.StartPos,CurPos.EndPos-CurPos.StartPos)
2018 then begin
2019 //debugln('TExtractProcTool.CheckIfRangeOnSameLevel WordIsBlockStatementStart "',GetAtom,'"');
2020 BlockCleanStart:=CurPos.StartPos;
2021 if not ReadTilBlockStatementEnd(true) then exit;
2022 BlockCleanEnd:=CurPos.EndPos;
2023 //debugln(copy(Src,BlockCleanStart,BlockCleanEnd-BlockCleanStart));
2024 //debugln('TExtractProcTool.CheckIfRangeOnSameLevel BlockEnd "',GetAtom,'" BlockCleanEnd=',dbgs(BlockCleanEnd),' CleanEndPos=',dbgs(CleanEndPos),' Result=',dbgs(Result),' BlockStartedInside=',dbgs(BlockCleanStart>=CleanStartPos));
2025 if BlockCleanStart<CleanStartPos then begin
2026 // this block started outside the selection
2027 // -> it should end outside
2028 if (BlockCleanEnd>=CleanStartPos) and (BlockCleanEnd<CleanEndPos) then
2029 begin
2030 // block overlaps selection
2031 exit;
2032 end;
2033 if BlockCleanEnd>=CleanEndPos then begin
2034 // set cursor back to block start
2035 MoveCursorToCleanPos(BlockCleanStart);
2036 ReadNextAtom;
2037 end;
2038 end else begin
2039 // this block started inside the selection
2040 // -> it should end inside
2041 if (BlockCleanEnd>CleanEndPos) then begin
2042 // block overlaps selection
2043 exit;
2044 end;
2045 end;
2046 //debugln('TExtractProcTool.CheckIfRangeOnSameLevel Block ok');
2047 end
2048 else if WordIsBlockStatementEnd.DoItCaseInsensitive(Src,
2049 CurPos.StartPos,CurPos.EndPos-CurPos.StartPos)
2050 then begin
2051 // a block ended inside, that started outside
2052 exit;
2053 end
2054 else if WordIsBlockStatementMiddle.DoItCaseInsensitive(Src,
2055 CurPos.StartPos,CurPos.EndPos-CurPos.StartPos)
2056 then begin
2057 // a block ended inside, that started outside
2058 exit;
2059 end;
2060 end;
2061 end;
2062
2063 end.
2064
2065