Задание. Организовать работу программы-сервера и нескольких программ клиентов следующим образом:
Сервер предоставляет клиентам кокой-либо из своих ресурсов (например, собственное окно)
Клиенты подключаются к серверу и начинают запись в окно, причем первый клиент пишет только «1», второй – только «2», и т.д. Клиентов может быть произвольное количество, но не менее пяти.
Если клиент подключается к серверу в монопольном режиме, он получает исключительные права на использование ресурса сервера. Все остальные клиенты, пытающиеся подключиться в данный момент, не должны получить доступ к ресурсу сервера и должны оказаться в очереди на обслуживание.
В разделяемом режиме каждому из подключенных клиентов предоставляется квант времени на исполнение (например 1с). Если клиент записывает символы в окно сервера с частотой 1 символ в секунду, то в случае, когда к серверу подключено пять клиентов, окно сервера должно содержать примерно следующую информацию:
Сервер: подключено 5 клиентов
12:12:01 1 2 3 4 5
12:12:02 1 2 3 4 5
Клиент 5 отключился от сервера
12:12:03 1 2 3 4
12:12:03 1 2 3 4
Обмен данными между клиентами и сервером организовать либо при помощи именованных каналов (named pipes).
Вот, что то не прет в написании этого кода просто ужас какой то...
Надеюсь завтра соберусь с мыслями и все получиться!
Ну получилось, что то вроде этого
Сервер
unit unitMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
const
WM_ConnectClientPipe = WM_USER+1342;
WM_DisconnectClientPipe = WM_USER+1343;
WM_MessagesAllClients = WM_USER+1344;
WM_MessagesClientsPrior= WM_USER+1346;
type
TfrmMain = class(TForm)
mmoLog: TMemo;
btnStart: TButton;
procedure btnStartClick(Sender: TObject);
private
{ Private declarations }
procedure WMConnectClientPipe(var aMsg:TMessage);message WM_ConnectClientPipe;
procedure WMDisconnectClientPipe(var aMsg:TMessage);message WM_DisconnectClientPipe;
procedure WMMessagesAllClients(var aMsg:TMessage);message WM_MessagesAllClients;
procedure WMMessagesClientsPrior(var aMsg:TMessage);message WM_MessagesClientsPrior;
public
{ Public declarations }
end;
const
MAX_PIPE_CLIENTS=20;//максимальное кол-во клиентов
BUFFSIZE=100;//размер буфера
TIME_OUT=1000;//таймаут
type
RPipe = packed record
hPipe: THANDLE;
hIdThread: Cardinal;
sPrior:string;
Live: Boolean;
end;
type
arrChar= array[0..BUFFSIZE] of Char;//для передачи в функции
var
frmMain: TfrmMain;
Clients:array[1..MAX_PIPE_CLIENTS] of RPipe;
countClients,counLiveClients,countPriorClients,countPriorClientsMess:Integer;
sTemp:string;
implementation
{$R *.dfm}
//чтение канала
function RdNameClientpipe(aHandle,ahPipe:HWND; var aInBuf:arrChar):Boolean;
var
hEventRd: THANDLE;
OverLapRd:OVERLAPPED;
bytesRead,lastError:Cardinal;
rd:Boolean;
begin
Result := True;
// Создаем событие ожидания завершения чтения из канала.
hEventRd := CreateEvent(nil, True, False, '');
FillChar(OverLapRd, sizeof(OVERLAPPED), 0);
OverLapRd.hEvent := hEventRd;
//получаем приоритет клиента в первом сообщении от него
rd := ReadFile (ahPipe, aInBuf, BUFFSIZE*SizeOf(Char), bytesRead, @OverLapRd);
if not rd then
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then // Ожидаем завершения ввода-вывода
WaitForSingleObject (hEventRd, INFINITE);
if not rd then
begin
lastError := GetLastError;
case lastError of
ERROR_IO_PENDING: // Ожидаем завершения операции
WaitForSingleObject (hEventRd, INFINITE);
ERROR_BROKEN_PIPE: // Экземпляр канала сломался, завершаем обслуживание.
Result := False;
else
Result := False;
end;
end;
CloseHandle(hEventRd);
end;
//запись в именованный канал
function WtNameClientpipe(ahPipe:HWND; aOutBuf:arrChar):Boolean;
var
hEventWrt:THANDLE;
OverLapWrt:OVERLAPPED;
wrt:Boolean;
bytesWritten,lastError:Cardinal;
begin
Result:=False;
// Создаем событие ожидания завершения записи в канал.
hEventWrt := CreateEventW (nil, true, false, nil);
FillChar(OverLapWrt, sizeof(OVERLAPPED), 0);
OverLapWrt.hEvent := hEventWrt;
//пишем клиенту его индекс который был выбран из свободных сот
wrt := WriteFile (ahPipe,aOutBuf ,BUFFSIZE*SizeOf(Char), bytesWritten,@OverLapWrt);
// Проверка на три вида ошибки: IO_PENDING, NO_DATA и остальные.
// Для случая IO_PENDING ожидать завершения асинхронного ввода-вывода
// на событии клиента, во всех остальных случаях, кроме NO_DATA
// считать клиента умершим и отметить факт его смерти в описании клиента.
if not wrt then
begin
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then //Ждем завершения операции
WaitForSingleObject (hEventWrt, INFINITE)
else
begin
if lastError <> ERROR_NO_DATA then //Клиент умер по причине lastError
Exit;
end;
end;
Result:=True;
end;
function ServerProc(Param: Pointer):Integer; stdcall;
type
PHWND = ^HWND;
var
idThread:Cardinal;
handle:HWND;//дескриптор окна
hPipe:HWND;
inBuf,outBuf:arrChar;
ExitLoop,prior:Boolean;
i:Integer;
ClientIndex:Integer;
preobr:string;
begin
handle:=PHWND(Param)^;
// Создать серверную часть канала на локальной машине
hPipe := CreateNamedPipe ('\\.\PIPE\test', // Имя канала = 'test'.
PIPE_ACCESS_DUPLEX or // Двусторонний канал
FILE_FLAG_OVERLAPPED, // Асинхронный ввод-вывод
PIPE_WAIT or // Ожидать сообщений
PIPE_READMODE_MESSAGE or // Обмен в канале производится пакетами
PIPE_TYPE_MESSAGE,
MAX_PIPE_CLIENTS, // Максимальное числе экземпляров канала.
BUFFSIZE*SizeOf(Char), // Размеры буферов чтения/записи.
BUFFSIZE*SizeOf(Char),
TIME_OUT, // Тайм-аут.
nil); // Атрибуты безопасности.
if hPipe=INVALID_HANDLE_VALUE then
Exit;
// Ожидаем подключения клиента.
ConnectNamedPipe(hPipe, nil);
for i := 1 to MAX_PIPE_CLIENTS do
if Clients[i].Live=False then
begin
Clients[i].Live:=True;
Clients[i].hPipe:=hPipe;
ClientIndex:=i;
Break;
end;
SendMessage(handle,WM_ConnectClientPipe,ClientIndex,0);
if not rdNameClientpipe(handle,hPipe,inBuf) then
begin
SendMessage(handle,WM_DisconnectClientPipe,ClientIndex,0);
Clients[ClientIndex].Live:=False;
Clients[ClientIndex].hPipe:=0;
CloseHandle (hPipe);
DisconnectNamedPipe (hPipe); // Разрушаем экземпляр канала
ExitThread(0);
end;
preobr:= inBuf;
Clients[ClientIndex].sPrior:=preobr;
Clients[ClientIndex].Live:=True;
preobr:=IntToStr(ClientIndex);
Move(preobr[1],outBuf,BUFFSIZE);
if not WtNameClientpipe(Clients[ClientIndex].hPipe,outBuf) then
begin
SendMessage(handle,WM_DisconnectClientPipe,ClientIndex,0);
Clients[ClientIndex].Live:=False;
Clients[ClientIndex].hPipe:=0;
CloseHandle (hPipe);
DisconnectNamedPipe (hPipe); // Разрушаем экземпляр канала
ExitThread(0);
end;
Clients[ClientIndex].Live:=True;
Clients[ClientIndex].hPipe:=hPipe;
Clients[ClientIndex+1].hIdThread:=CreateThread(nil, 0, @ServerProc, @Param^,0, idThread);
ExitLoop:=true;
while ExitLoop do
begin
ExitLoop:=rdNameClientpipe(handle,hPipe,inBuf);
prior:=False;
countPriorClients:=0;
for i := 1 to MAX_PIPE_CLIENTS do
begin
if Clients[i].Live then
begin
if Clients[i].sPrior='1' then
begin
prior:=True;
Inc(countPriorClients);
end;
end;
end;
if prior then
begin
if Clients[ClientIndex].sPrior='1' then
SendMessage(handle,WM_MessagesClientsPrior,countPriorClients,lparam(StrPas(inBuf)));
end
else
SendMessage(handle,WM_MessagesAllClients,ClientIndex,lparam(StrPas(inBuf)));
end;
SendMessage(handle,WM_DisconnectClientPipe,ClientIndex,0);
Clients[ClientIndex].Live:=False;
Clients[ClientIndex].hPipe:=0;
Clients[ClientIndex].sPrior:='';
CloseHandle (hPipe);
DisconnectNamedPipe (hPipe); // Разрушаем экземпляр канала
ExitThread(0); // Завершаем обслуживающий поток.
end;
procedure TfrmMain.btnStartClick(Sender: TObject);
var
idThread:Cardinal;
begin
//запуск потока
Clients[1].hIdThread:=CreateThread(nil, 0, @ServerProc, @WindowHandle, 0, idThread);
end;
procedure TfrmMain.WMConnectClientPipe(var aMsg: TMessage);
begin
frmMain.mmoLog.Lines.Add('Подключился клиент '+IntToStr(aMsg.WParam));
end;
procedure TfrmMain.WMDisconnectClientPipe(var aMsg: TMessage);
begin
frmMain.mmoLog.Lines.Add('Клиент '+IntToStr(aMsg.WParam)+' отключился от сервера');
end;
procedure TfrmMain.WMMessagesAllClients(var aMsg: TMessage);
var
i:Integer;
begin
sTemp:=sTemp+' '+string(aMsg.LParam);
Inc(countClients);
counLiveClients:=0;
for i := 1 to MAX_PIPE_CLIENTS do
if Clients[i].Live then
begin
Inc(counLiveClients);//кол-во живых клиентов
end;
if countClients>=counLiveClients then
begin
frmMain.mmoLog.Lines.Add(TimeToStr(Time)+' '+sTemp);
sTemp:='';
countClients:=0;
end;
end;
procedure TfrmMain.WMMessagesClientsPrior(var aMsg: TMessage);
var
i:Integer;
begin
sTemp:=sTemp+' '+string(aMsg.LParam);
Inc(countPriorClientsMess);
if countPriorClientsMess>=aMsg.WParam then
begin
frmMain.mmoLog.Lines.Add(TimeToStr(Time)+' '+sTemp);
sTemp:='';
countPriorClientsMess:=0;
end;
end;
end.
Клиент
unit unitMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TfrmMain = class(TForm)
btnStart: TButton;
lblprioritet: TLabel;
edtPrioritet: TEdit;
procedure btnStartClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
const
MAX_PIPE_CLIENTS=20;//максимальное кол-во клиентов
BUFFSIZE=100;//размер буфера
TIME_OUT=1000;//таймаут
type
arrChar= array[0..BUFFSIZE] of Char;//для передачи в функции
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
//чтение канала
function RdNameClientpipe(ahPipe:HWND; var aInBuf:arrChar):Boolean;
var
hEventRd: THANDLE;
OverLapRd:OVERLAPPED;
bytesRead,lastError:Cardinal;
rd:Boolean;
begin
Result := True;
// Создаем событие ожидания завершения чтения из канала.
hEventRd := CreateEvent(nil, True, False, '');
FillChar(OverLapRd, sizeof(OVERLAPPED), 0);
OverLapRd.hEvent := hEventRd;
//получаем приоритет клиента в первом сообщении от него
rd := ReadFile (ahPipe, aInBuf, BUFFSIZE*SizeOf(Char), bytesRead, @OverLapRd);
if not rd then
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then // Ожидаем завершения ввода-вывода
WaitForSingleObject (hEventRd, INFINITE);
if not rd then
begin
lastError := GetLastError;
case lastError of
ERROR_IO_PENDING: // Ожидаем завершения операции
WaitForSingleObject (hEventRd, INFINITE);
ERROR_BROKEN_PIPE: // Экземпляр канала сломался, завершаем обслуживание.
Result := False;
else
Result := False;
end;
end;
CloseHandle(hEventRd);
end;
//запись в именованный канал
function WtNameClientpipe(ahPipe:HWND; aOutBuf:arrChar):Boolean;
var
hEventWrt:THANDLE;
OverLapWrt:OVERLAPPED;
wrt:Boolean;
bytesWritten,lastError:Cardinal;
begin
Result:=True;
// Создаем событие ожидания завершения записи в канал.
hEventWrt := CreateEventW (nil, true, false, nil);
FillChar(OverLapWrt, sizeof(OVERLAPPED), 0);
OverLapWrt.hEvent := hEventWrt;
//пишем клиенту его индекс который был выбран из свободных сот
wrt := WriteFile (ahPipe,aOutBuf ,BUFFSIZE*SizeOf(Char), bytesWritten,@OverLapWrt);
// Проверка на три вида ошибки: IO_PENDING, NO_DATA и остальные.
// Для случая IO_PENDING ожидать завершения асинхронного ввода-вывода
// на событии клиента, во всех остальных случаях, кроме NO_DATA
// считать клиента умершим и отметить факт его смерти в описании клиента.
if not wrt then
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then // Ожидаем завершения ввода-вывода
WaitForSingleObject (hEventWrt, INFINITE);
if not wrt then
begin
lastError := GetLastError;
case lastError of
ERROR_IO_PENDING: // Ожидаем завершения операции
WaitForSingleObject (hEventWrt, INFINITE);
ERROR_BROKEN_PIPE: // Экземпляр канала сломался, завершаем обслуживание.
Result := False;
else
Result := False;
end;
end;
CloseHandle(hEventWrt);
end;
function ClientProc (Param: Pointer):Integer; stdcall;
var
hPipe:HWND;
hEventWrt,hEventRd:THandle;
OverLapWrt,OverLapRd:OVERLAPPED;
wrt,rd:Boolean;
bytesWritten,bytesWritten2,bytesRead:Cardinal;
outBuf,inIndex:arrChar;
lastError:Cardinal;
strTemp:^string;
begin
// Соединиться с сервером
hPipe := CreateFile('\\.\PIPE\test',
GENERIC_WRITE or // Доступ на чтение/запись
GENERIC_READ,
FILE_SHARE_READ or // Разделенный доступ
FILE_SHARE_WRITE,
nil,
OPEN_EXISTING, // Канал должен существовать
FILE_FLAG_OVERLAPPED, // Использовать асинхронный ввод/вывод
0);
if hPipe = INVALID_HANDLE_VALUE then
Exit;
strTemp:=Param;
Move(strTemp^,outBuf,BUFFSIZE);
if not WtNameClientpipe(hPipe,outBuf) then
begin
CloseHandle(hPipe);
ExitThread(0);
end;
if not rdNameClientpipe(hPipe,inIndex) then
begin
CloseHandle (hPipe);
DisconnectNamedPipe (hPipe); // Разрушаем экземпляр канала
ExitThread(0);
end;
while True do
begin
Sleep(1000);
if not WtNameClientpipe(hPipe,inIndex) then
Break;
end;
CloseHandle(hPipe);
ExitThread(0);
end;
procedure TfrmMain.btnStartClick(Sender: TObject);
var
idThread:Cardinal;
prior:Integer;
strTemp:string;
begin
strTemp:=edtPrioritet.Text;
CreateThread(nil, 0, @ClientProc, pchar(strTemp), 0, idThread);
end;
end.
Вот, что то не прет в написании этого кода просто ужас какой то...
Надеюсь завтра соберусь с мыслями и все получиться!
Ну получилось, что то вроде этого
Сервер
unit unitMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
const
WM_ConnectClientPipe = WM_USER+1342;
WM_DisconnectClientPipe = WM_USER+1343;
WM_MessagesAllClients = WM_USER+1344;
WM_MessagesClientsPrior= WM_USER+1346;
type
TfrmMain = class(TForm)
mmoLog: TMemo;
btnStart: TButton;
procedure btnStartClick(Sender: TObject);
private
{ Private declarations }
procedure WMConnectClientPipe(var aMsg:TMessage);message WM_ConnectClientPipe;
procedure WMDisconnectClientPipe(var aMsg:TMessage);message WM_DisconnectClientPipe;
procedure WMMessagesAllClients(var aMsg:TMessage);message WM_MessagesAllClients;
procedure WMMessagesClientsPrior(var aMsg:TMessage);message WM_MessagesClientsPrior;
public
{ Public declarations }
end;
const
MAX_PIPE_CLIENTS=20;//максимальное кол-во клиентов
BUFFSIZE=100;//размер буфера
TIME_OUT=1000;//таймаут
type
RPipe = packed record
hPipe: THANDLE;
hIdThread: Cardinal;
sPrior:string;
Live: Boolean;
end;
type
arrChar= array[0..BUFFSIZE] of Char;//для передачи в функции
var
frmMain: TfrmMain;
Clients:array[1..MAX_PIPE_CLIENTS] of RPipe;
countClients,counLiveClients,countPriorClients,countPriorClientsMess:Integer;
sTemp:string;
implementation
{$R *.dfm}
//чтение канала
function RdNameClientpipe(aHandle,ahPipe:HWND; var aInBuf:arrChar):Boolean;
var
hEventRd: THANDLE;
OverLapRd:OVERLAPPED;
bytesRead,lastError:Cardinal;
rd:Boolean;
begin
Result := True;
// Создаем событие ожидания завершения чтения из канала.
hEventRd := CreateEvent(nil, True, False, '');
FillChar(OverLapRd, sizeof(OVERLAPPED), 0);
OverLapRd.hEvent := hEventRd;
//получаем приоритет клиента в первом сообщении от него
rd := ReadFile (ahPipe, aInBuf, BUFFSIZE*SizeOf(Char), bytesRead, @OverLapRd);
if not rd then
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then // Ожидаем завершения ввода-вывода
WaitForSingleObject (hEventRd, INFINITE);
if not rd then
begin
lastError := GetLastError;
case lastError of
ERROR_IO_PENDING: // Ожидаем завершения операции
WaitForSingleObject (hEventRd, INFINITE);
ERROR_BROKEN_PIPE: // Экземпляр канала сломался, завершаем обслуживание.
Result := False;
else
Result := False;
end;
end;
CloseHandle(hEventRd);
end;
//запись в именованный канал
function WtNameClientpipe(ahPipe:HWND; aOutBuf:arrChar):Boolean;
var
hEventWrt:THANDLE;
OverLapWrt:OVERLAPPED;
wrt:Boolean;
bytesWritten,lastError:Cardinal;
begin
Result:=False;
// Создаем событие ожидания завершения записи в канал.
hEventWrt := CreateEventW (nil, true, false, nil);
FillChar(OverLapWrt, sizeof(OVERLAPPED), 0);
OverLapWrt.hEvent := hEventWrt;
//пишем клиенту его индекс который был выбран из свободных сот
wrt := WriteFile (ahPipe,aOutBuf ,BUFFSIZE*SizeOf(Char), bytesWritten,@OverLapWrt);
// Проверка на три вида ошибки: IO_PENDING, NO_DATA и остальные.
// Для случая IO_PENDING ожидать завершения асинхронного ввода-вывода
// на событии клиента, во всех остальных случаях, кроме NO_DATA
// считать клиента умершим и отметить факт его смерти в описании клиента.
if not wrt then
begin
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then //Ждем завершения операции
WaitForSingleObject (hEventWrt, INFINITE)
else
begin
if lastError <> ERROR_NO_DATA then //Клиент умер по причине lastError
Exit;
end;
end;
Result:=True;
end;
function ServerProc(Param: Pointer):Integer; stdcall;
type
PHWND = ^HWND;
var
idThread:Cardinal;
handle:HWND;//дескриптор окна
hPipe:HWND;
inBuf,outBuf:arrChar;
ExitLoop,prior:Boolean;
i:Integer;
ClientIndex:Integer;
preobr:string;
begin
handle:=PHWND(Param)^;
// Создать серверную часть канала на локальной машине
hPipe := CreateNamedPipe ('\\.\PIPE\test', // Имя канала = 'test'.
PIPE_ACCESS_DUPLEX or // Двусторонний канал
FILE_FLAG_OVERLAPPED, // Асинхронный ввод-вывод
PIPE_WAIT or // Ожидать сообщений
PIPE_READMODE_MESSAGE or // Обмен в канале производится пакетами
PIPE_TYPE_MESSAGE,
MAX_PIPE_CLIENTS, // Максимальное числе экземпляров канала.
BUFFSIZE*SizeOf(Char), // Размеры буферов чтения/записи.
BUFFSIZE*SizeOf(Char),
TIME_OUT, // Тайм-аут.
nil); // Атрибуты безопасности.
if hPipe=INVALID_HANDLE_VALUE then
Exit;
// Ожидаем подключения клиента.
ConnectNamedPipe(hPipe, nil);
for i := 1 to MAX_PIPE_CLIENTS do
if Clients[i].Live=False then
begin
Clients[i].Live:=True;
Clients[i].hPipe:=hPipe;
ClientIndex:=i;
Break;
end;
SendMessage(handle,WM_ConnectClientPipe,ClientIndex,0);
if not rdNameClientpipe(handle,hPipe,inBuf) then
begin
SendMessage(handle,WM_DisconnectClientPipe,ClientIndex,0);
Clients[ClientIndex].Live:=False;
Clients[ClientIndex].hPipe:=0;
CloseHandle (hPipe);
DisconnectNamedPipe (hPipe); // Разрушаем экземпляр канала
ExitThread(0);
end;
preobr:= inBuf;
Clients[ClientIndex].sPrior:=preobr;
Clients[ClientIndex].Live:=True;
preobr:=IntToStr(ClientIndex);
Move(preobr[1],outBuf,BUFFSIZE);
if not WtNameClientpipe(Clients[ClientIndex].hPipe,outBuf) then
begin
SendMessage(handle,WM_DisconnectClientPipe,ClientIndex,0);
Clients[ClientIndex].Live:=False;
Clients[ClientIndex].hPipe:=0;
CloseHandle (hPipe);
DisconnectNamedPipe (hPipe); // Разрушаем экземпляр канала
ExitThread(0);
end;
Clients[ClientIndex].Live:=True;
Clients[ClientIndex].hPipe:=hPipe;
Clients[ClientIndex+1].hIdThread:=CreateThread(nil, 0, @ServerProc, @Param^,0, idThread);
ExitLoop:=true;
while ExitLoop do
begin
ExitLoop:=rdNameClientpipe(handle,hPipe,inBuf);
prior:=False;
countPriorClients:=0;
for i := 1 to MAX_PIPE_CLIENTS do
begin
if Clients[i].Live then
begin
if Clients[i].sPrior='1' then
begin
prior:=True;
Inc(countPriorClients);
end;
end;
end;
if prior then
begin
if Clients[ClientIndex].sPrior='1' then
SendMessage(handle,WM_MessagesClientsPrior,countPriorClients,lparam(StrPas(inBuf)));
end
else
SendMessage(handle,WM_MessagesAllClients,ClientIndex,lparam(StrPas(inBuf)));
end;
SendMessage(handle,WM_DisconnectClientPipe,ClientIndex,0);
Clients[ClientIndex].Live:=False;
Clients[ClientIndex].hPipe:=0;
Clients[ClientIndex].sPrior:='';
CloseHandle (hPipe);
DisconnectNamedPipe (hPipe); // Разрушаем экземпляр канала
ExitThread(0); // Завершаем обслуживающий поток.
end;
procedure TfrmMain.btnStartClick(Sender: TObject);
var
idThread:Cardinal;
begin
//запуск потока
Clients[1].hIdThread:=CreateThread(nil, 0, @ServerProc, @WindowHandle, 0, idThread);
end;
procedure TfrmMain.WMConnectClientPipe(var aMsg: TMessage);
begin
frmMain.mmoLog.Lines.Add('Подключился клиент '+IntToStr(aMsg.WParam));
end;
procedure TfrmMain.WMDisconnectClientPipe(var aMsg: TMessage);
begin
frmMain.mmoLog.Lines.Add('Клиент '+IntToStr(aMsg.WParam)+' отключился от сервера');
end;
procedure TfrmMain.WMMessagesAllClients(var aMsg: TMessage);
var
i:Integer;
begin
sTemp:=sTemp+' '+string(aMsg.LParam);
Inc(countClients);
counLiveClients:=0;
for i := 1 to MAX_PIPE_CLIENTS do
if Clients[i].Live then
begin
Inc(counLiveClients);//кол-во живых клиентов
end;
if countClients>=counLiveClients then
begin
frmMain.mmoLog.Lines.Add(TimeToStr(Time)+' '+sTemp);
sTemp:='';
countClients:=0;
end;
end;
procedure TfrmMain.WMMessagesClientsPrior(var aMsg: TMessage);
var
i:Integer;
begin
sTemp:=sTemp+' '+string(aMsg.LParam);
Inc(countPriorClientsMess);
if countPriorClientsMess>=aMsg.WParam then
begin
frmMain.mmoLog.Lines.Add(TimeToStr(Time)+' '+sTemp);
sTemp:='';
countPriorClientsMess:=0;
end;
end;
end.
Клиент
unit unitMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TfrmMain = class(TForm)
btnStart: TButton;
lblprioritet: TLabel;
edtPrioritet: TEdit;
procedure btnStartClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
const
MAX_PIPE_CLIENTS=20;//максимальное кол-во клиентов
BUFFSIZE=100;//размер буфера
TIME_OUT=1000;//таймаут
type
arrChar= array[0..BUFFSIZE] of Char;//для передачи в функции
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
//чтение канала
function RdNameClientpipe(ahPipe:HWND; var aInBuf:arrChar):Boolean;
var
hEventRd: THANDLE;
OverLapRd:OVERLAPPED;
bytesRead,lastError:Cardinal;
rd:Boolean;
begin
Result := True;
// Создаем событие ожидания завершения чтения из канала.
hEventRd := CreateEvent(nil, True, False, '');
FillChar(OverLapRd, sizeof(OVERLAPPED), 0);
OverLapRd.hEvent := hEventRd;
//получаем приоритет клиента в первом сообщении от него
rd := ReadFile (ahPipe, aInBuf, BUFFSIZE*SizeOf(Char), bytesRead, @OverLapRd);
if not rd then
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then // Ожидаем завершения ввода-вывода
WaitForSingleObject (hEventRd, INFINITE);
if not rd then
begin
lastError := GetLastError;
case lastError of
ERROR_IO_PENDING: // Ожидаем завершения операции
WaitForSingleObject (hEventRd, INFINITE);
ERROR_BROKEN_PIPE: // Экземпляр канала сломался, завершаем обслуживание.
Result := False;
else
Result := False;
end;
end;
CloseHandle(hEventRd);
end;
//запись в именованный канал
function WtNameClientpipe(ahPipe:HWND; aOutBuf:arrChar):Boolean;
var
hEventWrt:THANDLE;
OverLapWrt:OVERLAPPED;
wrt:Boolean;
bytesWritten,lastError:Cardinal;
begin
Result:=True;
// Создаем событие ожидания завершения записи в канал.
hEventWrt := CreateEventW (nil, true, false, nil);
FillChar(OverLapWrt, sizeof(OVERLAPPED), 0);
OverLapWrt.hEvent := hEventWrt;
//пишем клиенту его индекс который был выбран из свободных сот
wrt := WriteFile (ahPipe,aOutBuf ,BUFFSIZE*SizeOf(Char), bytesWritten,@OverLapWrt);
// Проверка на три вида ошибки: IO_PENDING, NO_DATA и остальные.
// Для случая IO_PENDING ожидать завершения асинхронного ввода-вывода
// на событии клиента, во всех остальных случаях, кроме NO_DATA
// считать клиента умершим и отметить факт его смерти в описании клиента.
if not wrt then
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then // Ожидаем завершения ввода-вывода
WaitForSingleObject (hEventWrt, INFINITE);
if not wrt then
begin
lastError := GetLastError;
case lastError of
ERROR_IO_PENDING: // Ожидаем завершения операции
WaitForSingleObject (hEventWrt, INFINITE);
ERROR_BROKEN_PIPE: // Экземпляр канала сломался, завершаем обслуживание.
Result := False;
else
Result := False;
end;
end;
CloseHandle(hEventWrt);
end;
function ClientProc (Param: Pointer):Integer; stdcall;
var
hPipe:HWND;
hEventWrt,hEventRd:THandle;
OverLapWrt,OverLapRd:OVERLAPPED;
wrt,rd:Boolean;
bytesWritten,bytesWritten2,bytesRead:Cardinal;
outBuf,inIndex:arrChar;
lastError:Cardinal;
strTemp:^string;
begin
// Соединиться с сервером
hPipe := CreateFile('\\.\PIPE\test',
GENERIC_WRITE or // Доступ на чтение/запись
GENERIC_READ,
FILE_SHARE_READ or // Разделенный доступ
FILE_SHARE_WRITE,
nil,
OPEN_EXISTING, // Канал должен существовать
FILE_FLAG_OVERLAPPED, // Использовать асинхронный ввод/вывод
0);
if hPipe = INVALID_HANDLE_VALUE then
Exit;
strTemp:=Param;
Move(strTemp^,outBuf,BUFFSIZE);
if not WtNameClientpipe(hPipe,outBuf) then
begin
CloseHandle(hPipe);
ExitThread(0);
end;
if not rdNameClientpipe(hPipe,inIndex) then
begin
CloseHandle (hPipe);
DisconnectNamedPipe (hPipe); // Разрушаем экземпляр канала
ExitThread(0);
end;
while True do
begin
Sleep(1000);
if not WtNameClientpipe(hPipe,inIndex) then
Break;
end;
CloseHandle(hPipe);
ExitThread(0);
end;
procedure TfrmMain.btnStartClick(Sender: TObject);
var
idThread:Cardinal;
prior:Integer;
strTemp:string;
begin
strTemp:=edtPrioritet.Text;
CreateThread(nil, 0, @ClientProc, pchar(strTemp), 0, idThread);
end;
end.
Комментариев нет:
Отправить комментарий