paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-23 01:19:37 +02:00
Code Issues Packages Projects Releases Wiki Activity

codetools: added RetypeClassVariables

Browse Source 
git-svn-id: trunk@24215 -
This commit is contained in:
mattias 2010-03-25 21:16:32 +00:00
parent fd3fbf3d4a
commit a74bc652d2
6 changed files with 260 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -476,6 +476,8 @@ components/codetools/examples/removeemptymethods.lpi svneol=native#text/plain
components/codetools/examples/removeemptymethods.lpr svneol=native#text/plain
components/codetools/examples/replaceresourcedirectives.lpi svneol=native#text/plain
components/codetools/examples/replaceresourcedirectives.lpr svneol=native#text/plain
components/codetools/examples/retypepublishedvars.lpi svneol=native#text/plain
components/codetools/examples/retypepublishedvars.lpr svneol=native#text/plain
components/codetools/examples/scanexamples/BigLettersUnit.pas svneol=native#text/plain
components/codetools/examples/scanexamples/abstractclass1.pas svneol=native#text/plain
components/codetools/examples/scanexamples/addeventexample.pas svneol=native#text/plain
@ -491,6 +493,7 @@ components/codetools/examples/scanexamples/methodjump1.pas svneol=native#text/pl
components/codetools/examples/scanexamples/missingh2pasdirectives.pas svneol=native#text/plain
components/codetools/examples/scanexamples/modemacpas.pas svneol=native#text/plain
components/codetools/examples/scanexamples/overloadedfunction.pas svneol=native#text/plain
components/codetools/examples/scanexamples/publishedvars.pas svneol=native#text/plain
components/codetools/examples/scanexamples/resourcetest1.pas svneol=native#text/plain
components/codetools/examples/scanexamples/simpleunit1.pas svneol=native#text/plain
components/codetools/examples/scanexamples/test.h svneol=native#text/plain

19
components/codetools/codetoolmanager.pas
View File

@ -662,6 +662,8 @@ type
function RenamePublishedVariable(Code: TCodeBuffer;
const AClassName, OldVariableName, NewVarName,
VarType: shortstring; ErrorOnClassNotFound: boolean): boolean;
function RetypeClassVariables(Code: TCodeBuffer; const AClassName: string;
ListOfReTypes: TStrings; ErrorOnClassNotFound: boolean): boolean;
function FindDanglingComponentEvents(Code: TCodeBuffer;
const AClassName: string;
RootComponent: TComponent; ExceptionOnClassNotFound,
@ -4606,6 +4608,23 @@ begin
end;
end;
function TCodeToolManager.RetypeClassVariables(Code: TCodeBuffer;
const AClassName: string; ListOfReTypes: TStrings;
ErrorOnClassNotFound: boolean): boolean;
begin
Result:=false;
{$IFDEF CTDEBUG}
DebugLn('TCodeToolManager.RetypeClassVariables A ',Code.Filename,' ',AClassName);
{$ENDIF}
if not InitCurCodeTool(Code) then exit;
try
Result:=FCurCodeTool.RetypeClassVariables(AClassName,ListOfReTypes,
ErrorOnClassNotFound,SourceChangeCache);
except
on e: Exception do Result:=HandleException(e);
end;
end;
function TCodeToolManager.FindDanglingComponentEvents(Code: TCodeBuffer;
const AClassName: string; RootComponent: TComponent;
ExceptionOnClassNotFound, SearchInAncestors: boolean;

59
components/codetools/examples/retypepublishedvars.lpi Normal file
View File

@ -0,0 +1,59 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="7"/>
<General>
<Flags>
<LRSInOutputDirectory Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<TargetFileExt Value=""/>
<Title Value="finddeclaration"/>
</General>
<VersionInfo>
<StringTable Comments="" CompanyName="" FileDescription="" FileVersion="0.0.0.0" InternalName="" LegalCopyright="" LegalTrademarks="" OriginalFilename="" ProductName="" ProductVersion="0.0.0.0"/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="CodeTools"/>
</Item1>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="retypepublishedvars.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="retypepublishedvars"/>
</Unit0>
<Unit1>
<Filename Value="scanexamples/emptymethods1.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="EmptyMethods1"/>
</Unit1>
<Unit2>
<Filename Value="README.txt"/>
<IsPartOfProject Value="True"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="8"/>
<SearchPaths>
<OtherUnitFiles Value="scanexamples/"/>
</SearchPaths>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

80
components/codetools/examples/retypepublishedvars.lpr Normal file
View File

@ -0,0 +1,80 @@
{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Abstract:
Demonstrates how to change the types of the variables of a class.
}
program retypepublishedvars;
{$mode objfpc}{$H+}
uses
Classes, SysUtils, CodeCache, CodeToolManager, DefineTemplates,
CodeAtom, CodeToolsConfig, CodeToolsStructs, PascalParserTool;
const
ConfigFilename = 'codetools.config';
var
Code: TCodeBuffer;
Filename: String;
ListOfTypes: TStringList;
begin
if (ParamCount>=1) and (Paramcount<>3) then begin
writeln('Usage:');
writeln(' ',ParamStr(0));
writeln(' ',ParamStr(0),' <filename.pas>');
end;
try
CodeToolBoss.SimpleInit(ConfigFilename);
Filename:=ExpandFileName('scanexamples'+PathDelim+'publishedvars.pas');
if (ParamCount>=3) then begin
Filename:=ExpandFileName(ParamStr(1));
end;
// Step 1: load the file
Code:=CodeToolBoss.LoadFile(Filename,false,false);
if Code=nil then
raise Exception.Create('loading failed '+Filename);
// complete code
ListOfTypes:=TStringList.Create;
ListOfTypes.Values['TExButton']:='TButton';
ListOfTypes.Values['TExEdit']:='TEdit';
if CodeToolBoss.RetypeClassVariables(Code,'TForm1',ListOfTypes,true)
then begin
writeln('Sucess:');
writeln('=========================');
writeln(Code.Source);
writeln('=========================');
end else begin
writeln('RetypeClassVariables failed: ',CodeToolBoss.ErrorMessage);
end;
except
on E: Exception do begin
writeln('EXCEPTION: '+E.Message);
end;
end;
end.

22
components/codetools/examples/scanexamples/publishedvars.pas Normal file
View File

@ -0,0 +1,22 @@
unit publishedvars;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TExButton;
Button3: TExButton;
Edit1: TExEdit;
public
end;
implementation
end.

77
components/codetools/stdcodetools.pas
View File

@ -187,6 +187,9 @@ type
ExceptionOnClassNotFound, WithVariables, WithMethods,
WithProperties, WithAncestors: boolean;
out TreeOfCodeTreeNodeExtension: TAVLTree): boolean;
function RetypeClassVariables(const AClassName: string;
ListOfTypes: TStrings; ExceptionOnClassNotFound: boolean;
SourceChangeCache: TSourceChangeCache): boolean;
function FindDanglingComponentEvents(const TheClassName: string;
RootComponent: TComponent; ExceptionOnClassNotFound,
SearchInAncestors: boolean;
@ -4901,6 +4904,80 @@ begin
Result:=true;
end;
function TStandardCodeTool.RetypeClassVariables(const AClassName: string;
ListOfTypes: TStrings; ExceptionOnClassNotFound: boolean;
SourceChangeCache: TSourceChangeCache): boolean;
var
ClassNode: TCodeTreeNode;
Node: TCodeTreeNode;
TypeNode: TCodeTreeNode;
i: Integer;
OldToNew: TStringToStringTree;
OldType: String;
NewType: string;
HasChanged: Boolean;
begin
Result:=false;
BuildTree(true);
ClassNode:=FindClassNodeInInterface(AClassName,true,false,false);
if ClassNode=nil then begin
if ExceptionOnClassNotFound then
RaiseException(Format(ctsclassNotFound, ['"', AClassName, '"']))
else
exit;
end;
if (ListOfTypes=nil) or (ListOfTypes.Count=0) then exit(true);
OldToNew:=TStringToStringTree.Create(false);
try
for i:=0 to ListOfTypes.Count-1 do
OldToNew.Add(ListOfTypes.Names[i],ListOfTypes.ValueFromIndex[i]);
HasChanged:=false;
BuildSubTreeForClass(ClassNode);
Node:=ClassNode.FirstChild;
while (Node<>nil) and (Node.HasAsParent(ClassNode)) do begin
if (Node.Desc=ctnVarDefinition) and (Node.FirstChild<>nil) then begin
TypeNode:=Node.FirstChild;
if TypeNode.Desc=ctnIdentifier then begin
MoveCursorToNodeStart(TypeNode);
ReadNextAtom;
ReadNextAtom;
if CurPos.Flag=cafPoint then begin
// skip unitname
ReadNextAtom;
end else begin
UndoReadNextAtom;
end;
// cursor is now on identifier
OldType:=GetAtom;
if OldToNew.Contains(OldType) then begin
NewType:=OldToNew[OldType];
if OldType<>NewType then begin
// change type
if not HasChanged then begin
HasChanged:=true;
SourceChangeCache.MainScanner:=Scanner;
end;
if not SourceChangeCache.Replace(gtNone,gtNone,
CurPos.StartPos,CurPos.EndPos,NewType) then exit(false);
end;
end;
end;
Node:=Node.NextSkipChilds;
end else
Node:=Node.Next;
end;
if HasChanged then begin
if not SourceChangeCache.Apply then exit;
end;
finally
OldToNew.Free;
end;
Result:=true;
end;
function TStandardCodeTool.FindDanglingComponentEvents(
const TheClassName: string; RootComponent: TComponent;
ExceptionOnClassNotFound, SearchInAncestors: boolean;