{----------------------------------------------------------------------------- The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/MPL-1.1.html Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is: Compile.pas, released on 2004-03-29. The Initial Developer of the Original Code is Andreas Hausladen (Andreas dott Hausladen att gmx dott de) Portions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen. All Rights Reserved. Contributor(s): - You may retrieve the latest version of this file at the Project JEDI's JVCL home page, located at http://jvcl.sourceforge.net Known Issues: -----------------------------------------------------------------------------} // $Id: Compile.pas 12032 2008-11-03 22:47:18Z ahuser $ unit Compile; {$I jvcl.inc} {$I windowsonly.inc} interface uses Windows, SysUtils, Classes, CapExec, JVCLData, DelphiData, GenerateUtils, PackageUtils, Intf, PackageInformation, ConditionParser, JclBase, JclSysInfo, JvVCL5Utils, JVCLVer; type TProgressKind = ( pkTarget, // progress of all targets pkProject, // |- progress of the parts of one target compilation pkResource, // |- progress of the resource compilation pkPackage, // |- progress of the package compilation pkOther // |- progress for copy/delete and other things ); TTargetProgressEvent = procedure(Sender: TObject; Current: TTargetConfig; Position, Max: Integer) of object; TPackageProgressEvent = procedure(Sender: TObject; Current: TPackageTarget; const Text: string; Position, Max: Integer) of object; TResourceProgressEvent = procedure(Sender: TObject; const Text: string; Position, Max: Integer) of object; TProjectProgressEvent = TResourceProgressEvent; TProgressEvent = procedure(Sender: TObject; const Text: string; Position, Max: Integer; Kind: TProgressKind) of object; TCompiler = class(TObject) private FData: TJVCLData; FCurrentProjectGroup: TProjectGroup; FAborted: Boolean; FOutput: TStrings; FCount: Integer; FPkgCount: Integer; // number of packages to compile FPkgIndex: Integer; FResCount: Integer; FResIndex: Integer; FOnCaptureLine: TCaptureLine; FOnTargetProgress: TTargetProgressEvent; FOnPackageProgress: TPackageProgressEvent; FOnResourceProgress: TResourceProgressEvent; FOnProjectProgress: TProjectProgressEvent; FOnProgress: TProgressEvent; FOnIdle: TNotifyEvent; FAbortReason: string; function IsPackageUsed(ProjectGroup: TProjectGroup; RequiredPackage: TRequiredPackage): Boolean; function IsFileUsed(ProjectGroup: TProjectGroup; ContainedFile: TContainedFile): Boolean; procedure SortProjectGroup(Group: TProjectGroup; List: TList); protected function Dcc32(TargetConfig: ITargetConfig; Project: TPackageTarget; const DccOpt: string; DebugUnits: Boolean; Files, ObjFiles: TStrings): Integer; function Bcc32(TargetConfig: ITargetConfig; Project: TPackageTarget; const BccOpt: string; DebugUnits: Boolean; Files: TStrings; ObjFiles: TStrings): Integer; function Ilink32(TargetConfig: ITargetConfig; Project: TPackageTarget; const IlinkOpt: string; DebugUnits: Boolean; ObjFiles, LibFiles, ResFiles: TStrings): Integer; function Tlib(TargetConfig: ITargetConfig; Project: TPackageTarget; const TlibOpt: string; DebugUnits: Boolean; ObjFiles: TStrings): Integer; function Make(TargetConfig: ITargetConfig; Args: string; CaptureLine: TCaptureLine; StartDir: string = ''): Integer; function CompileCppPackage(TargetConfig: ITargetConfig; Project: TPackageTarget; const DccOpt, BccOpt, IlinkOpt: string; DebugUnits: Boolean; var FilesCompiled: Boolean): Integer; function CompileDelphiPackage(TargetConfig: ITargetConfig; Project: TPackageTarget; const DccOpt: string; DebugUnits: Boolean; var FilesCompiled: Boolean): Integer; function WriteDcc32Cfg(const Directory: string; TargetConfig: ITargetConfig; const DccOpt: string; DebugUnits: Boolean): string; // returns the dcc32.cfg filename procedure DoIdle(Sender: TObject); procedure LinkMapFile(TargetConfig: ITargetConfig; Project: TPackageTarget; DebugUnits: Boolean); procedure LogModify(const Name: string; const FilenameA: string; AgeA: Integer; const FilenameB: string; AgeB: Integer); procedure CaptureLine(const Line: string; var Aborted: Boolean); virtual; procedure CaptureLineClean(const Line: string; var Aborted: Boolean); virtual; procedure CaptureLineGetCompileCount(const Line: string; var Aborted: Boolean); procedure CaptureLinePackageCompilation(const Line: string; var Aborted: Boolean); procedure CaptureLineResourceCompilation(const Line: string; var Aborted: Boolean); procedure CaptureStatusLineDcc32(const Line: string; var Aborted: Boolean); procedure DoTargetProgress(Current: TTargetConfig; Position, Max: Integer); virtual; procedure DoProjectProgress(const Text: string; Position, Max: Integer); virtual; procedure DoResourceProgress(const Text: string; Position, Max: Integer); virtual; procedure DoPackageProgress(Current: TPackageTarget; const Text: string; Position, Max: Integer); virtual; procedure DoProgress(const Text: string; Position, Max: Integer; Kind: TProgressKind); virtual; // DoProgress is called by every DoXxxProgress method function CompileProjectGroup(ProjectGroup: TProjectGroup; DebugUnits: Boolean): Boolean; function GenerateResources(TargetConfig: ITargetConfig): Boolean; function DeleteFormDataFiles(ProjectGroup: TProjectGroup): Boolean; function CopyFormDataFiles(ProjectGroup: TProjectGroup; DebugUnits: Boolean): Boolean; function IsCondition(const Condition: string; TargetConfig: ITargetConfig): Boolean; function GeneratePackages(const Group, Targets, PackagesPath: string): Boolean; overload; function GenerateAllPackages: Boolean; overload; function CompileTarget(TargetConfig: TTargetConfig; PackageGroupKind: TPackageGroupKind): Boolean; procedure DeleteRemovedFiles(TargetConfig: TTargetConfig); //procedure AlterHppFiles(TargetConfig: ITargetConfig; Project: TPackageTarget); public constructor Create(AData: TJVCLData); destructor Destroy; override; function IsDcc32BugDangerous(TargetConfig: ITargetConfig): Boolean; function Compile: Boolean; procedure Abort; // abort compile process property AbortReason: string read FAbortReason write FAbortReason; property Data: TJVCLData read FData; property Output: TStrings read FOutput; property OnCaptureLine: TCaptureLine read FOnCaptureLine write FOnCaptureLine; property OnTargetProgress: TTargetProgressEvent read FOnTargetProgress write FOnTargetProgress; property OnPackageProgress: TPackageProgressEvent read FOnPackageProgress write FOnPackageProgress; property OnResourceProgress: TResourceProgressEvent read FOnResourceProgress write FOnResourceProgress; property OnProjectProgress: TProjectProgressEvent read FOnProjectProgress write FOnProjectProgress; property OnProgress: TProgressEvent read FOnProgress write FOnProgress; property OnIdle: TNotifyEvent read FOnIdle write FOnIdle; end; const ProjectMaxProgress = 3; MaxDcc32PathLen = 80; var Compiler: TCompiler = nil; resourcestring RsPackagesAreUpToDate = 'Packages are up to date'; implementation uses {$IFNDEF COMPILER12_UP} JvJCLUtils, {$ENDIF ~COMPILER12_UP} CmdLineUtils, JvConsts, Utils, Core, Dcc32FileAgePatch; resourcestring RsGeneratingTemplates = 'Generating templates...'; RsGeneratingPackages = 'Generating packages...'; RsGeneratingResources = 'Generating resources...'; RsCompilingPackages = 'Compiling packages...'; RsPostCompilationOperations = 'Post-compilation operations...'; RsCopyingFiles = 'Copying files...'; RsCopyingFile = 'Copying %s'; RsFinished = 'Finished.'; RsAbortedByUser = 'Aborted by User'; RsErrorLoadingPackageGeneratorConfigFile = 'Error loading devtools\bin\pgEdit.xml'; RsErrorGeneratingPackages = 'Error while generating packages for %s'; RsErrorGeneratingTemplates = 'Error while generating templates.'; RsErrorCompilingResources = 'Error while compiling resources.'; RsErrorGeneratingTemplatesForDir = 'Error generating templates for the %s directory.'; RsErrorCompilingPackages = 'An error occured while compiling the packages.'; // this must not be the doubt of the installer RsErrorLinkingMapFiles = 'An error occured while linking the map files into binaries.'; RsErrorDeletingMapFiles = 'An error occured while deleting the map files after the linking.'; RsCommandNotFound = 'Command could not be executed.'#10#10#10'Cmdline: %s'#10#0'Start directory: %s'; const sGeneratePackages = '[Generating: Packages]'; // do not localize sLinkingMapFiles = '[Linking: map files]'; // do not localize const CommonDependencyFiles: array[0..5] of string = ( 'jvcl.inc', 'jvclbase.inc', 'jvcl%t.inc', 'jedi.inc', 'linuxonly.inc', 'windowsonly.inc' ); function CutPersEdition(const Edition: string): string; var i: Integer; begin Result := Edition; for i := 2 to Length(Result) do if not CharInSet(Result[i], ['0'..'9']) then begin Result := Copy(Result, 1, i - 1); Exit; end; end; function ReplaceTargetMacros(const S: string; TargetConfig: ITargetConfig): string; var ps: Integer; begin Result := S; ps := Pos('%t', Result); if ps > 0 then begin Delete(Result, ps, 2); Insert(Format('%s%d', [LowerCase(TargetConfig.Target.TargetType), TargetConfig.Target.Version]), Result, ps); end; end; { TCompiler } constructor TCompiler.Create(AData: TJVCLData); begin inherited Create; FData := AData; FOutput := TStringList.Create; CaptureStatusLine := CaptureStatusLineDcc32; end; destructor TCompiler.Destroy; begin CaptureStatusLine := nil; FOutput.Free; inherited Destroy; end; procedure TCompiler.DoTargetProgress(Current: TTargetConfig; Position, Max: Integer); begin if Assigned(FOnTargetProgress) then FOnTargetProgress(Self, Current, Position, Max); DoProgress(Current.Target.DisplayName, Position, Max, pkTarget); end; procedure TCompiler.DoProjectProgress(const Text: string; Position, Max: Integer); begin if Assigned(FOnProjectProgress) then FOnProjectProgress(Self, Text, Position, Max); DoProgress(Text, Position, Max, pkProject); end; procedure TCompiler.DoResourceProgress(const Text: string; Position, Max: Integer); begin if Assigned(FOnResourceProgress) then FOnResourceProgress(Self, Text, Position, Max); DoProgress(Text, Position, Max, pkResource); end; procedure TCompiler.DoPackageProgress(Current: TPackageTarget; const Text: string; Position, Max: Integer); begin if Assigned(FOnPackageProgress) then FOnPackageProgress(Self, Current, Text, Position, Max); DoProgress(Text, Position, Max, pkPackage); end; procedure TCompiler.DoProgress(const Text: string; Position, Max: Integer; Kind: TProgressKind); begin if Assigned(FOnProgress) then FOnProgress(Self, Text, Position, Max, Kind); end; procedure TCompiler.LogModify(const Name: string; const FilenameA: string; AgeA: Integer; const FilenameB: string; AgeB: Integer); begin { if AgeA = -1 then CaptureLine(Format('%s: %s (%s) > %s (%s)', [Name, FilenameA, '-1', FilenameB, DateTimeToStr(FileDateToDateTime(AgeB))]), FAborted) else if AgeB = -1 then CaptureLine(Format('%s: %s (%s) > %s (%s)', [Name, FilenameA, DateTimeToStr(FileDateToDateTime(AgeA)), FilenameB, '-1']), FAborted) else CaptureLine(Format('%s: %s (%s) > %s (%s)', [Name, FilenameA, DateTimeToStr(FileDateToDateTime(AgeA)), FilenameB, DateTimeToStr(FileDateToDateTime(AgeB))]), FAborted);} end; procedure TCompiler.CaptureLine(const Line: string; var Aborted: Boolean); begin FOutput.Add(Line); if Assigned(FOnCaptureLine) then FOnCaptureLine(Line, FAborted); //Aborted := FAborted; We abort only when the compiler has finished its work. end; procedure TCompiler.CaptureLineClean(const Line: string; var Aborted: Boolean); begin if StartsWith('[', Line) then CaptureLine(Line, Aborted); end; procedure TCompiler.CaptureLineGetCompileCount(const Line: string; var Aborted: Boolean); begin if StartsWith(Trim(Line), 'echo [Compiling: ', True) then Inc(FCount) else if (Line <> '') and (Line[1] <> #9) then CaptureLine(Line, FAborted); //Aborted := FAborted; We abort only when the compiler has finished its work. end; procedure TCompiler.CaptureLinePackageCompilation(const Line: string; var Aborted: Boolean); var S: string; i: Integer; begin CaptureLine(Line, Aborted); if (Line <> '') and (Line[1] = '[') then begin if StartsWith(Line, '[Compiling: ', True) then begin Inc(FPkgIndex); S := Trim(Copy(Line, 13, Length(Line) - 13)); for i := 0 to FCurrentProjectGroup.Count - 1 do if CompareText(FCurrentProjectGroup.Packages[i].TargetName, S) = 0 then begin S := S + ' (' + FCurrentProjectGroup.Packages[i].Info.Description + ')'; DoPackageProgress(FCurrentProjectGroup.Packages[i], S, FPkgIndex - 1, FPkgCount); Exit; end; DoPackageProgress(nil, S, FPkgIndex, FPkgCount); end; end; end; procedure TCompiler.CaptureLineResourceCompilation(const Line: string; var Aborted: Boolean); var S: string; begin CaptureLine(Line, Aborted); if (Line <> '') and (Line[1] = '[') then begin if StartsWith(Line, '[Compiling: ', True) then begin Inc(FResIndex); S := Trim(Copy(Line, 15, Length(Line) - 15)); DoResourceProgress(S, FResIndex, FResCount); end; end; end; procedure TCompiler.CaptureStatusLineDcc32(const Line: string; var Aborted: Boolean); begin CaptureLine(Line, Aborted); end; procedure TCompiler.Abort; begin FAborted := True; end; procedure WriteMsg(const Text: string); // used by TCompiler.GeneratePackages begin Compiler.CaptureLine(Text, Compiler.FAborted); end; procedure TCompiler.DoIdle(Sender: TObject); begin if Assigned(FOnIdle) then FOnIdle(Self); end; /// /// Make calls the make.exe of the given TargetConfig. If the StartDir is empty /// the JVCLPackageDir\bin directory is used. If the command could not be /// executed a message dialog is shown with the complete command line. Returns /// the ExitCode of the last/failed command. /// function TCompiler.Make(TargetConfig: ITargetConfig; Args: string; CaptureLine: TCaptureLine; StartDir: string): Integer; begin if StartDir = '' then StartDir := Data.JVCLPackagesDir + '\bin'; if Data.IgnoreMakeErrors then Args := Trim('-i ' + Args); if Data.Verbose then begin // output command line if Assigned(CaptureLine) then CaptureLine(#1 + '"' + TargetConfig.Target.Make + '" ' + Args, FAborted); end; Result := CaptureExecute('"' + TargetConfig.Target.Make + '"', Args, StartDir, CaptureLine, DoIdle, False, TargetConfig.GetPathEnvVar); if Result < 0 then // command not found MessageBox(0, PChar(Format(RsCommandNotFound, ['"' + TargetConfig.Target.Make + '"' + Args, StartDir])), 'JVCL Installer', MB_OK or MB_ICONERROR); end; /// /// WriteDcc32Cfg() writes the dcc32.cfg file to the directory /// function TCompiler.WriteDcc32Cfg(const Directory: string; TargetConfig: ITargetConfig; const DccOpt: string; DebugUnits: Boolean): string; var Lines: TStrings; SearchPaths, S: string; i: Integer; OutDirs: TOutputDirs; Target: TCompileTarget; begin OutDirs := TargetConfig.GetOutputDirs(DebugUnits); Lines := TStringList.Create; try // opts Lines.Add(DccOpt); // default paths SearchPaths := TargetConfig.Target.ExpandDirMacros( TargetConfig.Target.RootLibDir + ';' + TargetConfig.Target.RootLibDir + PathDelim + 'obj;' + TargetConfig.JclDcpDir + ';' + TargetConfig.JclDcuDir + ';' + OutDirs.DcpDir + ';' + OutDirs.UnitOutDir ); Lines.Add('-U"' + SearchPaths + ';' + TargetConfig.JVCLDir + PathDelim + 'Common' + '"'); Lines.Add('-I"' + SearchPaths + ';' + TargetConfig.JVCLDir + PathDelim + 'Common' + '"'); Lines.Add('-R"' + SearchPaths + ';' + TargetConfig.JVCLDir + PathDelim + 'Resources' + '"'); Lines.Add('-O"' + SearchPaths + '"'); // search paths SearchPaths := ''; Target := TargetConfig.Target; for i := 0 to Target.SearchPaths.Count - 1 do begin S := ExcludeTrailingPathDelimiter(Target.ExpandDirMacros(Target.SearchPaths[i])); if DirectoryExists(S) then begin if SearchPaths <> '' then SearchPaths := SearchPaths + ';' + S else SearchPaths := S; end; end; Lines.Add('-U"' + SearchPaths + '"'); Lines.Add('-I"' + SearchPaths + '"'); Lines.Add('-R"' + SearchPaths + '"'); Lines.Add('-O"' + SearchPaths + '"'); // output directories Lines.Add('-LE"' + OutDirs.BplDir + '"'); // .exe output Lines.Add('-LN"' + OutDirs.DcpDir + '"'); // .dcp output Lines.Add('-N0"' + OutDirs.UnitOutDir + '"'); // .dcu output Lines.Add('-N1"' + OutDirs.HppDir + '"'); // .hpp output if TargetConfig.Target.IsBDS then Lines.Add('-NH"' + OutDirs.HppDir + '"'); // .hpp output Lines.Add('-N2"' + OutDirs.UnitOutDir + '"'); // .obj output if TargetConfig.Target.IsBDS then Lines.Add('-NO"' + OutDirs.UnitOutDir + '"'); // .obj output Lines.Add('-NB"' + OutDirs.DcpDir + '"'); // .bpi output { dcc32.exe crashes if the path is too long } if IsDcc32BugDangerous(TargetConfig) then Lines.Add('-Q'); if TargetConfig.Target.IsPersonal then Lines.Add('-DDelphiPersonalEdition'); Result := Directory + '\dcc32.cfg'; Lines.SaveToFile(Result); finally Lines.Free; end; end; /// /// Dcc32() compiles a Delphi.Win32 package. If the command could not be /// executed a message dialog is shown with the complete command line. Returns /// the ExitCode of the last/failed command. /// function TCompiler.Dcc32(TargetConfig: ITargetConfig; Project: TPackageTarget; const DccOpt: string; DebugUnits: Boolean; Files, ObjFiles: TStrings): Integer; const MaxCmdLineLength = 2048 - 1; var Dcc32Cfg, PrjFilename: string; BplFilename, BplBakFilename, Filename, Args, CmdLine, S: string; OutDirs: TOutputDirs; ExistingBplRenamed: Boolean; begin OutDirs := TargetConfig.GetOutputDirs(DebugUnits); PrjFilename := Project.SourceDir + PathDelim + ExtractFileName(Project.SourceName); if Files.Count > 0 then Dcc32Cfg := WriteDcc32Cfg(ExtractFileDir(PrjFilename), TargetConfig, DccOpt, DebugUnits); CmdLine := ''; Result := 0; try // collect files, limited by the MaxCmdLineLength while Files.Count > 0 do begin if FAborted then Break; Filename := Files[0]; if Pos(' ', Filename) > 0 then S := ' "' + Filename + '"' else S := ' ' + Filename; Files.Delete(0); CmdLine := '"' + TargetConfig.Target.Dcc32 + '"' + S; Args := S; while Files.Count > 0 do begin Filename := Files[0]; if Pos(' ', Filename) > 0 then S := ' "' + Filename + '"' else S := ' ' + Filename; if Length(CmdLine + S) > MaxCmdLineLength then Break; CmdLine := CmdLine + S; Files.Delete(0); if Assigned(ObjFiles) then ObjFiles.Add(OutDirs.UnitOutDir + PathDelim + ChangeFileExt(ExtractFileName(Filename), '.obj')); end; if Data.Verbose then begin // output command line CaptureLinePackageCompilation(#1 + CmdLine, FAborted); end; { Get the target file out of the way, in case it is still used by the IDE or an application. } BplFilename := OutDirs.BplDir + PathDelim + Project.TargetName; BplBakFilename := BplFilename + '.bak'; ExistingBplRenamed := False; if FileExists(BplFilename) then begin if SetFileAttributes(PChar(BplBakFilename), FILE_ATTRIBUTE_NORMAL) then DeleteFile(BplBakFilename); ExistingBplRenamed := RenameFile(BplFilename, BplBakFilename); end; Result := -1; try { Compile the project } if TargetConfig.Target.Version <= 9 then Result := CaptureExecute('"' + TargetConfig.Target.Dcc32 + '"', Args, ExtractFileDir(PrjFilename), CaptureLinePackageCompilation, DoIdle, False, TargetConfig.GetPathEnvVar, Dcc32SpeedInjection) else Result := CaptureExecute('"' + TargetConfig.Target.Dcc32 + '"', Args, ExtractFileDir(PrjFilename), CaptureLinePackageCompilation, DoIdle, False, TargetConfig.GetPathEnvVar, nil); finally { Restore original file if there was an error or an exception } if ExistingBplRenamed then begin if Result <> 0 then RenameFile(BplBakFilename, BplFilename); if FileExists(BplBakFilename) then begin SetFileAttributes(PChar(BplBakFilename), FILE_ATTRIBUTE_NORMAL); if not DeleteFile(BplBakFilename) then MoveFileEx(PChar(BplBakFilename), nil, MOVEFILE_DELAY_UNTIL_REBOOT); end; end; end; if Result <> 0 then Break; end; finally if not CmdOptions.KeepFiles then DeleteFile(Dcc32Cfg); end; if Result < 0 then // command not found MessageBox(0, PChar(Format(RsCommandNotFound, [CmdLine, ExtractFileDir(PrjFilename)])), 'JVCL Installer', MB_OK or MB_ICONERROR); end; /// /// Bcc32() compiles C++ files. It adds the compiled .obj file names to ObjFiles /// If the command could not be executed a message dialog is shown with the /// complete command line. Returns the ExitCode of the last/failed command. /// function TCompiler.Bcc32(TargetConfig: ITargetConfig; Project: TPackageTarget; const BccOpt: string; DebugUnits: Boolean; Files: TStrings; ObjFiles: TStrings): Integer; var Lines: TStrings; i: Integer; RspFilename: string; ObjFilename: string; NothingToDo: Boolean; ObjAge: Integer; CsmAge: Integer; OutDirs: TOutputDirs; begin Result := 0; OutDirs := TargetConfig.GetOutputDirs(DebugUnits); RspFilename := Project.SourceDir + PathDelim + ChangeFileExt(ExtractFileName(Project.SourceName), '.@@@'); CsmAge := FileAgeEx(Format('%s\lib\vcl%d0.csm', [TargetConfig.Target.RootDir, TargetConfig.Target.Version])); NothingToDo := True; Lines := TStringList.Create; try Lines.Add(BccOpt); Lines.Add(Format('-I"%s\include;%s\include\vcl"', [TargetConfig.Target.RootDir, TargetConfig.Target.RootDir])); if DebugUnits then Lines.Add('-D_DEBUG -y -v'); Lines.Add('-D_RTLDLL;NO_STRICT;USEPACKAGES'); if TargetConfig.Target.IsPersonal then Lines.Add('-DDelphiPersonalEdition'); Lines.Add(Format('-O2 -H="%s\lib\vcl%d0.csm" -Hu -Vx -Ve -r -a8 -b- -k- -vi- -c -tWM', [TargetConfig.Target.RootDir, TargetConfig.Target.Version])); Lines.Add('-n"' + OutDirs.UnitOutDir + '"'); // add files for i := 0 to Files.Count - 1 do begin ObjFilename := OutDirs.UnitOutDir + PathDelim + ExtractFileName(ChangeFileExt(Files[i], '.obj')); ObjAge := FileAgeEx(ObjFilename); if Assigned(ObjFiles) then ObjFiles.AddObject(ObjFilename, TObject(ObjAge)); if not TargetConfig.AutoDependencies or (ObjAge < CsmAge) or (ObjAge < FileAgeEx(ExtractFilePath(RspFilename) + Files[i])) then begin Lines.Add('"' + Files[i] + '"'); NothingToDo := False; end; end; if NothingToDo then Exit; Lines.SaveToFile(RspFilename); finally Lines.Free; end; if Data.Verbose then begin // output command line CaptureLinePackageCompilation(#1 + '"' + TargetConfig.Target.Bcc32 + '" @' + ExtractFileName(RspFilename), FAborted); end; try Result := CaptureExecute('"' + TargetConfig.Target.Bcc32 + '"', '@' + ExtractFileName(RspFilename), ExtractFileDir(RspFilename), CaptureLinePackageCompilation, DoIdle, False, TargetConfig.GetPathEnvVar); finally if not CmdOptions.KeepFiles then DeleteFile(RspFilename); end; if Result < 0 then // command not found MessageBox(0, PChar(Format(RsCommandNotFound, ['"' + TargetConfig.Target.Bcc32 + '" @' + ExtractFileName(RspFilename), ExtractFileDir(RspFilename)])), 'JVCL Installer', MB_OK or MB_ICONERROR); end; /// /// Ilink32() links .obj, .lib and .res files. If the command could not be /// executed a message dialog is shown with the complete command line. Returns /// the ExitCode of the last/failed command. /// function TCompiler.Ilink32(TargetConfig: ITargetConfig; Project: TPackageTarget; const IlinkOpt: string; DebugUnits: Boolean; ObjFiles, LibFiles, ResFiles: TStrings): Integer; var Lines: TStrings; RspFilename: string; OutDirs: TOutputDirs; begin OutDirs := TargetConfig.GetOutputDirs(DebugUnits); RspFilename := Project.SourceDir + PathDelim + ChangeFileExt(ExtractFileName(Project.SourceName), '.@@@'); Lines := TStringList.Create; try Lines.Add(IlinkOpt + ' +'); if DebugUnits then Lines.Add(Format('-L"%s\lib\debug" +', [TargetConfig.Target.RootDir])) else Lines.Add(Format('-L"%s\lib\release" +', [TargetConfig.Target.RootDir])); Lines.Add(Format('-L"%s\lib\obj;%s\lib" +', [TargetConfig.Target.RootDir, TargetConfig.Target.RootDir])); Lines.Add(Format('-I"%s" +', [OutDirs.UnitOutDir])); // intermediate output dir Lines.Add(Format('-j"%s" +', [OutDirs.UnitOutDir])); // .obj search path Lines.Add(Format('-D"%s" +', [Project.Info.Description])); Lines.Add(Format('-L"%s\common;%s\Resources;%s\design;%s\run" +', // resource files [TargetConfig.JVCLDir, TargetConfig.JVCLDir, TargetConfig.JVCLDir, TargetConfig.JVCLDir])); if DebugUnits then Lines.Add('-v +'); if not TargetConfig.GenerateMapFiles then Lines.Add('-x +'); Lines.Add('-aa -Tpp -Gn -Gl -Gi +'); if Project.Info.XmlInfo.ImageBase <> '' then Lines.Add('-b:0x' + Project.Info.XmlInfo.ImageBase + ' +'); case Project.Info.ProjectType of ptPackageRun: Lines.Add('-Gpr +'); ptPackageDesign: Lines.Add('-Gpd +'); ptPackage: ; ptLibrary: ; ptProgram: ; end; Lines.Add(Format('-L"%s;%s" -l"%s" +', [TargetConfig.JCLDcpDir, OutDirs.DcpDir, OutDirs.DcpDir])); // add .obj files Lines.Add(ConcatPaths(ObjFiles, ' ') + ', +'); Lines.Add('"' + OutDirs.BplDir + PathDelim + Project.TargetName + '", +'); Lines.Add('"' + OutDirs.BplDir + PathDelim + ChangeFileExt(Project.TargetName, '.map') + '", +'); Lines.Add(ConcatPaths(LibFiles, ' ') + ',, +'); Lines.Add(ConcatPaths(ResFiles, ' ')); Lines.SaveToFile(RspFilename); finally Lines.Free; end; if Data.Verbose then begin // output command line CaptureLinePackageCompilation(#1 + '"' + TargetConfig.Target.Ilink32 + '" @' + ExtractFileName(RspFilename), FAborted); end; try Result := CaptureExecute('"' + TargetConfig.Target.Ilink32 + '"', '@' + ExtractFileName(RspFilename), ExtractFileDir(RspFilename), CaptureLinePackageCompilation, DoIdle, False, TargetConfig.GetPathEnvVar); finally if not CmdOptions.KeepFiles then DeleteFile(RspFilename); end; if Result < 0 then // command not found MessageBox(0, PChar(Format(RsCommandNotFound, ['"' + TargetConfig.Target.Ilink32 + '" @' + ExtractFileName(RspFilename), ExtractFileDir(RspFilename)])), 'JVCL Installer', MB_OK or MB_ICONERROR); end; /// /// Tlib() creates a .lib file. If the command could not be executed a message /// dialog is shown with the complete command line. Returns the ExitCode of the /// last/failed command. /// function TCompiler.Tlib(TargetConfig: ITargetConfig; Project: TPackageTarget; const TlibOpt: string; DebugUnits: Boolean; ObjFiles: TStrings): Integer; var Lines: TStrings; RspFilename: string; LibFilename: string; OutDirs: TOutputDirs; begin OutDirs := TargetConfig.GetOutputDirs(DebugUnits); RspFilename := Project.SourceDir + PathDelim + ChangeFileExt(ExtractFileName(Project.SourceName), '.@@@'); LibFilename := OutDirs.DcpDir + PathDelim + ChangeFileExt(ExtractFileName(Project.SourceName), '.lib'); DeleteFile(LibFilename); Lines := TStringList.Create; try Lines.Add(TLibOpt + ' &'); // add .obj files if ObjFiles.Count > 0 then Lines.Add(' +"' + ConcatPaths(ObjFiles, '" &'#13#10 + ' +"') + '"'); Lines.SaveToFile(RspFilename); finally Lines.Free; end; if Data.Verbose then begin // output command line CaptureLinePackageCompilation(#1 + '"' + TargetConfig.Target.Tlib + '" "' + LibFilename + '" @' + ExtractFileName(RspFilename), FAborted); end; try Result := CaptureExecute('"' + TargetConfig.Target.Tlib + '"', '"' + LibFilename + '" @' + ExtractFileName(RspFilename), ExtractFileDir(RspFilename), CaptureLinePackageCompilation, DoIdle, False, TargetConfig.GetPathEnvVar); finally if not CmdOptions.KeepFiles then DeleteFile(RspFilename); end; if Result < 0 then // command not found MessageBox(0, PChar(Format(RsCommandNotFound, ['"' + TargetConfig.Target.TLib + '" "' + LibFilename + '" @' + ExtractFileName(RspFilename), ExtractFileDir(RspFilename)])), 'JVCL Installer', MB_OK or MB_ICONERROR); end; /// /// CompileCppPackage() compiles a BCB.Win32 package. If one of the commands /// could not be executed a message dialog is shown with the complete command /// line of the failed command. Returns the ExitCode of the last/failed command. /// function TCompiler.CompileCppPackage(TargetConfig: ITargetConfig; Project: TPackageTarget; const DccOpt, BccOpt, IlinkOpt: string; DebugUnits: Boolean; var FilesCompiled: Boolean): Integer; var PrjFilename, PkgFilename, ResFilename: string; PasFiles, CppFiles, ObjFiles, LibFiles, ResFiles: TStrings; i, ObjAge, NewestObjAge, AgeIndex: Integer; BplFilename, DcpFilename, BpiFilename, ObjFilename: string; {BplAge, }DcpAge, {LibAge,} BpiAge: Integer; Changed: Boolean; OutDirs: TOutputDirs; FilesPackedTogether: Boolean; begin OutDirs := TargetConfig.GetOutputDirs(DebugUnits); PrjFilename := Project.SourceDir + PathDelim + ExtractFileName(Project.SourceName); BplFilename := OutDirs.BplDir + PathDelim + Project.TargetName; DcpFilename := OutDirs.DcpDir + PathDelim + Project.DcpName; BpiFilename := ChangeFileExt(DcpFilename, '.bpi'); {BplAge := FileAgeEx(BplFilename);} DcpAge := FileAgeEx(DcpFilename); {LibAge := FileAgeEx(ChangeFileExt(DcpFilename, '.lib'));} BpiAge := FileAgeEx(BpiFilename); PasFiles := nil; CppFiles := nil; ObjFiles := nil; LibFiles := nil; ResFiles := nil; try PasFiles := TStringList.Create; CppFiles := TStringList.Create; ObjFiles := TStringList.Create; LibFiles := TStringList.Create; ResFiles := TStringList.Create; CppFiles.Add(ChangeFileExt(PrjFilename, '.cpp')); // .cpp ResFiles.Add(ChangeFileExt(PrjFilename, '.res')); // .res for i := 0 to Project.ContainCount - 1 do begin if IsFileUsed(Project.Owner, Project.Contains[i]) then begin PasFiles.Add(Project.Contains[i].Name); if Project.Contains[i].FormName <> '' then begin ResFilename := ChangeFileExt(Project.Contains[i].Name, '.xfm'); if not FileExists(ResFilename) then ResFilename := ChangeFileExt(Project.Contains[i].Name, '.dfm'); ResFiles.Add(ResFilename); end; end; end; ObjFiles.Add('c0pkg32.obj'); for i := 0 to Project.RequireCount - 1 do begin if IsPackageUsed(Project.Owner, Project.Requires[i]) then begin // obtain DCP filename { TODO : Change this if the .dcp filename convention changes } PkgFilename := ChangeFileExt(Project.Requires[i].GetBplName(Project.Owner), ''); ObjFiles.Add(PkgFilename + '.bpi'); end; end; ObjFiles.Add('Memmgr.lib'); ObjFiles.Add('sysinit.obj'); LibFiles.Add('import32.lib'); LibFiles.Add('cp32mti.lib'); // add additional .lib files if TargetConfig.Target.Version = 5 then LibFiles.AddStrings(Project.Info.XmlInfo.C5Libs) else if TargetConfig.Target.Version = 6 then LibFiles.AddStrings(Project.Info.XmlInfo.C6Libs) else if TargetConfig.Target.Version = 10 then // not used LibFiles.AddStrings(Project.Info.XmlInfo.C10Libs); AgeIndex := ObjFiles.Count; // add .pas.obj files NewestObjAge := 0; for i := 0 to PasFiles.Count - 1 do begin ObjFilename := OutDirs.UnitOutDir + PathDelim + ChangeFileExt(ExtractFileName(PasFiles[i]), '.obj'); if TargetConfig.AutoDependencies then ObjAge := FileAgeEx(ObjFilename) else ObjAge := -1; ObjFiles.AddObject(ObjFilename, TObject(ObjAge)); if ObjAge > NewestObjAge then NewestObjAge := ObjAge; end; // compile Delphi files (creates only .dcu, .obj and .hpp files) Result := CompileDelphiPackage(TargetConfig, Project, DccOpt + ' -JPHNE --BCB', DebugUnits, FilesCompiled); if Result <> 0 then Exit; FilesPackedTogether := False; Changed := not TargetConfig.AutoDependencies or HaveFilesChanged(ObjFiles, AgeIndex) or (DcpAge < NewestObjAge) or (BpiAge <> FileAgeEx(BpiFilename)); if Changed then begin // compile Delphi package (only modified) to get .dcp file (.bpl is also created) // Note: in order to be REALLY safe, we should also pass --BCB here to get the // compiler in BCB mode and ensure that should a unit be recompiled, it is in the // same state as it was when the dcu/obj/hpp files were created. However, this // does not work with BCB5, as it won't generate the dcp file with --BCB. Defining // BCB via -DBCB is also not working here. So we have to "hope" the compiler // is intelligent enough to see that it just needs to pack the dcu files into // the final dcp file. Result := CompileDelphiPackage(TargetConfig, Project, StringReplace(' ' + DccOpt + ' ', ' -B ', '', [rfReplaceAll]), DebugUnits, FilesPackedTogether); if Result <> 0 then Exit; end; { Delete the dcc32 generated .lsp file which is not used at all. } DeleteFile(Project.SourceDir + PathDelim + ExtractFileName(ChangeFileExt(Project.SourceName, '.lsp'))); AgeIndex := ObjFiles.Count; // compile C++ files Result := Bcc32(TargetConfig, Project, BccOpt, DebugUnits, CppFiles, ObjFiles); if Result <> 0 then Exit; Changed := not TargetConfig.AutoDependencies or HaveFilesChanged(ObjFiles, AgeIndex) or FilesCompiled or FilesPackedTogether; {(BplAge < NewestObjAge) or (LibAge < BpiAge) or (BpiAge < NewestObjAge)}; if Changed then begin // link files (create .lib, .bpi and .bpl) Result := Ilink32(TargetConfig, Project, IlinkOpt, DebugUnits, ObjFiles, LibFiles, ResFiles); if Result <> 0 then Exit; end; finally PasFiles.Free; CppFiles.Free; ObjFiles.Free; LibFiles.Free; ResFiles.Free; end; end; /// /// CompileDelphiPackage() compiles a Delphi.Win32 package. If one of the commands /// could not be executed a message dialog is shown with the complete command /// line of the failed command. Returns the ExitCode of the last/failed command. /// function TCompiler.CompileDelphiPackage(TargetConfig: ITargetConfig; Project: TPackageTarget; const DccOpt: string; DebugUnits: Boolean; var FilesCompiled: Boolean): Integer; var Files: TStrings; i: Integer; DcpAge, FormAge, PasAge, DcuAge, BplAge, DepAge: Integer; PrjFilename, DcpFilename, BplFilename, ResFilename: string; Filename, DcuFilename: string; Changed: Boolean; OutDirs: TOutputDirs; begin OutDirs := TargetConfig.GetOutputDirs(DebugUnits); Result := 0; PrjFilename := Project.SourceDir + PathDelim + ExtractFileName(Project.SourceName); DcpFilename := OutDirs.DcpDir + PathDelim + Project.DcpName; BplFilename := OutDirs.BplDir + PathDelim + Project.TargetName; ResFilename := ChangeFileExt(PrjFilename, '.res'); DcpAge := FileAgeEx(DcpFilename); BplAge := FileAgeEx(BplFilename); // .dpk/.bpk Changed := not TargetConfig.AutoDependencies or (DcpAge < FileAgeEx(PrjFilename)) or (DcpAge < FileAgeEx(ResFilename)){ or (DcpAge > BplAge)}; // this happens if the .dcp is not for the .bpl [BDS 2006 makes this non-function] if Changed then begin if DcpAge < FileAgeEx(PrjFilename) then LogModify('Project', PrjFilename, FileAgeEx(PrjFilename), DcpFilename, DcpAge); if DcpAge < FileAgeEx(ResFilename) then LogModify('Resource', ResFilename, FileAgeEx(ResFilename), DcpFilename, DcpAge); {if DcpAge > BplAge then LogModify('Bpl', BplFilename, BplAge, DcpFilename, DcpAge);} end; if DcpAge > BplAge then DcpAge := BplAge; // compile units that are newer than the bpl if the bpl is older than the dcp if not Changed then begin for i := 0 to High(CommonDependencyFiles) do begin Filename := TargetConfig.JVCLDir + '\common\' + ReplaceTargetMacros(CommonDependencyFiles[i], TargetConfig); DepAge := FileAgeEx(Filename); if (DcpAge < DepAge) or (DepAge = -1) then begin Changed := True; LogModify('Common', Filename, DepAge, DcpFilename, DcpAge); Break; end; end; end; if not Changed then begin // required JVCL package for i := 0 to Project.JvDependencies.Count - 1 do begin if IsPackageUsed(Project.Owner, Project.JvDependenciesReqPkg[i]) then begin Filename := OutDirs.DcpDir + PathDelim + TargetConfig.VersionedJVCLXmlDcp(Project.JvDependenciesReqPkg[i].Name); DepAge := FileAgeEx(Filename); if (DepAge > DcpAge) or (DepAge = -1) then begin Changed := True; LogModify('JVCL', Filename, DepAge, DcpFilename, DcpAge); Break; end; end; end; end; if not Changed then begin // required JCL package for i := 0 to Project.JclDependencies.Count - 1 do begin if IsPackageUsed(Project.Owner, Project.JclDependenciesReqPkg[i]) then begin Filename := TargetConfig.JclDcpDir + PathDelim + TargetConfig.VersionedJclDcp(Project.JclDependenciesReqPkg[i].Name + '.dcp'); DepAge := FileAgeEx(Filename); if (DepAge > DcpAge) or (DepAge = -1) then begin Changed := True; LogModify('JCL', Filename, DepAge, DcpFilename, DcpAge); Break; end; end; end; end; if not Changed then begin // files for i := 0 to Project.ContainCount - 1 do begin if IsFileUsed(Project.Owner, Project.Contains[i]) then begin // .pas Filename := Project.SourceDir + PathDelim + Project.Contains[i].Name; DcuFilename := OutDirs.UnitOutDir + PathDelim + ChangeFileExt(ExtractFileName(Project.Contains[i].Name), '.dcu'); PasAge := FileAgeEx(Filename); DcuAge := FileAgeEx(DcuFilename); if (PasAge > DcuAge) or (PasAge = -1) then begin Changed := True; LogModify('Source', Filename, PasAge, DcuFilename, DcuAge); Break; end; if (DcuAge > DcpAge) or (DcuAge = -1) then begin Changed := True; LogModify('Unit', DcuFilename, DcuAge, DcpFilename, DcpAge); Break; end; // .dfm/.xfm if Project.Contains[i].FormName <> '' then begin Filename := ChangeFileExt(Filename, '.dfm'); FormAge := FileAgeEx(Filename); if FormAge = -1 then begin Filename := ChangeFileExt(Filename, '.xfm'); FormAge := FileAgeEx(Filename); end; if (FormAge <> -1) and (FormAge > DcpAge) then begin Changed := True; LogModify('Form', Filename, FormAge, DcpFilename, DcpAge); Break; end; end; end; end; end; FilesCompiled := False; if Changed then begin Files := TStringList.Create; try Files.Add(ExtractFileName(ChangeFileExt(Project.SourceName, '.dpk'))); // force .dpk Result := Dcc32(TargetConfig, Project, DccOpt, DebugUnits, Files, nil); if Result = 0 then FilesCompiled := True; finally Files.Free; end; end; end; /// /// GeneratePackages generates the packages in /// PackagesPath for the Group (JVCL) for the Targets (comma separated /// pg.exe target list). /// function TCompiler.GeneratePackages(const Group, Targets, PackagesPath: string): Boolean; var ErrMsg: string; List, TargetList: TStrings; begin Result := False; CaptureLine(sGeneratePackages, FAborted); if FAborted then begin AbortReason := RsAbortedByUser; Exit; end; try if not LoadConfig(Data.JVCLDir + '\' + sPackageGeneratorFile, Group, ErrMsg) then begin CaptureLine(ErrMsg, FAborted); AbortReason := RsErrorLoadingPackageGeneratorConfigFile; Exit; end; except on E: Exception do begin AbortReason := RsErrorLoadingPackageGeneratorConfigFile + #10#10 + E.Message; Exit; end; end; List := TStringList.Create; TargetList := TStringList.Create; try TargetList.CommaText := Targets; ExpandTargetsNoPerso(TargetList); EnumeratePackages(PackagesPath, List); if not Generate(List, TargetList, WriteMsg, Data.JVCLDir + '\' + sPackageGeneratorFile, Group, ErrMsg, PackagesPath, '', '', Data.JVCLDir + '\common\jvcl%t.inc') then begin CaptureLine(ErrMsg, FAborted); AbortReason := Format(RsErrorGeneratingPackages, [TargetList.CommaText]); Exit; end; finally List.Free; TargetList.Free; end; if FAborted then begin AbortReason := RsAbortedByUser; Exit; end; Result := True; end; /// /// GenerateAllPackages generates all JVCL packages /// function TCompiler.GenerateAllPackages: Boolean; begin Result := GeneratePackages('JVCL', 'all', Data.JVCLPackagesDir); end; /// /// Compile() prepares for compiling and decides if the VCL framework /// should be compiled. /// function TCompiler.Compile: Boolean; var i, Index: Integer; Frameworks, Count: Integer; TargetConfigs: array of TTargetConfig; SysInfo: string; begin Result := True; FAborted := False; SysInfo := GetWindowsProductString; if SysInfo <> '' then begin SysInfo := #1 + SysInfo + Format(' %s (%d.%d.%d)', [Win32CSDVersion, Win32MajorVersion, Win32MinorVersion, Win32BuildNumber]); CaptureLine(SysInfo, FAborted); CaptureLine('', FAborted); end; CaptureLine(Format('JVCL %d.%d.%d.%d', [JVCLVersionMajor, JVCLVersionMinor, JVCLVersionRelease, JVCLVersionBuild]), FAborted); CaptureLine('', FAborted); AbortReason := ''; // read target configs that should be compiled Count := 0; Frameworks := 0; SetLength(TargetConfigs, Data.Targets.Count); for i := 0 to High(TargetConfigs) do begin if Data.TargetConfig[i].InstallJVCL then begin TargetConfigs[Count] := Data.TargetConfig[i]; Inc(Count); if pkVCL in Data.TargetConfig[i].InstallMode then Inc(Frameworks); end; end; SetLength(TargetConfigs, Count); // compile all selected targets Index := 0; for i := 0 to Count - 1 do begin DoTargetProgress(TargetConfigs[i], Index, Frameworks); if pkVCL in TargetConfigs[i].InstallMode then begin Result := CompileTarget(TargetConfigs[i], pkVCL); if not Result then Break; Inc(Index); end; DoTargetProgress(TargetConfigs[i], Index, Frameworks); end; end; /// /// DeleteRemovedFiles deletes the removed packages and units from the output directories. /// procedure TCompiler.DeleteRemovedFiles(TargetConfig: TTargetConfig); var I: Integer; Filename, Path: string; begin { Delete removed package files .dcp, .lib, .bpi, .dcu, .hpp file } for I := 0 to High(sRemovedPackages) do begin { Release } Filename := TargetConfig.VersionedJVCLXmlDcp(sRemovedPackages[I]); Path := IncludeTrailingPathDelimiter(TargetConfig.DcpDir); if Path = '' then IncludeTrailingPathDelimiter(TargetConfig.Target.DcpDir); if FileExists(Path + Filename) then begin DeleteFile(Path + Filename); DeleteFile(Path + ChangeFileExt(Filename, '.dcu')); DeleteFile(Path + ChangeFileExt(Filename, '.lib')); DeleteFile(Path + ChangeFileExt(Filename, '.bpi')); DeleteFile(Path + ChangeFileExt(Filename, '.hpp')); if TargetConfig.HppDir <> '' then Path := IncludeTrailingPathDelimiter(TargetConfig.HppDir); DeleteFile(Path + ChangeFileExt(Filename, '.hpp')); end; { Debug } Filename := TargetConfig.VersionedJVCLXmlDcp(sRemovedPackages[I]); Path := IncludeTrailingPathDelimiter(TargetConfig.DebugDcpDir); if Path = '' then IncludeTrailingPathDelimiter(TargetConfig.Target.DcpDir); if FileExists(Path + Filename) then begin DeleteFile(Path + Filename); DeleteFile(Path + ChangeFileExt(Filename, '.dcu')); DeleteFile(Path + ChangeFileExt(Filename, '.lib')); DeleteFile(Path + ChangeFileExt(Filename, '.bpi')); DeleteFile(Path + ChangeFileExt(Filename, '.hpp')); if TargetConfig.DebugHppDir <> '' then Path := IncludeTrailingPathDelimiter(TargetConfig.DebugHppDir); DeleteFile(Path + ChangeFileExt(Filename, '.hpp')); end; { Delete package .bpl } Filename := TargetConfig.VersionedJVCLXmlBpl(sRemovedPackages[I]); Path := IncludeTrailingPathDelimiter(TargetConfig.BplDir); if Path = '' then Path := IncludeTrailingPathDelimiter(TargetConfig.Target.BplDir); DeleteFile(Path + Filename); end; { Delete removed unit files .dcu, .dfm, .hpp } for I := 0 to High(sRemovedUnits) do begin { Release } Path := IncludeTrailingPathDelimiter(TargetConfig.UnitOutDir); if Path <> '' then begin Filename := sRemovedUnits[I] + '.dcu'; if FileExists(Path + Filename) then begin DeleteFile(Path + Filename); DeleteFile(Path + ChangeFileExt(Filename, '.dfm')); DeleteFile(Path + ChangeFileExt(Filename, '.hpp')); if TargetConfig.HppDir <> '' then Path := IncludeTrailingPathDelimiter(TargetConfig.HppDir); DeleteFile(Path + ChangeFileExt(Filename, '.hpp')); end; end; { Debug } Path := IncludeTrailingPathDelimiter(TargetConfig.DebugUnitOutDir); if Path <> '' then begin Filename := sRemovedUnits[I] + '.dcu'; if FileExists(Path + Filename) then begin DeleteFile(Path + Filename); DeleteFile(Path + ChangeFileExt(Filename, '.dfm')); DeleteFile(Path + ChangeFileExt(Filename, '.hpp')); if TargetConfig.DebugHppDir <> '' then Path := IncludeTrailingPathDelimiter(TargetConfig.DebugHppDir); DeleteFile(Path + ChangeFileExt(Filename, '.hpp')); end; end; end; end; /// /// CompileTarget starts CompileProjectGroup for all sub targets of the /// given target IDE. /// function TCompiler.CompileTarget(TargetConfig: TTargetConfig; PackageGroupKind: TPackageGroupKind): Boolean; var Aborted: Boolean; begin Result := True; Aborted := False; FOutput.Clear; DeleteRemovedFiles(TargetConfig); // VCL if Result and (pkVCL in TargetConfig.InstallMode) then begin if not TargetConfig.DeveloperInstall then begin // debug units if TargetConfig.Target.SupportsPersonalities([persDelphi]) and TargetConfig.DebugUnits then Result := CompileProjectGroup( TargetConfig.Frameworks.Items[TargetConfig.Target.IsPersonal, pkVCL], True); end; if Result then begin // compile Result := CompileProjectGroup( TargetConfig.Frameworks.Items[TargetConfig.Target.IsPersonal, pkVCL], False); end; if Result then CaptureLine('[Finished JVCL for VCL installation]', Aborted); // do not localize end; end; /// /// GenerateResources starts the make file for the resource file compilation. /// function TCompiler.GenerateResources(TargetConfig: ITargetConfig): Boolean; begin Result := False; // get number of resources to compile FCount := 0; if Make(TargetConfig, '-f makefile.mak -n', CaptureLineGetCompileCount, TargetConfig.JVCLDir + '\images') <> 0 then begin AbortReason := RsErrorCompilingResources; Exit; end; // update FResCount with the number of resources that MAKE will compile FResCount := FCount; FResIndex := 0; if FCount > 0 then begin DoResourceProgress('', 0, FResCount); // generate .res and .dcr files if Make(TargetConfig, '-f makefile.mak', CaptureLineResourceCompilation, TargetConfig.JVCLDir + '\images') <> 0 then begin AbortReason := RsErrorCompilingResources; Exit; end; DoResourceProgress('', FResCount, FResCount); end; if FAborted then begin AbortReason := RsAbortedByUser; Exit; end; Result := True; end; /// /// DeleteFormDataFiles deletes the .dfm, .xfm files from the lib-path. /// function TCompiler.DeleteFormDataFiles(ProjectGroup: TProjectGroup): Boolean; var Files: TStrings; i: Integer; Dir: string; begin Result := True; Files := TStringList.Create; try Dir := ProjectGroup.TargetConfig.UnitOutDir; FindFiles(Dir, '*.*', False, Files, ['.dfm', '.xfm']); for i := 0 to Files.Count - 1 do DeleteFile(Files[i]); finally Files.Free; end; end; /// /// CopyFormDataFiles copies the .dfm, .xfm files to the lib-path. /// This function is only called for non developer installations. /// function TCompiler.CopyFormDataFiles(ProjectGroup: TProjectGroup; DebugUnits: Boolean): Boolean; var Files: TStrings; i: Integer; Dir, DestDir, DestFile, DebugDestDir: string; begin Result := True; Files := TStringList.Create; try {**}DoProgress('', 0, 100, pkOther); DestDir := ProjectGroup.TargetConfig.UnitOutDir; DebugDestDir := ProjectGroup.TargetConfig.DebugUnitOutDir; Dir := ProjectGroup.TargetConfig.JVCLDir + PathDelim + 'run'; FindFiles(Dir, '*.dfm', False, Files, ['.dfm']); CaptureLine(RsCopyingFiles, FAborted); for i := 0 to Files.Count - 1 do begin DestFile := DestDir + PathDelim + ExtractFileName(Files[i]); if FileAgeEx(Files[i]) > FileAgeEx(DestFile) then begin {**} DoProgress(ExtractFileName(Files[i]), i, Files.Count, pkOther); CopyFile(PChar(Files[i]), PChar(DestFile), False); end; if DebugUnits then begin DestFile := DebugDestDir + PathDelim + ExtractFileName(Files[i]); if FileAgeEx(Files[i]) > FileAgeEx(DestFile) then CopyFile(PChar(Files[i]), PChar(DestFile), False); end; end; {**}DoProgress('', 0, Files.Count, pkOther); finally Files.Free; end; end; procedure TCompiler.SortProjectGroup(Group: TProjectGroup; List: TList); procedure SortProject(Project: TPackageTarget; var ProjectIndex: Integer); var ReqProjectIndex: Integer; ReqPackage: TRequiredPackage; ReqProject: TPackageTarget; ListIndex: Integer; begin for ReqProjectIndex := 0 to Project.RequireCount - 1 do begin ReqPackage := Project.Requires[ReqProjectIndex]; if IsPackageUsed(Group, ReqPackage) then begin // Two cases: the required project is not in the list so we need to add, // or it's already there and not in front so we need to move it. // In both cases, we need to sort the moved/added package recursively // and increment the ProjectIndex only after the recursive sort is done // so that packages required by the current required package are put // in front of it as well. ReqProject := Group.FindPackageByXmlName(ReqPackage.Name); if Assigned(ReqProject) then begin ListIndex := List.IndexOf(ReqProject); if ListIndex = -1 then begin List.Insert(ProjectIndex, ReqProject); SortProject(ReqProject, ProjectIndex); Inc(ProjectIndex); end else if ListIndex > ProjectIndex then begin List.Move(ListIndex, ProjectIndex); SortProject(ReqProject, ProjectIndex); Inc(ProjectIndex); end; end; end; end; end; var CurProject: TPackageTarget; CurProjectIndex: Integer; begin // Add all projects to be compiled into list. for CurProjectIndex := 0 to Group.Count - 1 do if Group[CurProjectIndex].Compile then List.Add(Group[CurProjectIndex]); // Sort according to dependency list: // For each package that must be compiled, put those it requires in front // of it, and this recursively. CurProjectIndex := 0; while CurProjectIndex < List.Count do begin CurProject := List[CurProjectIndex]; SortProject(CurProject, CurProjectIndex); Inc(CurProjectIndex); end; end; /// /// CompileProjectGroup starts the make file for the templates, starts the /// packages generator, calls the GenerateResource method and compiles all /// selected packages of the project group. /// function TCompiler.CompileProjectGroup(ProjectGroup: TProjectGroup; DebugUnits: Boolean): Boolean; var AProjectIndex, i: Integer; TargetConfig: ITargetConfig; DccOpt: string; Edition, JVCLPackagesDir: string; Files: TStrings; ProjectOrder: TList; Project: TPackageTarget; DebugProgress: string; FilesCompiled: Boolean; function GetProjectIndex: Integer; begin Result := AProjectIndex; Inc(AProjectIndex); end; begin Assert(ProjectGroup <> nil, 'The project group file wasn''t found'); Result := False; if FAborted then Exit; DebugProgress := ''; if DebugUnits then DebugProgress := ' (Debug)'; FCurrentProjectGroup := ProjectGroup; try TargetConfig := ProjectGroup.TargetConfig; { remove current JVCL but keep the "Installation tag" valid } TargetConfig.DeinstallJVCL(nil, nil, {RealUninstall:=}False); // obtain information for progress bar FPkgCount := 0; for i := 0 to ProjectGroup.Count - 1 do if ProjectGroup.Packages[i].Compile then Inc(FPkgCount); FPkgIndex := 0; Edition := TargetConfig.TargetSymbol; JVCLPackagesDir := TargetConfig.JVCLPackagesDir; DccOpt := '-M'; // make modified units, output 'never build' DCPs if TargetConfig.Build then DccOpt := DccOpt + ' -B'; if TargetConfig.GenerateMapFiles then DccOpt := DccOpt + ' -GD'; if TargetConfig.Target.IsBDS and (persBCB in TargetConfig.Target.SupportedPersonalities) then // Dual packages, bpi and lib files for BDS 2006 DccOpt := DccOpt + ' -JL'; // for BCB 5/6 the -JPHNE is set during compilation if not DebugUnits and not TargetConfig.DeveloperInstall then DccOpt := DccOpt + ' -DJVCL_NO_DEBUGINFO'; if DebugUnits then begin ForceDirectoriesEx(TargetConfig.DebugUnitOutDir); ForceDirectoriesEx(TargetConfig.DebugBplDir); ForceDirectoriesEx(TargetConfig.DebugDcpDir); ForceDirectoriesEx(TargetConfig.DebugHppDir); end; { Create include directory if necessary } if TargetConfig.Target.SupportsPersonalities([persBCB]) then ForceDirectoriesEx(TargetConfig.Target.ExpandDirMacros(TargetConfig.HppDir)); // ***************************************************************** {**}DoProjectProgress(RsGeneratingPackages + DebugProgress, GetProjectIndex, ProjectMaxProgress); // generate the packages and .cfg files if not GeneratePackages('JVCL', CutPersEdition(Edition), TargetConfig.JVCLPackagesDir) then Exit; // AbortReason is set in GeneratePackages // ***************************************************************** {**}{DoProjectProgress(RsGeneratingResources, GetProjectIndex, ProjectMaxProgress); if not GenerateResources(TargetConfig) then Exit; // AbortReason is set in GenerateResources} // ***************************************************************** {**}DoProjectProgress(RsCompilingPackages + DebugProgress, GetProjectIndex, ProjectMaxProgress); { Remove .dfm/.xfm files from the lib directory so the compiler takes the correct one and we do not have unused files in the lib directory. } DeleteFormDataFiles(ProjectGroup); Files := TStringList.Create; try { .bpl and .dcp files may be in the wrong directory. So delete them. } TargetConfig.GetPackageBinariesForDeletion(Files); for i := 0 to Files.Count - 1 do if not StartsWith(Files[i], TargetConfig.BplDir + PathDelim, True) and not StartsWith(Files[i], TargetConfig.DcpDir + PathDelim, True) then begin if TargetConfig.DebugUnits then begin if StartsWith(Files[i], TargetConfig.DebugBplDir + PathDelim, True) and StartsWith(Files[i], TargetConfig.DebugDcpDir + PathDelim, True) then Continue; end; DeleteFile(Files[i]); end; finally Files.Free; end; { Now compile the packages } DoPackageProgress(nil, '', 0, FPkgCount); ProjectOrder := TList.Create; try SortProjectGroup(ProjectGroup, ProjectOrder); if ProjectOrder.Count > 0 then CaptureLinePackageCompilation('[Compiling: Packages]', FAborted); for i := 0 to ProjectOrder.Count - 1 do begin Project := ProjectOrder[i]; CaptureLinePackageCompilation('[Compiling: ' + Project.TargetName + ']', FAborted); FilesCompiled := False; if TargetConfig.Target.IsBCB and not TargetConfig.Target.IsBDS then begin if CompileCppPackage(TargetConfig, Project, DccOpt, '', '', DebugUnits, FilesCompiled) <> 0 then begin if FAborted then Exit; AbortReason := RsErrorCompilingPackages; Exit; end; end else begin { Create .dcp and .bpl } if CompileDelphiPackage(TargetConfig, Project, DccOpt, DebugUnits, FilesCompiled) <> 0 then begin if FAborted then Exit; AbortReason := RsErrorCompilingPackages; Exit; end; end; {if FilesCompiled and (TargetConfig.Target.SupportedPersonalities * [persBCB] <> []) then AlterHppFiles(TargetConfig, Project);} if FAborted then Exit; end; finally ProjectOrder.Free; end; DoPackageProgress(nil, '', FPkgCount, FPkgCount); // ***************************************************************** {**}DoProjectProgress(RsPostCompilationOperations + DebugProgress, GetProjectIndex, ProjectMaxProgress); if TargetConfig.GenerateMapFiles and (TargetConfig.LinkMapFiles or TargetConfig.CreateJdbgFiles) then begin CaptureLine(sLinkingMapFiles, FAborted); for i := 0 to ProjectGroup.Count - 1 do if ProjectGroup.Packages[i].Compile then LinkMapFile(TargetConfig, ProjectGroup.Packages[i], DebugUnits); end; // ***************************************************************** if not ProjectGroup.TargetConfig.DeveloperInstall {or (TargetConfig.Target.SupportsPersonalities([persBCB], True))} then // only BCB begin {**} DoProjectProgress(RsCopyingFiles + DebugProgress, GetProjectIndex, ProjectMaxProgress); { The .dfm/.xfm files are deleted from the lib directory in the resource generation section in this method. The files are only copied for a non-developer installation and for BCB. } CopyFormDataFiles(ProjectGroup, DebugUnits); end else {**} GetProjectIndex; // increase progress if not FAborted then begin if TargetConfig.CleanPalettes then TargetConfig.CleanJVCLPalette(False); TargetConfig.RegisterToIDE; end; finally {**}DoProjectProgress(RsFinished, ProjectMaxProgress, ProjectMaxProgress); FCurrentProjectGroup := nil; end; Result := True; end; function TCompiler.IsFileUsed(ProjectGroup: TProjectGroup; ContainedFile: TContainedFile): Boolean; begin Result := ContainedFile.IsUsedByTarget(ProjectGroup.TargetConfig.TargetSymbol) and IsCondition(ContainedFile.Condition, ProjectGroup.TargetConfig); end; function TCompiler.IsPackageUsed(ProjectGroup: TProjectGroup; RequiredPackage: TRequiredPackage): Boolean; begin Result := RequiredPackage.IsRequiredByTarget(ProjectGroup.TargetConfig.TargetSymbol) and IsCondition(RequiredPackage.Condition, ProjectGroup.TargetConfig); end; procedure TCompiler.LinkMapFile(TargetConfig: ITargetConfig; Project: TPackageTarget; DebugUnits: Boolean); var BplFilename, MapFilename: string; MapFileSize, JclDebugDataSize: Integer; OutDirs: TOutputDirs; begin OutDirs := TargetConfig.GetOutputDirs(DebugUnits); BplFileName := OutDirs.BplDir + PathDelim + Project.TargetName; MapFileName := ChangeFileExt(BplFileName, '.map'); if FileExists(BplFilename) and FileExists(MapFileName) then begin CaptureLine(Format('Linking %s inside %s', [ExtractFileName(MapFileName), ExtractFileName(BplFileName)]), FAborted); if TargetConfig.LinkMapFiles and not TargetConfig.LinkMapFile(BplFileName, MapFileName, MapFileSize, JclDebugDataSize) then begin CaptureLine(Format('Error: Unable to link %s', [ExtractFileName(MapFileName)]), FAborted); AbortReason := RsErrorLinkingMapFiles; Exit; end; if TargetConfig.CreateJdbgFiles and not TargetConfig.CompressMapFileToJdbg(MapFileName) then begin CaptureLine(Format('Error: Unable to link %s', [ExtractFileName(MapFileName)]), FAborted); AbortReason := RsErrorLinkingMapFiles; Exit; end; if TargetConfig.DeleteMapFiles then begin CaptureLine(Format('Deleting file %s', [ExtractFileName(MapFileName)]), FAborted); if not DeleteFile(MapFileName) then begin CaptureLine(Format('Error: Unable to delete %s', [MapFileName]), FAborted); AbortReason := RsErrorDeletingMapFiles; Exit; end; end; end; end; /// /// AlterHppFiles corrects the *.hpp files that the dcc32.exe compiler has generated. /// - Converts every '#define constant "string"' to "static const char /// (*procedure TCompiler.AlterHppFiles(TargetConfig: ITargetConfig; Project: TPackageTarget); function IsValidTypeName(const Name: string): Boolean; var I: Integer; begin Result := False; for I := 1 to Length(Name) do if not (Name[I] in ['A'..'Z', 'a'..'z', '0'..'9', ':', '_']) then Exit; Result := True; end; function AlterDefine(var f: TextFile; Lines: TStrings): Boolean; var S, Name, TypeName: string; ps: Integer; Value: Integer; begin Result := False; S := Trim(Copy(Lines[Lines.Count - 1], 9, MaxInt)); ps := Pos(' ', S); if (ps > 2) and (ps < Length(S)) then begin { #define name "string" => static const char* name = "string"; } if S[ps + 1] = '"' then begin Name := Copy(S, 1, ps - 1); Lines[Lines.Count - 1] := Format('static const char* %s = %s', [Name, Copy(S, ps + 1, MaxInt)]); while not Eof(f) and (S[Length(S)] = '\') do // line continuation begin ReadLn(f, S); Lines.Add(S); end; Lines[Lines.Count - 1] := Lines[Lines.Count - 1] + ';'; Result := True; end else { #define name (type)(value) => static const type name = (type)(value); } if S[ps + 1] = '(' then begin Name := Copy(S, 1, ps - 1); Delete(S, 1, ps + 1); ps := Pos(')', S); if ps > 2 then begin TypeName := Copy(S, 1, ps - 1); if IsValidTypeName(TypeName) then begin Delete(S, 1, ps); if (S <> '') and (S[1] = '(') and (S[Length(S)] = ')') and TryStrToInt(Copy(S, 2, Length(S) - 2), Value) then begin Lines[Lines.Count - 1] := Format('static const %s %s = (%s)(%d);', [TypeName, Name, TypeName, Value]); Result := True; end; end; end; end; end; end; procedure AlterHppFile(const Filename: string); var Lines: TStrings; Modified: Boolean; S: string; f: TextFile; begin Lines := TStringList.Create; try AssignFile(f, Filename); Reset(f); try Modified := False; while not Eof(f) do begin ReadLn(f, S); Lines.Add(S); if StartsWith(S, '#define ', False) then begin if AlterDefine(f, Lines) then Modified := True; end; end; finally CloseFile(f); end; if Modified then Lines.SaveToFile(Filename); finally Lines.Free; end; end; var I: Integer; HppDir, Filename: string; begin HppDir := TargetConfig.HppDir; for I := 0 to Project.ContainCount - 1 do begin Filename := HppDir + PathDelim + ChangeFileExt(ExtractFileName(Project.Contains[I].Name), '.hpp'); if FileExists(Filename) then AlterHppFile(Filename); end; end;*) type { TListConditionParser searches for the idents in the List. If an ident is in the list the ident is returned as True. } TListConditionParser = class(TConditionParser) private FTargetConfig: ITargetConfig; protected procedure MissingRightParenthesis; override; function GetIdentValue(const Ident: String): Boolean; override; public constructor Create(ATargetConfig: ITargetConfig); end; function TCompiler.IsCondition(const Condition: string; TargetConfig: ITargetConfig): Boolean; var Parser: TListConditionParser; begin Result := True; if Condition <> '' then begin Parser := TListConditionParser.Create(TargetConfig); try Result := Parser.Parse(Condition); finally Parser.Free; end; end; end; function TCompiler.IsDcc32BugDangerous(TargetConfig: ITargetConfig): Boolean; begin if TargetConfig.Target.Version <= 7 then Result := Length(Data.JVCLDir) > MaxDcc32PathLen else Result := False; end; { TListConditionParser } constructor TListConditionParser.Create(ATargetConfig: ITargetConfig); begin inherited Create; FTargetConfig := ATargetConfig; end; function TListConditionParser.GetIdentValue(const Ident: String): Boolean; begin Result := FTargetConfig.JVCLConfig.Enabled[Ident]; end; procedure TListConditionParser.MissingRightParenthesis; begin raise Exception.Create('Missing ")" in conditional expression'); end; end.