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

* example for unit advancedipc by Ondrej Pokorny added

Browse Source 
git-svn-id: trunk@31939 -
This commit is contained in:
Tomas Hajny 2015-10-03 21:25:53 +00:00
parent 8746c68a29
commit 8b522e0ff3
3 changed files with 204 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -1981,6 +1981,8 @@ packages/fcl-base/examples/testcont.pp svneol=native#text/plain
packages/fcl-base/examples/testexprpars.pp svneol=native#text/plain
packages/fcl-base/examples/testez.pp svneol=native#text/plain
packages/fcl-base/examples/testhres.pp svneol=native#text/plain
packages/fcl-base/examples/testipc_client.pp svneol=native#text/plain
packages/fcl-base/examples/testipc_server.pp svneol=native#text/plain
packages/fcl-base/examples/testmime.pp svneol=native#text/plain
packages/fcl-base/examples/testnres.pp svneol=native#text/plain
packages/fcl-base/examples/testol.pp svneol=native#text/plain

97
packages/fcl-base/examples/testipc_client.pp Normal file
View File

@ -0,0 +1,97 @@
program testipc_client;
{$MODE ObjFPC}
{$H+}
uses
Classes, SysUtils, AdvancedIPC;
const
STRINGMESSAGE_WANTS_RESPONSE = 3;
STRINGMESSAGE_NO_RESPONSE = 2;
MESSAGE_STOP = 4;
var
xClient, xClientNotRunning: TIPCClient;
xStream, xResponseStream: TStringStream;
xRequestID: Integer;
xMsgType: TMessageType;
I: Integer;
begin
xClient := nil;
xClientNotRunning := nil;
xStream := nil;
xResponseStream := nil;
try
xResponseStream := TStringStream.Create('OK');
//check connection to to the "hello" server (that has to run)
xClient := TIPCClient.Create(nil);
xClient.ServerID := 'hello';
if not xClient.ServerRunning then
begin
Writeln('ERROR: Server '+xClient.ServerID+' is not running.');
Writeln('Closing');
Exit;
end;
//first send some messages to server that is not running
xClientNotRunning := TIPCClient.Create(nil);
xClientNotRunning.ServerID := 'not_running';
if xClientNotRunning.ServerRunning then
begin
Writeln('ERROR: Server '+xClientNotRunning.ServerID+' is running. This test needs that the server doesn''t run.');
Writeln('Closing');
Exit;
end;
for I := 1 to 10 do
begin
FreeAndNil(xStream);
xStream := TStringStream.Create('Message '+IntToStr(I));
xStream.Position := 0;
xClientNotRunning.PostRequest(STRINGMESSAGE_NO_RESPONSE, xStream);
end;
FreeAndNil(xClientNotRunning);
//now send messages to the "hello" server
FreeAndNil(xStream);
xStream := TStringStream.Create('I want some response.');
xStream.Position := 0;
if xClient.SendRequest(STRINGMESSAGE_WANTS_RESPONSE, xStream, 100, xRequestID) and
xClient.PeekResponse(xResponseStream, xMsgType, 100)
then
Writeln('Request-response test OK.')
else
Writeln('ERROR: Request-response test failed.');
FreeAndNil(xStream);
xStream := TStringStream.Create('I do not want any response.');
xStream.Position := 0;
if xClient.SendRequest(STRINGMESSAGE_NO_RESPONSE, xStream, 100, xRequestID) then
begin
if xClient.PeekResponse(xResponseStream, xMsgType, 100) then
Writeln('ERROR: I received a response even that I didn''t want any. What happened?')
else
Writeln('Request test OK.');
end else
Writeln('ERROR: Request test failed.');
if xClient.SendRequest(MESSAGE_STOP, nil, 100) and
not xClient.ServerRunning
then
Writeln('Server was sucessfully stopped.')
else
Writeln('ERROR: I could not stop the server.')
finally
xClient.Free;
xClientNotRunning.Free;
xStream.Free;
xResponseStream.Free;
end;
end.

105
packages/fcl-base/examples/testipc_server.pp Normal file
View File

@ -0,0 +1,105 @@
program testipc_server;
{$MODE ObjFPC}
{$H+}
uses
Classes, SysUtils, AdvancedIPC;
const
STRINGMESSAGE_WANTS_RESPONSE = 3;
STRINGMESSAGE_NO_RESPONSE = 2;
MESSAGE_STOP = 4;
var
xServer: TIPCServer;
xStream, xResponseStream: TStringStream;
xMsgID: Integer;
xMsgType: TMessageType;
xNotRunningMessagesCount: Integer;
begin
xServer := nil;
xStream := nil;
xResponseStream := nil;
try
xStream := TStringStream.Create('');
xResponseStream := TStringStream.Create('OK');
//first get all messages from the hello server
xServer := TIPCServer.Create(nil);
xServer.ServerID := 'hello';
xServer.StartServer;
WriteLn('Server ', xServer.ServerID, ' started.');
WriteLn('-----');
while True do
begin
if xServer.PeekRequest(xMsgID{%H-}, xMsgType{%H-}) then
begin
case xMsgType of
STRINGMESSAGE_WANTS_RESPONSE, STRINGMESSAGE_NO_RESPONSE:
begin
xServer.ReadRequest(xMsgID, xStream);
WriteLn('Received string message:');
WriteLn(xStream.DataString);
if xMsgType = STRINGMESSAGE_WANTS_RESPONSE then
begin
xResponseStream.Position := 0;
xServer.PostResponse(xMsgID, STRINGMESSAGE_NO_RESPONSE, xResponseStream);
WriteLn('Posting response.');
end;
WriteLn('-----');
end;
MESSAGE_STOP:
begin
WriteLn('Stopping '+xServer.ServerID+' server.');
WriteLn('-----');
Break;
end;
end;
end else
Sleep(50);
end;
FreeAndNil(xServer);
//now try to get all unhandled messages from the not_running server
//please see that the messages are not peeked in the order they have been posted (this is correct/designed behavior).
xServer := TIPCServer.Create(nil);
xServer.ServerID := 'not_running';
xServer.StartServer(False);
WriteLn('');
WriteLn('Server ', xServer.ServerID, ' started.');
WriteLn('-----');
xNotRunningMessagesCount := 0;
while xServer.PeekRequest(xStream, xMsgID, xMsgType) do
begin
if xMsgType = STRINGMESSAGE_NO_RESPONSE then
begin
WriteLn('Received message: ', xStream.DataString);
Inc(xNotRunningMessagesCount);
end else
WriteLn('ERROR: Wrong message type: ', xMsgType);
WriteLn('-----');
end;
if xNotRunningMessagesCount <> 10 then
begin
WriteLn('ERROR: Wrong message count: ', xNotRunningMessagesCount);
WriteLn('-----');
end;
WriteLn('Stopping '+xServer.ServerID+' server.');
WriteLn('-----');
FreeAndNil(xServer);
finally
xServer.Free;
xStream.Free;
xResponseStream.Free;
end;
end.