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