paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 00:39:34 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Test programs for crashing IPC server

Browse Source 
git-svn-id: trunk@33698 -
This commit is contained in:
michael 2016-05-16 16:22:39 +00:00
parent d53c4b4153
commit 5f8fd810b8
5 changed files with 258 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -2603,6 +2603,8 @@ packages/fcl-pdf/utils/ttfdump.lpr svneol=native#text/plain
packages/fcl-process/Makefile svneol=native#text/plain
packages/fcl-process/Makefile.fpc svneol=native#text/plain
packages/fcl-process/Makefile.fpc.fpcmake svneol=native#text/plain
packages/fcl-process/examples/checkipcserver.lpi svneol=native#text/plain
packages/fcl-process/examples/checkipcserver.lpr svneol=native#text/plain
packages/fcl-process/examples/demoproject.ico -text
packages/fcl-process/examples/demoproject.lpi svneol=native#text/plain
packages/fcl-process/examples/demoproject.pp svneol=native#text/plain
@ -2616,6 +2618,8 @@ packages/fcl-process/examples/ipcclient.lpi svneol=native#text/plain
packages/fcl-process/examples/ipcclient.pp svneol=native#text/plain
packages/fcl-process/examples/ipcserver.lpi svneol=native#text/plain
packages/fcl-process/examples/ipcserver.pp svneol=native#text/plain
packages/fcl-process/examples/simpleipcserver.lpi svneol=native#text/plain
packages/fcl-process/examples/simpleipcserver.lpr svneol=native#text/plain
packages/fcl-process/examples/waitonexit.pp svneol=native#text/pascal
packages/fcl-process/fpmake.pp svneol=native#text/plain
packages/fcl-process/src/amicommon/pipes.inc svneol=native#text/plain

59
packages/fcl-process/examples/checkipcserver.lpi Normal file
View File

@ -0,0 +1,59 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="IPC Client"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="checkipcserver.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="checkipcserver"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

55
packages/fcl-process/examples/checkipcserver.lpr Normal file
View File

@ -0,0 +1,55 @@
program checkipcserver;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils, CustApp, simpleipc
{ you can add units after this };
type
{ TSimpleIPCClientApp }
TSimpleIPCClientApp = class(TCustomApplication)
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
end;
{ TSimpleIPCClientApp }
procedure TSimpleIPCClientApp.DoRun;
var
IPCClient: TSimpleIPCClient;
begin
IPCClient := TSimpleIPCClient.Create(nil);
IPCClient.ServerID:= 'ipc_test_crash';
if IPCClient.ServerRunning then
WriteLn('Server is runnning')
else
WriteLn('Server is NOT runnning');
IPCClient.Destroy;
Terminate;
end;
constructor TSimpleIPCClientApp.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
end;
var
Application: TSimpleIPCClientApp;
begin
Application:=TSimpleIPCClientApp.Create(nil);
Application.Title:='IPC Client';
Application.Run;
Application.Free;
end.

59
packages/fcl-process/examples/simpleipcserver.lpi Normal file
View File

@ -0,0 +1,59 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="IPC Server"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="simpleipcserver.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="simpleipcserver"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

81
packages/fcl-process/examples/simpleipcserver.lpr Normal file
View File

@ -0,0 +1,81 @@
program simpleipcserver;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}
BaseUnix,
{$ENDIF}
{$IFDEF windows}
Windows,
{$ENDIF}
Classes, SysUtils, CustApp, simpleipc, Crt;
type
{ TSimpleIPCServerApp }
TSimpleIPCServerApp = class(TCustomApplication)
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
end;
{ TSimpleIPCServerApp }
procedure TSimpleIPCServerApp.DoRun;
var
IPCServer: TSimpleIPCServer;
Key: Char;
NullObj: TObject;
begin
IPCServer := TSimpleIPCServer.Create(nil);
IPCServer.ServerID:='ipc_test_crash';
IPCServer.Global:=True;
IPCServer.StartServer;
NullObj := nil;
WriteLn('Server started');
WriteLn(' Press e to finish with an exception');
WriteLn(' Press t to terminate through OS api - ', {$IFDEF UNIX}'Kill'{$ELSE}'TerminateProcess'{$ENDIF});
WriteLn(' Press any other key to finish normally');
Key := ReadKey;
case Key of
'e':
begin
NullObj.AfterConstruction;
end;
't':
begin
{$ifdef unix}
FpKill(FpGetpid, 9);
{$endif}
{$ifdef windows}
TerminateProcess(GetCurrentProcess, 0);
{$endif}
end;
end;
IPCServer.Active:=False;
WriteLn('Server stopped');
IPCServer.Destroy;
Terminate;
end;
constructor TSimpleIPCServerApp.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
end;
var
Application: TSimpleIPCServerApp;
begin
Application:=TSimpleIPCServerApp.Create(nil);
Application.Title:='IPC Server';
Application.Run;
Application.Free;
end.