{ *************************************************************************** * * * 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 . You can also * * obtain it by writing to the Free Software Foundation, * * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * * * *************************************************************************** Author: Juha Manninen Abstract: Methods that use and extend codetools features. Needed by Delphi converter. Some of these methods could be made part of codetools. } unit ConvCodeTool; {$mode objfpc}{$H+} interface uses // LCL+FCL Classes, SysUtils, FileProcs, Forms, Controls, DialogProcs, Dialogs, contnrs, strutils, // IDE LazarusIDEStrConsts, LazIDEIntf, FormEditor, IDEMsgIntf, // codetools CodeToolManager, StdCodeTools, CodeTree, CodeAtom, AVL_Tree, FindDeclarationTool, PascalReaderTool, PascalParserTool, LFMTrees, ExprEval, KeywordFuncLists, BasicCodeTools, LinkScanner, CodeCache, SourceChanger, CustomCodeTool, CodeToolsStructs, EventCodeTool, // Converter ConverterTypes, ConvertSettings, ReplaceNamesUnit, ReplaceFuncsUnit; type { TCodeToolLink } TCodeToolLink = class private protected fCodeTool: TCodeTool; fCode: TCodeBuffer; fSrcCache: TSourceChangeCache; fAskAboutError: Boolean; fSettings: TConvertSettings; // Conversion settings. procedure InitCodeTool; function HandleCodetoolError: TModalResult; public constructor Create(ACode: TCodeBuffer); destructor Destroy; override; procedure ResetMainScanner; public property CodeTool: TCodeTool read fCodeTool; property Code: TCodeBuffer read fCode; property SrcCache: TSourceChangeCache read fSrcCache; property AskAboutError: Boolean read fAskAboutError write fAskAboutError; property Settings: TConvertSettings read fSettings write fSettings; end; { TConvDelphiCodeTool } TConvDelphiCodeTool = class private fCTLink: TCodeToolLink; fIsConsoleApp: Boolean; fHasFormFile: boolean; fLowerCaseRes: boolean; fAddUnitEvent: TAddUnitEvent; // Delphi Function names to replace with FCL/LCL functions. fDefinedProcNames: TStringList; // List of TFuncReplacement. fFuncsToReplace: TObjectList; function AddModeDelphiDirective: boolean; function RenameResourceDirectives: boolean; function ReplaceFuncsInSource: boolean; function RememberProcDefinition(aNode: TCodeTreeNode): TCodeTreeNode; function ReplaceFuncCalls(aIsConsoleApp: boolean): boolean; public constructor Create(ACTLink: TCodeToolLink); destructor Destroy; override; function Convert: TModalResult; function FindApptypeConsole: boolean; function FixMainClassAncestor(const AClassName: string; AReplaceTypes: TStringToStringTree): boolean; public property IsConsoleApp: Boolean read fIsConsoleApp write fIsConsoleApp; property HasFormFile: boolean read fHasFormFile write fHasFormFile; property LowerCaseRes: boolean read fLowerCaseRes write fLowerCaseRes; property AddUnitEvent: TAddUnitEvent read fAddUnitEvent write fAddUnitEvent; end; implementation { TCodeToolLink } constructor TCodeToolLink.Create(ACode: TCodeBuffer); begin inherited Create; fCode:=ACode; fAskAboutError:=True; InitCodeTool; end; destructor TCodeToolLink.Destroy; begin inherited Destroy; end; procedure TCodeToolLink.InitCodeTool; begin // Initialize codetools. (Copied from TCodeToolManager.) if not CodeToolBoss.InitCurCodeTool(fCode) then exit; try fCodeTool:=CodeToolBoss.CurCodeTool; fSrcCache:=CodeToolBoss.SourceChangeCache; ResetMainScanner; except on e: Exception do CodeToolBoss.HandleException(e); end; end; procedure TCodeToolLink.ResetMainScanner; begin fSrcCache.MainScanner:=fCodeTool.Scanner; end; function TCodeToolLink.HandleCodetoolError: TModalResult; // returns mrOk or mrAbort const CodetoolsFoundError='The codetools found an error in unit %s:%s%s%s'; var ErrMsg: String; begin ErrMsg:=CodeToolBoss.ErrorMessage; LazarusIDE.DoJumpToCodeToolBossError; if fAskAboutError then begin Result:=QuestionDlg(lisCCOErrorCaption, Format(CodetoolsFoundError, [ExtractFileName(fCode.Filename), #13, ErrMsg, #13]), mtWarning, [mrIgnore, lisIgnoreAndContinue, mrAbort], 0); if Result=mrIgnore then Result:=mrOK; end else begin Result:=mrOK; end; end; { TConvDelphiCodeTool } constructor TConvDelphiCodeTool.Create(ACTLink: TCodeToolLink); begin inherited Create; fCTLink:=ACTLink; fLowerCaseRes:=False; fIsConsoleApp:=False; end; destructor TConvDelphiCodeTool.Destroy; begin inherited Destroy; end; function TConvDelphiCodeTool.Convert: TModalResult; // add {$mode delphi} directive // remove {$R *.dfm} or {$R *.xfm} directive // Change {$R *.RES} to {$R *.res} if needed // TODO: fix delphi ambiguouties like incomplete proc implementation headers begin Result:=mrCancel; try fCTLink.SrcCache.BeginUpdate; try // these changes can be applied together without rescan if not AddModeDelphiDirective then exit; if not RenameResourceDirectives then exit; if fCTLink.Settings.FuncReplaceMode=rsEnabled then if not ReplaceFuncCalls(fIsConsoleApp) then exit; finally fCTLink.SrcCache.EndUpdate; end; Result:=mrOK; except on e: Exception do begin CodeToolBoss.HandleException(e); Result:=fCTLink.HandleCodetoolError; end; end; end; function TConvDelphiCodeTool.FindApptypeConsole: boolean; // Return true if there is {$APPTYPE CONSOLE} directive. var ParamPos, ACleanPos: Integer; begin Result:=false; ACleanPos:=0; with fCTLink.CodeTool do begin BuildTree(lsrImplementationStart); ACleanPos:=FindNextCompilerDirectiveWithName(Src, 1, 'Apptype', Scanner.NestedComments, ParamPos); if (ACleanPos>0) and (ACleanPos<=SrcLen) and (ParamPos>0) then Result:=LowerCase(copy(Src,ParamPos,7))='console'; end; end; function TConvDelphiCodeTool.AddModeDelphiDirective: boolean; var ModeDirectivePos: integer; InsertPos: Integer; s: String; begin Result:=false; with fCTLink.CodeTool do begin if not FindModeDirective(true,ModeDirectivePos) then begin // add {$MODE Delphi} behind source type if Tree.Root=nil then exit; MoveCursorToNodeStart(Tree.Root); ReadNextAtom; // 'unit', 'program', .. ReadNextAtom; // name ReadNextAtom; // semicolon InsertPos:=CurPos.EndPos; if fCTLink.Settings.SupportDelphi then s:='{$IFDEF FPC}'+LineEnding+' {$MODE Delphi}'+LineEnding+'{$ENDIF}' else s:='{$MODE Delphi}'; fCTLink.SrcCache.Replace(gtEmptyLine,gtEmptyLine,InsertPos,InsertPos,s); end; // changing mode requires rescan BuildTree(lsrEnd); end; Result:=true; end; function TConvDelphiCodeTool.RenameResourceDirectives: boolean; // rename {$R *.dfm} directive to {$R *.lfm}, or lowercase it. // lowercase {$R *.RES} to {$R *.res} var ParamPos, ACleanPos: Integer; Key, LowKey, NewKey: String; s: string; begin Result:=false; ACleanPos:=1; // find $R directive with fCTLink.CodeTool do repeat ACleanPos:=FindNextCompilerDirectiveWithName(Src, ACleanPos, 'R', Scanner.NestedComments, ParamPos); if (ACleanPos<1) or (ACleanPos>SrcLen) or (ParamPos>SrcLen-6) then break; NewKey:=''; if (Src[ACleanPos]='{') and (Src[ParamPos]='*') and (Src[ParamPos+1]='.') and (Src[ParamPos+5]='}') then begin Key:=copy(Src,ParamPos+2,3); LowKey:=LowerCase(Key); // Form file resource rename or lowercase: if (LowKey='dfm') or (LowKey='xfm') then begin if fCTLink.Settings.SupportDelphi then begin // Use the same dfm file. Lowercase existing key. if fCTLink.Settings.SameDfmFile then begin if Key<>LowKey then NewKey:=LowKey; end else begin // Add IFDEF for .lfm and .dfm allowing Delphi to use .dfm. s:='{$IFNDEF FPC}'+LineEnding+ ' {$R *.dfm}'+LineEnding+ '{$ELSE}'+LineEnding+ ' {$R *.lfm}'+LineEnding+ '{$ENDIF}'; Result:=fCTLink.SrcCache.Replace(gtNone,gtNone,ACleanPos,ParamPos+6,s); end; end else // Change .dfm to .lfm. NewKey:='lfm'; end // lowercase {$R *.RES} to {$R *.res} else if (Key='RES') and fLowerCaseRes then NewKey:=LowKey; // Change a single resource name. if NewKey<>'' then begin if not fCTLink.SrcCache.Replace(gtNone,gtNone,ParamPos+2,ParamPos+5,NewKey) then exit; end; end; ACleanPos:=FindCommentEnd(Src, ACleanPos, Scanner.NestedComments); until false; Result:=true; end; function TConvDelphiCodeTool.FixMainClassAncestor(const AClassName: string; AReplaceTypes: TStringToStringTree): boolean; // Replace the ancestor type of main form with a fall-back type if needed. var ANode, InheritanceNode: TCodeTreeNode; TypeUpdater: TStringMapUpdater; OldType, NewType: String; begin Result:=false; with fCTLink.CodeTool do begin BuildTree(lsrImplementationStart); // Find the class name that the main class inherits from. ANode:=FindClassNodeInUnit(AClassName,true,false,false,false); if ANode=nil then exit; InheritanceNode:=FindInheritanceNode(ANode); if InheritanceNode=nil then exit; ANode:=InheritanceNode.FirstChild; if ANode=nil then exit; if ANode.Desc=ctnIdentifier then begin MoveCursorToNodeStart(ANode); // cursor to the identifier ReadNextAtom; OldType:=GetAtom; end; TypeUpdater:=TStringMapUpdater.Create(AReplaceTypes); try // Find replacement for ancestor type maybe using regexp syntax. if TypeUpdater.FindReplacement(OldType, NewType) then begin fCTLink.ResetMainScanner; if not fCTLink.SrcCache.Replace(gtNone, gtNone, CurPos.StartPos, CurPos.EndPos, NewType) then exit; if not fCTLink.SrcCache.Apply then exit; end; finally TypeUpdater.Free; end; end; Result:=true; end; function TConvDelphiCodeTool.ReplaceFuncsInSource: boolean; // Replace the function names and parameters in source. var ReplacementParams: TObjectList; // Replacement parameters. function ParseReplacementParams(const aStr: string): integer; // Parse replacement params. They show which original params are copied where. // Returns the first position where comments can be searched from. var i, xNum, xStart, xLen: Integer; begin i:=0; while i= 1.'); ReplacementParams.Add(TReplacementParam.Create(xNum, xLen, xStart)); end; end; if aStr[i]<>')' then raise EDelphiConverterError.Create('")" is missing from replacement function.'); Result:=i+1; end; function InsertParams2Replacement(FuncInfo: TFuncReplacement): string; // Construct a new funcion call, inserting original parameters to replacement str. // FuncInfo - Replacement string + parameters from the original function call. var RP: TReplacementParam; ss, se: String; i: integer; begin Result:=FuncInfo.ReplFunc; for i:=ReplacementParams.Count-1 downto 0 do begin RP:=TReplacementParam(ReplacementParams[i]); if RP.ParamNum<=FuncInfo.Params.Count then begin ss:=copy(Result, 1, RP.StrPosition-1); // String before the param se:=copy(Result, RP.StrPosition+RP.ParamLen, MaxInt); // and after it. Result:=ss+FuncInfo.Params[RP.ParamNum-1]+se; end; end; end; function GetComment(const aStr: string; aPossibleStartPos: integer): string; // Extract and return a possible comment. var CommChBeg, CommBeg, CommEnd, i: Integer; // Start and end of comment. begin Result:=''; CommEnd:=Length(aStr); CommChBeg:=PosEx('//', aStr, aPossibleStartPos); if CommChBeg<>0 then CommBeg:=CommChBeg+2 else begin CommChBeg:=PosEx('{', aStr, aPossibleStartPos); if CommChBeg<>0 then begin CommBeg:=CommChBeg+1; i:=PosEx('}', aStr, CommBeg); if i<>0 then CommEnd:=i-1; end; end; if CommChBeg<>0 then Result:=Trim(Copy(aStr, CommBeg, CommEnd-CommBeg+1)); end; var FuncInfo: TFuncReplacement; PossibleCommentPos: Integer; // Start looking for comments here. i: Integer; s, NewFunc, Comment: String; begin Result:=false; ReplacementParams:=TObjectList.Create; try // Replace from bottom to top. for i:=fFuncsToReplace.Count-1 downto 0 do begin FuncInfo:=TFuncReplacement(fFuncsToReplace[i]); // Update ReplacementParams. ReplacementParams.Clear; PossibleCommentPos:=ParseReplacementParams(FuncInfo.ReplFunc); // Replace only if the params match somehow, so eg. a variable is not replaced. if (FuncInfo.Params.Count>0) or (ReplacementParams.Count=0) then begin NewFunc:=InsertParams2Replacement(FuncInfo); Comment:=GetComment(FuncInfo.ReplFunc, PossibleCommentPos); // Separate function body NewFunc:=Format('%s%s { *Converted from %s* %s }', [NewFunc, FuncInfo.InclSemiColon, FuncInfo.FuncName, Comment]); // Old function call with params for IDE message output. s:=copy(fCTLink.CodeTool.Src, FuncInfo.StartPos, FuncInfo.EndPos-FuncInfo.StartPos); s:=StringReplace(s, LineEnding, '', [rfReplaceAll]); // Now replace it. fCTLink.ResetMainScanner; if not fCTLink.SrcCache.Replace(gtNone, gtNone, FuncInfo.StartPos, FuncInfo.EndPos, NewFunc) then exit; IDEMessagesWindow.AddMsg('Replaced call '+s, '', -1); IDEMessagesWindow.AddMsg(' with '+NewFunc, '', -1); // Add the required unit name to uses section if needed. if Assigned(AddUnitEvent) and (FuncInfo.UnitName<>'') then AddUnitEvent(FuncInfo.UnitName); end; end; finally ReplacementParams.Free; end; Result:=true; end; function TConvDelphiCodeTool.RememberProcDefinition(aNode: TCodeTreeNode): TCodeTreeNode; // This is called when Node.Desc=ctnProcedureHead. // Save the defined proc name so it is not replaced later. var ProcName: string; begin with fCTLink.CodeTool do begin MoveCursorToCleanPos(aNode.StartPos); ReadNextAtom; // Read proc name. ProcName:=GetAtom; ReadNextAtom; if GetAtom<>'.' then // Don't save a method name (like TClass.Method). fDefinedProcNames.Add(ProcName); end; Result:=aNode.Next; end; function TConvDelphiCodeTool.ReplaceFuncCalls(aIsConsoleApp: boolean): boolean; // Copied and modified from TFindDeclarationTool.FindReferences. // Search for calls to functions / procedures in a list from current unit's // implementation section. Replace found calls with a given replacement. var xStart: Integer; procedure CheckSemiColon(FuncInfo: TFuncReplacement); begin with fCTLink.CodeTool do if AtomIsChar(';') then begin FuncInfo.EndPos:=CurPos.EndPos; FuncInfo.InclSemiColon:=';'; end; end; procedure ReadParams(FuncInfo: TFuncReplacement); var ExprStartPos, ExprEndPos, BracketCount: integer; begin FuncInfo.InclSemiColon:=''; FuncInfo.StartPos:=xStart; with fCTLink.CodeTool do begin MoveCursorToCleanPos(xStart); ReadNextAtom; // Read func name. ReadNextAtom; // Read first atom after proc name. if AtomIsChar('(') then begin // read parameter list ReadNextAtom; if not AtomIsChar(')') then begin // read all expressions BracketCount:=0; while true do begin ExprStartPos:=CurPos.StartPos; // read til comma or bracket close repeat ReadNextAtom; if (CurPos.StartPos>SrcLen) or (CurPos.Flag=cafComma) then break; if CurPos.Flag=cafRoundBracketOpen then Inc(BracketCount) else if CurPos.Flag=cafRoundBracketClose then begin if BracketCount=0 then break; Dec(BracketCount); end; until false; ExprEndPos:=CurPos.StartPos; // Add parameter to list FuncInfo.Params.Add(copy(Src,ExprStartPos,ExprEndPos-ExprStartPos)); MoveCursorToCleanPos(ExprEndPos); ReadNextAtom; if AtomIsChar(')') then begin FuncInfo.EndPos:=CurPos.EndPos; ReadNextAtom; CheckSemiColon(FuncInfo); break; end; if not AtomIsChar(',') then raise EDelphiConverterError.Create('Bracket not found'); ReadNextAtom; end; end; end else begin FuncInfo.EndPos:=CurPos.StartPos; CheckSemiColon(FuncInfo); end; end; FuncInfo.UpdateReplacement; end; procedure ReadFuncCall(MaxPos: Integer); var FuncDefInfo, FuncCallInfo: TFuncReplacement; FuncName: string; i, x, IdentEndPos: Integer; begin IdentEndPos:=xStart; with fCTLink.CodeTool, fCTLink.Settings do begin while (IdentEndPos<=MaxPos) and (IsIdentChar[Src[IdentEndPos]]) do inc(IdentEndPos); for i:=0 to ReplaceFuncs.Funcs.Count-1 do begin FuncName:=ReplaceFuncs.Funcs[i]; if (IdentEndPos-xStart=length(FuncName)) and (CompareIdentifiers(PChar(FuncName),@Src[xStart])=0) and not fDefinedProcNames.Find(FuncName, x) then begin FuncDefInfo:=ReplaceFuncs.FuncAtInd(i); if ReplaceFuncs.Categories.Find(FuncDefInfo.Category, x) // Categories.Objects[x] is used as a boolean flag. and Assigned(ReplaceFuncs.Categories.Objects[x]) // UTF8 funcs are in LCL which console apps don't have -> don't change. and not (aIsConsoleApp and (FuncDefInfo.Category='UTF8Names')) // Keep Windows funcs in a Windows application. and (fCTLink.Settings.MultiPlatform or (FuncDefInfo.Category<>'WindowsAPI')) then begin // Create a new replacement object for params, position and other info. FuncCallInfo:=TFuncReplacement.Create(FuncDefInfo); ReadParams(FuncCallInfo); IdentEndPos:=FuncCallInfo.EndPos; // Skip the params, too, for next search. fFuncsToReplace.Add(FuncCallInfo); Break; end; end; end; end; xStart:=IdentEndPos; end; function SearchFuncCalls(aNode: TCodeTreeNode): TCodeTreeNode; var CommentLvl: Integer; InStrConst: Boolean; begin xStart:=aNode.StartPos; with fCTLink.CodeTool do while xStart<=aNode.EndPos do begin case Src[xStart] of '{': // pascal comment begin inc(xStart); CommentLvl:=1; InStrConst:=false; while xStart<=aNode.EndPos do begin case Src[xStart] of '{': if Scanner.NestedComments then inc(CommentLvl); '}': begin dec(CommentLvl); if CommentLvl=0 then break; end; '''': InStrConst:=not InStrConst; end; inc(xStart); end; inc(xStart); end; '/': // Delphi comment if (Src[xStart+1]<>'/') then begin inc(xStart); end else begin inc(xStart,2); InStrConst:=false; while (xStart<=aNode.EndPos) do begin case Src[xStart] of #10,#13: break; '''': InStrConst:=not InStrConst; end; inc(xStart); end; inc(xStart); if (xStart<=aNode.EndPos) and (Src[xStart] in [#10,#13]) and (Src[xStart-1]<>Src[xStart]) then inc(xStart); end; '(': // turbo pascal comment if (Src[xStart+1]<>'*') then begin inc(xStart); end else begin inc(xStart,3); InStrConst:=false; while (xStart<=aNode.EndPos) do begin case Src[xStart] of ')': if Src[xStart-1]='*' then break; '''': InStrConst:=not InStrConst; end; inc(xStart); end; inc(xStart); end; 'a'..'z','A'..'Z','_': ReadFuncCall(aNode.EndPos); '''': begin // skip string constant inc(xStart); while (xStart<=aNode.EndPos) do begin if (not (Src[xStart] in ['''',#10,#13])) then inc(xStart) else begin inc(xStart); break; end; end; end; else inc(xStart); end; end; Result:=aNode.NextSkipChilds; end; var Node: TCodeTreeNode; begin Result:=false; with fCTLink.CodeTool do begin fFuncsToReplace:=TObjectList.Create; fDefinedProcNames:=TStringList.Create; fDefinedProcNames.Sorted:=True; fDefinedProcNames.Duplicates:=dupIgnore; ActivateGlobalWriteLock; try BuildTree(lsrEnd); // Only convert identifiers in ctnBeginBlock nodes Node:=fCTLink.CodeTool.Tree.Root; while Node<>nil do begin if Node.Desc=ctnBeginBlock then Node:=SearchFuncCalls(Node) else if Node.Desc=ctnProcedureHead then Node:=RememberProcDefinition(Node) else Node:=Node.Next; end; if not ReplaceFuncsInSource then Exit; finally DeactivateGlobalWriteLock; fDefinedProcNames.Free; fFuncsToReplace.Free; end; end; Result:=true; end; // ReplaceFuncCalls end.