paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-31 04:52:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

Compiler/OutputFilter: Prepare using Application.QueueAsyncCall instead of ProcessMessages

Browse Source 
git-svn-id: trunk@24589 -
This commit is contained in:
martin 2010-04-12 00:39:34 +00:00
parent c35d025dac
commit 907fb4c6ab
2 changed files with 287 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
ide/compiler.pp
View File

@ -40,30 +40,49 @@ interface
uses
Classes, SysUtils, Process, LCLProc, Forms, Controls, FileUtil, InfoBuild,
LazarusIDEStrConsts, CompilerOptions, Project, OutputFilter, UTF8Process;
LazarusIDEStrConsts, CompilerOptions, Project, OutputFilter, UTF8Process,
LazIDEIntf, ProjectIntf;
type
TOnCmdLineCreate = procedure(var CmdLine: string; var Abort:boolean)
of object;
TBuildProjectData = class
public
Reason: TCompileReason;
Flags: TProjectBuildFlags;
CompilerFilename: String;
CompilerParams: String;
end;
{ TCompiler }
TCompiler = class(TObject)
private
FASyncResult: TModalResult;
FOnCmdLineCreate : TOnCmdLineCreate;
FOutputFilter: TOutputFilter;
FTheProcess: TProcessUTF8;
FOldCurDir: string;
FFinishedCallback: TNotifyEvent;
procedure CompilationFinished(Sender: TObject);
public
// Values stored by caller, to be rtrieved on callback
CallerData: TObject;
public
constructor Create;
destructor Destroy; override;
function Compile(AProject: TProject;
const WorkingDir, CompilerFilename, CompilerParams: string;
BuildAll, SkipLinking, SkipAssembler: boolean): TModalResult;
const WorkingDir, CompilerFilename, CompilerParams: string;
BuildAll, SkipLinking, SkipAssembler: boolean;
aFinishedCallback: TNotifyEvent = nil
): TModalResult;
procedure WriteError(const Msg: string);
property OnCommandLineCreate: TOnCmdLineCreate read FOnCmdLineCreate
write FOnCmdLineCreate;
property OutputFilter: TOutputFilter read FOutputFilter write FOutputFilter;
property TheProcess: TProcessUTF8 read FTheProcess;
property ASyncResult: TModalResult read FASyncResult;
end;
@ -75,6 +94,7 @@ implementation
{------------------------------------------------------------------------------
TCompiler Constructor
------------------------------------------------------------------------------}
constructor TCompiler.Create;
begin
inherited Create;
@ -94,20 +114,22 @@ end;
------------------------------------------------------------------------------}
function TCompiler.Compile(AProject: TProject;
const WorkingDir, CompilerFilename, CompilerParams: string;
BuildAll, SkipLinking, SkipAssembler: boolean): TModalResult;
BuildAll, SkipLinking, SkipAssembler: boolean;
aFinishedCallback: TNotifyEvent = nil): TModalResult;
var
CmdLine : String;
Abort : Boolean;
OldCurDir: string;
begin
Result:=mrCancel;
FASyncResult:= mrNone;
FFinishedCallback := aFinishedCallback;
DebugLn('TCompiler.Compile WorkingDir="',WorkingDir,'" CompilerFilename="',CompilerFilename,'" CompilerParams="',CompilerParams,'"');
// if we want to show the compile progress, it's now time to show the dialog
CompileProgress.Show;
// change working directory
OldCurDir:=GetCurrentDirUTF8;
FOldCurDir:=GetCurrentDirUTF8;
if not SetCurrentDirUTF8(WorkingDir) then begin
WriteError('TCompiler.Compile unable to set working directory '+WorkingDir);
exit;
@ -166,12 +188,15 @@ begin
if OutputFilter<>nil then begin
OutputFilter.Options:=[ofoSearchForFPCMessages,ofoExceptionOnError];
OutputFilter.CompilerOptions:=AProject.CompilerOptions;
OutputFilter.Execute(TheProcess,Self);
if aFinishedCallback <> nil then begin
OutputFilter.ExecuteAsyncron(TheProcess, @CompilationFinished, Self);
end else
OutputFilter.Execute(TheProcess,Self);
end else begin
TheProcess.Execute;
end;
finally
if TheProcess.Running then
if TheProcess.Running and ((OutputFilter = nil) or (aFinishedCallback = nil)) then
begin
TheProcess.WaitOnExit;
if not (TheProcess.ExitStatus in [0,1]) then begin
@ -193,11 +218,27 @@ begin
end;
end;
finally
SetCurrentDirUTF8(OldCurDir);
SetCurrentDirUTF8(FOldCurDir);
end;
DebugLn('[TCompiler.Compile] end');
end;
procedure TCompiler.CompilationFinished(Sender: TObject);
begin
FASyncResult:= mrOK;
if TheProcess.Running then begin
TheProcess.WaitOnExit;
if not (TheProcess.ExitStatus in [0,1]) then begin
WriteError(Format(listCompilerInternalError,[TheProcess.ExitStatus]));
FASyncResult:=mrCancel;
end;
end;
DebugLn('[TCompiler.Compile] Async end');
if assigned(FFinishedCallback) then
FFinishedCallback(Self);
end;
procedure TCompiler.WriteError(const Msg: string);
begin
DebugLn('TCompiler.WriteError ',Msg);

279
ide/outputfilter.pas
View File

@ -98,13 +98,17 @@ type
property Filter: TOutputFilter read FFilter;
end;
TOutputFilterState = (ofsNone, ofsRunning, ofsSucceded, ofsFailed, ofsAborted);
{ TOutputFilter }
TOutputFilter = class
private
FAsyncDataAvailable: boolean;
FAsyncProcessTerminated: boolean;
FLastAsyncExecuteTime: TDateTime;
FCaller: TObject;
FFinishedCallback: TNotifyEvent;
FCompilerOptions: TBaseCompilerOptions;
FBufferingOutputLock: integer;
fCurrentDirectory: string;
@ -122,12 +126,15 @@ type
fOnAddFilteredLine: TOnAddFilteredLine;
fOptions: TOuputFilterOptions;
FScanLine: TOFScanLine;
FState: TOutputFilterState;
FHasReadErrorLine: Boolean;
FStopExecute: boolean;
FLasTOutputLineParts: integer;
fLastOutputTime: TDateTime;
fLastSearchedShortIncFilename: string;
fLastSearchedIncFilename: string;
fProcess: TProcessUTF8;
FAsyncProcess: TAsyncProcess;
FAsyncOutput: TDynamicDataQueue;
FScanners: TFPList; // list of TIDEMsgScanner
FTool: TIDEExternalToolOptions;
@ -147,7 +154,10 @@ type
procedure OnAsyncReadData(Sender: TObject);
function CreateScanners(ScannerOptions: TStrings): boolean;
procedure ClearScanners;
protected
procedure InitExecute;
procedure CleanUpExecute;
procedure ContinueAsyncExecute(Data: PtrInt);
protected
procedure SetErrorName(errtype: TFPCErrorType; const AValue: String );
function GetErrorName(errtype: TFPCErrorType): string;
public
@ -155,6 +165,10 @@ type
Aborted: boolean;
function Execute(TheProcess: TProcessUTF8; aCaller: TObject = nil;
aTool: TIDEExternalToolOptions = nil): boolean;
function ExecuteAsyncron(TheProcess: TProcessUTF8;
aFinishedCallback: TNotifyEvent;
aCaller: TObject = nil;
aTool: TIDEExternalToolOptions = nil): boolean;
procedure Clear;
constructor Create;
destructor Destroy; override;
@ -197,7 +211,8 @@ type
property Tool: TIDEExternalToolOptions read FTool;
property ScannerCount: integer read GetScannerCount;
property Scanners[Index: integer]: TIDEMsgScanner read GetScanners;
property ErrorTypeName[errType: TFPCErrorType]: string read GetErrorName write SetErrorName;
property ErrorTypeName[errType: TFPCErrorType]: string read GetErrorName write SetErrorName;
property State: TOutputFilterState read FState;
end;
EOutputFilterError = class(Exception)
@ -219,6 +234,7 @@ implementation
constructor TOutputFilter.Create;
begin
inherited Create;
FState := ofsNone;
fFilteredOutput:=TFilteredOutputLines.Create;
fOutput:=TIDEMessageLineList.Create;
fOptions:=[ofoSearchForFPCMessages,ofoSearchForMakeMessages,
@ -240,6 +256,53 @@ begin
fLastSearchedIncFilename:='';
end;
procedure TOutputFilter.InitExecute;
begin
//debugln('TOutputFilter.Execute A CurrentDirectory="',TheProcess.CurrentDirectory,'"');
fCurrentDirectory:=TrimFilename(fProcess.CurrentDirectory);
if fCurrentDirectory='' then fCurrentDirectory:=GetCurrentDirUTF8;
fCurrentDirectory:=AppendPathDelim(fCurrentDirectory);
ErrorExists:=true;
Aborted:=false;
//Darwin linker features
DarwinLinkerMultiline:=false;
DarwinLinkerLine:='';
end;
procedure TOutputFilter.CleanUpExecute;
begin
// workaround for missing TProcess error handling
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W2');
{$ENDIF}
EndBufferingOutput;
fProcess:=nil;
FAsyncProcess:= nil;
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W3');
{$ENDIF}
FreeAndNil(FAsyncOutput);
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W4');
{$ENDIF}
if Assigned(OnEndReading) then OnEndReading(Self,fOutput);
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W5');
{$ENDIF}
FreeAndNil(FScanLine);
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W6');
{$ENDIF}
FTool:=nil;
FCaller:=nil;
ClearScanners;
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W7');
{$ENDIF}
end;
function TOutputFilter.Execute(TheProcess: TProcessUTF8; aCaller: TObject;
aTool: TIDEExternalToolOptions): boolean;
const
@ -253,29 +316,22 @@ var
ExceptionMsg: String;
begin
Result:=true;
if FState = ofsRunning then RaiseGDBException('OutputFilter already running');
Clear;
fProcess:=TheProcess;
FCaller:=aCaller;
FTool:=aTool;
FScanLine:=TOFScanLine.Create(Self);
//debugln('TOutputFilter.Execute A CurrentDirectory="',TheProcess.CurrentDirectory,'"');
fCurrentDirectory:=TrimFilename(fProcess.CurrentDirectory);
if fCurrentDirectory='' then fCurrentDirectory:=GetCurrentDirUTF8;
fCurrentDirectory:=AppendPathDelim(fCurrentDirectory);
SetLength(Buf,BufSize);
InitExecute;
SetLength(Buf,BufSize);
OutputLine:='';
ErrorExists:=true;
Aborted:=false;
TheAsyncProcess:=nil;
EndUpdateNeeded:=false;
ExceptionMsg:='';
//Darwin linker features
DarwinLinkerMultiline:=false;
DarwinLinkerLine:='';
try
BeginBufferingOutput;
@ -378,43 +434,182 @@ begin
ExceptionMsg:='the process exited with error code '+dbgs(fProcess.ExitStatus);
end;
finally
// workaround for missing TProcess error handling
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W1');
{$ENDIF}
if EndUpdateNeeded then
EndUpdate;
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W2');
{$ENDIF}
EndBufferingOutput;
fProcess:=nil;
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W3');
{$ENDIF}
FreeAndNil(FAsyncOutput);
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W4');
{$ENDIF}
if Assigned(OnEndReading) then OnEndReading(Self,fOutput);
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W5');
{$ENDIF}
FreeAndNil(FScanLine);
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W6');
{$ENDIF}
FTool:=nil;
FCaller:=nil;
ClearScanners;
{$IFDEF VerboseOFExecute}
WriteLn('TOutputFilter.Execute W7');
{$ENDIF}
CleanUpExecute;
end;
if ExceptionMsg<>'' then
raise EOutputFilterError.Create(ExceptionMsg);
end;
function TOutputFilter.ExecuteAsyncron(TheProcess: TProcessUTF8;
aFinishedCallback: TNotifyEvent; aCaller: TObject; aTool: TIDEExternalToolOptions): boolean;
begin
Result := False;
if FState = ofsRunning then RaiseGDBException('OutputFilter already running');
FState := ofsRunning;
FHasReadErrorLine := False;
Clear;
fProcess:=TheProcess;
FCaller:=aCaller;
FFinishedCallback := aFinishedCallback;
FTool:=aTool;
FScanLine:=TOFScanLine.Create(Self);
InitExecute;
try
BeginBufferingOutput;
// create custom scanners
ClearScanners;
if (Tool<>nil) and (Tool.Scanners<>nil)
and (not CreateScanners(Tool.Scanners)) then
exit;
//debugln(['TOutputFilter.Execute ',dbgsname(fProcess)]);
if fProcess is TAsyncProcess then begin
FAsyncProcess:=TAsyncProcess(fProcess);
FAsyncProcess.OnReadData:=@OnAsyncReadData;
FAsyncProcess.OnTerminate:=@OnAsyncTerminate;
FAsyncOutput:=TDynamicDataQueue.Create;
end;
fProcess.Execute;
Result := True;
FLastAsyncExecuteTime := Now;
finally
if Result then
Application.QueueAsyncCall(@ContinueAsyncExecute, 0)
else begin
CleanUpExecute;
FState := ofsFailed;
FFinishedCallback(Self);
end;
end;
end;
procedure TOutputFilter.ContinueAsyncExecute(Data: PtrInt);
procedure CheckTermintedProcess;
begin
if fProcess.WaitOnExit then begin
//DebugLn('TOutputFilter.Execute fProcess.ExitStatus=',dbgs(fProcess.ExitStatus));
if fProcess.ExitStatus=0 then
ErrorExists:=false;
end;
end;
const
BufSize = 4096;
var
i, Count, LineStart : longint;
OutputLine, Buf : String;
AsyncExecuteTime: TDateTime;
begin
try
if FState <> ofsRunning then exit;
if StopExecute then begin
try
fProcess.Terminate(0);
Aborted:=true;
ReadConstLine('aborted',true);
CheckTermintedProcess;
finally
FState := ofsAborted;
CleanUpExecute;
FFinishedCallback(Self);
end;
exit;
end;
AsyncExecuteTime:=Now;
SetLength(Buf,BufSize);
OutputLine:='';
try
BeginUpdate;
repeat
// Read data
Count:=0;
if (FAsyncProcess<>nil) then begin
// using non blocking TAsyncProcess
Count:=FAsyncOutput.Size;
if Count>0 then
Count:=FAsyncOutput.Pop(Buf[1],Min(Count,length(Buf)))
else if AsyncProcessTerminated then begin
Count:=FAsyncProcess.NumBytesAvailable;
if Count>0 then begin
Count:=fProcess.Output.Read(Buf[1],Min(Count,length(Buf)));
end else begin
FState := ofsSucceded;
break;
end;
end else begin
// no new input, but process still running
Sleep(30);
end;
end;
if (FAsyncProcess=nil) and (fProcess.Output<>nil) then begin
// using a blocking TProcess
Count:=fProcess.Output.Read(Buf[1],length(Buf));
if Count=0 then begin
// no output on blocking means, process has ended
FState := ofsSucceded;
break;
end;
end;
//DebugLn('TOutputFilter.Execute Count=',dbgs(Count));
LineStart:=1;
i:=1;
while i<=Count do begin
if Buf[i] in [#10,#13] then begin
OutputLine:=OutputLine+copy(Buf,LineStart,i-LineStart);
ReadLine(OutputLine,false);
if fLastErrorType in [etFatal, etPanic, etError] then begin
FHasReadErrorLine := True;
end;
OutputLine:='';
if (i<Count) and (Buf[i+1] in [#10,#13]) and (Buf[i]<>Buf[i+1])
then
inc(i);
LineStart:=i+1;
end;
inc(i);
end;
OutputLine:=OutputLine+copy(Buf,LineStart,Count-LineStart+1);
// Repeat, if we did have something to read
until (Count = 0) or (abs(Now - FLastAsyncExecuteTime) > ((1/86400)/15));
if not(FState = ofsRunning) then
CheckTermintedProcess;
finally
FLastAsyncExecuteTime := AsyncExecuteTime;
if (FState = ofsSucceded) and FHasReadErrorLine then
FState := ofsFailed;
EndUpdate;
if FState = ofsRunning then
Application.QueueAsyncCall(@ContinueAsyncExecute, 0)
else begin
CleanUpExecute;
FFinishedCallback(Self);
end;
end;
except
try
fProcess.Terminate(0);
except end;
FFinishedCallback(Self);
end;
end;
procedure TOutputFilter.ReadLine(var s: string; DontFilterLine: boolean);
// this is called for every line written by the external tool (=Output)
// it parses the output
@ -1280,7 +1475,7 @@ begin
end;
end;
procedure TOutputFilter.SetErrorName(errType: TFPCErrorType; const AValue: String);
procedure TOutputFilter.SetErrorName(errType: TFPCErrorType; const AValue: String);
begin
FErrorNames[errType]:=AValue;
end;