freepascal.compiler/packages/fcl-base/examples/sitest.pp

program SITest;

{$mode objfpc}
{$h+}

uses
  Classes,
  CustApp, advancedipc, singleinstance;

type
  TMyCustomApplication = class(TCustomApplication)
  private
    procedure ServerReceivedParams(Sender: TBaseSingleInstance; aParams: TStringList);
    procedure ServerReceivedCustomRequest(Sender: TBaseSingleInstance; {%H-}MsgID: Integer; aMsgType: TMessageType; MsgData: TStream);
  end;

const
  MsgType_Request_No_Response = 1;
  MsgType_Request_With_Response = 2;
  MsgType_Response = 3;

{ TMyCustomApplication }

procedure TMyCustomApplication.ServerReceivedCustomRequest(
  Sender: TBaseSingleInstance; MsgID: Integer; aMsgType: TMessageType;
  MsgData: TStream);
var
  xData: string;
  xStringStream: TStringStream;
begin
  MsgData.Position := 0;
  SetLength(xData, MsgData.Size div SizeOf(Char));
  if MsgData.Size > 0 then
    MsgData.ReadBuffer(xData[1], MsgData.Size);

  WriteLn('Request: ', xData);

  if aMsgType = MsgType_Request_With_Response then
  begin
    WriteLn('Sending response to client.');
    xStringStream := TStringStream.Create('my response');
    try
      (Sender as TAdvancedSingleInstance).ServerPostCustomResponse(MsgID, MsgType_Response, xStringStream);
    finally
      xStringStream.Free;
    end;
  end;
end;

procedure TMyCustomApplication.ServerReceivedParams(Sender: TBaseSingleInstance;
  aParams: TStringList);
var
  I: Integer;
begin
  Writeln('-----');
  Writeln('Params:');
  for I := 0 to aParams.Count-1 do
    Writeln(aParams[I]);
  Writeln('-----');
end;

var
  xApp: TMyCustomApplication;
  xStream: TStringStream;
  xMsgType: TMessageType;
begin
  xApp := TMyCustomApplication.Create(nil);
  try
    xApp.SingleInstanceEnabled := True;
    xApp.SingleInstance.OnServerReceivedParams := @xApp.ServerReceivedParams;
    (xApp.SingleInstance as TAdvancedSingleInstance).OnServerReceivedCustomRequest := @xApp.ServerReceivedCustomRequest;
    xApp.Initialize;
    Writeln(xApp.SingleInstance.StartResult);
    xApp.Run;

    case xApp.SingleInstance.StartResult of
      siNotResponding: ReadLn;
      siClient:
      begin
        xStream := TStringStream.Create('hello');
        try
          (xApp.SingleInstance as TAdvancedSingleInstance).ClientSendCustomRequest(MsgType_Request_No_Response, xStream);
        finally
          xStream.Free;
        end;
        xStream := TStringStream.Create('I want a response');
        try
          (xApp.SingleInstance as TAdvancedSingleInstance).ClientSendCustomRequest(MsgType_Request_With_Response, xStream);
          xStream.Size := 0;
          if (xApp.SingleInstance as TAdvancedSingleInstance).ClientPeekCustomResponse(xStream, xMsgType) then
            WriteLn('Response: ', xStream.DataString)
          else
            WriteLn('Error: no response');
        finally
          xStream.Free;
        end;
        ReadLn;
      end;
    end;
  finally
    xApp.Free;
  end;
end.