1{ 2 This file is part of the Free Component library. 3 Copyright (c) 2007 by Tomas Hajny, member of 4 the Free Pascal development team 5 6 OS/2 implementation of one-way IPC between 2 processes 7 8 See the file COPYING.FPC, included in this distribution, 9 for details about the copyright. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 14 15 **********************************************************************} 16 17uses DosCalls, OS2Def; 18 19ResourceString 20 SErrFailedToCreatePipe = 'Failed to create named pipe: %s'; 21 SErrFailedToDisconnectPipe = 'Failed to disconnect named pipe: %s'; 22 23const 24(* Constant used as key identifying a pipe connected to event semaphore. *) 25(* 'FP' *) 26 PipeKey = $4650; 27 PipeBufSize = 256; 28 29{ --------------------------------------------------------------------- 30 TPipeClientComm 31 ---------------------------------------------------------------------} 32 33Type 34 TPipeClientComm = Class(TIPCClientComm) 35 Private 36 FFileName: String; 37 FStream: TFileStream; 38 Public 39 Constructor Create(AOWner : TSimpleIPCClient); override; 40 Procedure Connect; override; 41 Procedure Disconnect; override; 42 Procedure SendMessage(MsgType : TMessageType; AStream : TStream); override; 43 Function ServerRunning : Boolean; override; 44 Property FileName : String Read FFileName; 45 Property Stream : TFileStream Read FStream; 46 end; 47 48 49constructor TPipeClientComm.Create (AOWner: TSimpleIPCClient); 50begin 51 inherited Create (AOWner); 52 FFileName:= '\PIPE\' + Owner.ServerID; 53 If (Owner.ServerInstance <> '') then 54 FFileName := FFileName + '.' + Owner.ServerInstance; 55end; 56 57 58procedure TPipeClientComm.Connect; 59begin 60 try 61 FStream := TFileStream.Create (FFileName, fmOpenWrite); 62 finally 63 Owner.DoError (SErrServerNotActive, [Owner.ServerID]); 64 end; 65end; 66 67 68procedure TPipeClientComm.Disconnect; 69begin 70 FreeAndNil (FStream); 71end; 72 73 74procedure TPipeClientComm.SendMessage (MsgType: TMessageType; AStream: TStream); 75var 76 Hdr: TMsgHeader; 77begin 78 Hdr.Version := MsgVersion; 79 Hdr.MsgType := MsgType; 80 Hdr.MsgLen := AStream.Size; 81 FStream.WriteBuffer (Hdr, SizeOf (Hdr)); 82 FStream.CopyFrom (AStream, 0); 83end; 84 85 86function TPipeClientComm.ServerRunning: boolean; 87begin 88{$WARNING Fake TPipeClientComm.ServerRunning - no safe solution known} 89 Result := true; 90end; 91 92 93{ --------------------------------------------------------------------- 94 TPipeServerComm 95 ---------------------------------------------------------------------} 96 97type 98 TPipeServerComm = class (TIPCServerComm) 99 private 100 FFileName: string; 101 FStream: THandleStream; 102 EventSem: THandle; 103 SemName: string; 104 public 105 constructor Create (AOWner: TSimpleIPCServer); override; 106 procedure StartServer; override; 107 procedure StopServer; override; 108 function PeekMessage (TimeOut: integer): boolean; override; 109 procedure ReadMessage; override; 110 function GetInstanceID: string; override; 111 property FileName: string read FFileName; 112 property Stream: THandleStream read FStream; 113 end; 114 115 116constructor TPipeServerComm.Create (AOWner: TSimpleIPCServer); 117begin 118 inherited Create (AOWner); 119 FFileName := '\PIPE\' + Owner.ServerID; 120 SemName := '\SEM32\PIPE\' + Owner.ServerID; 121 If not Owner.Global then 122 FFileName := FFileName + '.' + IntToStr (GetProcessID); 123end; 124 125 126procedure TPipeServerComm.StartServer; 127var 128 H: THandle; 129begin 130 if not (Assigned (FStream)) then 131 if (DosCreateNPipe (PChar (FFileName), H, np_Access_Inbound, 132 np_ReadMode_Message or np_WriteMode_Message or 1, PipeBufSize, 133 PipeBufSize, 0) <> 0) or 134 (DosCreateEventSem (PChar (SemName), EventSem, 0, 0) <> 0) or 135 (DosSetNPipeSem (H, EventSem, PipeKey) <> 0) or 136 (DosConnectNPipe (H) <> 0) then 137 Owner.DoError (SErrFailedToCreatePipe, [FFileName]); 138 FStream := THandleStream.Create (H); 139end; 140 141 142procedure TPipeServerComm.StopServer; 143begin 144 if (DosDisconnectNPipe (FStream.Handle) <> 0) or 145 (DosCloseEventSem (EventSem) <> 0) then 146 Owner.DoError (SErrFailedToDisconnectPipe, [FFileName]); 147 FreeAndNil (FStream); 148end; 149 150 151function TPipeServerComm.PeekMessage (TimeOut: integer): boolean; 152var 153 PipeSemState: TPipeSemState; 154begin 155 Result := (DosQueryNPipeSemState (EventSem, PipeSemState, 156 SizeOf (PipeSemState)) = 0) and (PipeSemState.Status = 1) and 157 (PipeSemState.Avail <> 0) and (PipeSemState.Key = PipeKey); 158 if not (Result) then 159 Result := (DosWaitEventSem (EventSem, TimeOut) = 0) and 160 (DosQueryNPipeSemState (EventSem, PipeSemState, 161 SizeOf (PipeSemState)) = 0) and (PipeSemState.Status = 1) and 162 (PipeSemState.Avail <> 0) and (PipeSemState.Key = PipeKey); 163end; 164 165 166procedure TPipeServerComm.ReadMessage; 167 168var 169 Hdr: TMsgHeader; 170 171begin 172 FStream.ReadBuffer(Hdr,SizeOf(Hdr)); 173 PushMessage(Hdr,FStream); 174end; 175 176function TPipeServerComm.GetInstanceID: string; 177begin 178 Result := IntToStr (GetProcessID); 179end; 180 181{ --------------------------------------------------------------------- 182 Set TSimpleIPCClient / TSimpleIPCServer defaults. 183 ---------------------------------------------------------------------} 184 185function TSimpleIPCServer.CommClass: TIPCServerCommClass; 186begin 187 if (DefaultIPCServerClass <> nil) then 188 Result := DefaultIPCServerClass 189 else 190 Result := TPipeServerComm; 191end; 192 193function TSimpleIPCClient.CommClass: TIPCClientCommClass; 194begin 195 if (DefaultIPCClientClass <> nil) then 196 Result := DefaultIPCClientClass 197 else 198 Result := TPipeClientComm; 199end; 200