- Код: Выделить всё
unit userver;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,windows;
const
MAX_PIPE_INSTANCES = 100;
NAME_SIZE = 25;
LINE_LEN = 80;
type TMessageEvent = procedure(const Sender : TObject;Msg : string) of object;
type
{ TServerL }
TServerL = class(TThread)
private
FOnMessage:TMessageEvent;
FPipeName:string;
public
procedure Execute; override;
constructor Create;
{destructor Destroy; override;}
property OnMessage:TMessageEvent read FOnMessage write FOnMessage;
property NameId:string read FPipeName write Fpipename;
end;
implementation
{ TServerL }
procedure TServerL.Execute;
const
IN_BUF_SIZE = 1000;
OUT_BUF_SIZE = 1000;
TIME_OUT = 0;
MAX_READ = 1000*Sizeof(Char);
var
inBuf: array[0..IN_BUF_SIZE] of Char;
bytesRead: DWORD;
bytesTransRd: DWORD;
rc: Boolean;
LastError: DWORD;
ExitLoop: Boolean;
hpipe:Thandle;
OverLapWrt: OVERLAPPED;
hEventWrt: THANDLE;
OverLapRd: OVERLAPPED;
hEventRd: THANDLE;
pSD: PSECURITY_DESCRIPTOR;
sa: SECURITY_ATTRIBUTES;
tmpNamePipe:string;
begin
pSD := PSECURITY_DESCRIPTOR(LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH));
if not Assigned(pSD) then begin
if assigned(FOnMessage) then FOnMessage(self, 'Error allocation memory for SD');
Exit;
end;
if not InitializeSecurityDescriptor (pSD,
SECURITY_DESCRIPTOR_REVISION) then begin
if assigned(FOnMessage) then FOnMessage(self, 'InitializeSecurityDescriptor');
LocalFree(HLOCAL(pSD));
Exit;
end;
if not SetSecurityDescriptorDacl(pSD, true, nil, false) then begin
if assigned(FOnMessage) then FOnMessage(self, 'SetSecurityDescriptorDacl');
LocalFree(HLOCAL(pSD));
Exit;
end;
sa.nLength := sizeof(sa);
sa.lpSecurityDescriptor := pSD;
sa.bInheritHandle := true;
while not Terminated do
begin
inBuf[0] := #0;
ExitLoop := false;
lastError := 0;
tmpNamePipe:='\\.\PIPE\'+FPipeName;
hPipe := CreateNamedPipe (PChar(tmpNamePipe),
PIPE_ACCESS_DUPLEX or
FILE_FLAG_OVERLAPPED,
PIPE_WAIT or
PIPE_READMODE_MESSAGE or
PIPE_TYPE_MESSAGE,
MAX_PIPE_INSTANCES,
OUT_BUF_SIZE*SizeOf(Char),
IN_BUF_SIZE*SizeOf(char),
TIME_OUT,
@sa);
if hPipe = INVALID_HANDLE_VALUE then begin
if assigned(FOnMessage) then FOnMessage(self, 'Error CreateNamedPipe');
Exit;
end
else
if assigned(FOnMessage) then FOnMessage(self, 'CreateNamedPipe '+tmpNamePipe);
ConnectNamedPipe(hPipe, nil);
hEventWrt := CreateEventW (nil, true, false, nil);
FillChar(OverLapWrt, sizeof(OVERLAPPED), 0);
OverLapWrt.hEvent := hEventWrt;
hEventRd := CreateEventW (nil, true, false, nil);
FillChar(OverLapRd, sizeof(OVERLAPPED), 0);
OverLapRd.hEvent := hEventRd;
if not rc then
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then
WaitForSingleObject (hEventRd, INFINITE);
repeat
rc := ReadFile (hPipe, inBuf, MAX_READ, bytesRead, @OverLapRd);
if not rc then begin
lastError := GetLastError;
case lastError of
ERROR_IO_PENDING:
WaitForSingleObject (hEventRd, INFINITE);
ERROR_BROKEN_PIPE:
ExitLoop := true;
else
begin
if assigned(FOnMessage) then FOnMessage(self, 'Error ReadFile');
ExitLoop := true;
end;
end;
end;
if not ExitLoop then begin
GetOverlappedResult (hPipe, OverLapRd, bytesTransRd, false);
end;
if assigned(FOnMessage) then FOnMessage(self, '>>'+inBuf);
until ExitLoop;
if assigned(FOnMessage) then FOnMessage(self, 'Disconnect');
CloseHandle (hPipe);
CloseHandle (hEventRd);
CloseHandle (hEventWrt);
DisconnectNamedPipe (hPipe);
end;
end;
constructor TServerL.Create;
begin
inherited Create(True);
FPipeName:='';
end;
end.
GUI
- Код: Выделить всё
unit main;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
interface
uses
mseglob,mseguiglob,mseguiintf,mseapplication,msestat,msemenus,msegui,
msegraphics,msegraphutils,mseevent,mseclasses,mseforms,msedataedits,mseedit,
msestrings,msetypes,msesimplewidgets,msewidgets;
type
tmainfo = class(tmainform)
m_msg: tmemoedit;
tlabel1: tlabel;
e_namepipe: tstringedit;
tbutton1: tbutton;
procedure runserver(const sender: TObject);
procedure OnMessage(const Sender : TObject;Msg : string);
procedure OnTerminate(sender: TObject);
end;
var
mainfo: tmainfo;
implementation
uses
main_mfm,userver;
var
Server:TServerL;
procedure tmainfo.OnTerminate(sender: TObject);
begin
Server.free;
Server:=nil;
end;
procedure tmainfo.runserver(const sender: TObject);
begin
if not Assigned(Server) then
begin
Server:=TServerL.Create;
Server.OnMessage:=@OnMessage;
Server.OnTerminate:=@OnTerminate;
Server.NameId:=e_namepipe.value;
Server.Resume;
end;
end;
procedure tmainfo.OnMessage(const Sender: TObject; Msg: string);
begin
m_msg.value:=m_msg.value+Msg+#13;
end;
end.
Требуется проверка существования именнованого пайпа, без уничтожения самого пайпа.
Пробовал FileExists вызывает Disconnect.
- Код: Выделить всё
CreateFile (PChar(NamePipe),
GENERIC_WRITE or
GENERIC_READ,
FILE_SHARE_READ or
FILE_SHARE_WRITE,
nil,
CREATE_NEW,
FILE_FLAG_OVERLAPPED,
0);
Возвращает всегда "успех", тоже самое и ConnectNamedPipe
