freepascal.ru

Код: Выделить всё

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.



Код: Выделить всё

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.

Код: Выделить всё

CreateFile (PChar(NamePipe),

GENERIC_WRITE or

GENERIC_READ,

FILE_SHARE_READ or

FILE_SHARE_WRITE,

nil,

CREATE_NEW,   

FILE_FLAG_OVERLAPPED,

0);

coyot.rush писал(а):CREATE_NEW

Creates a new file, only if it does not already exist.

If the specified file exists, the function fails and the last-error code is set to ERROR_FILE_EXISTS (80).

If the specified file does not exist and is a valid path to a writable location, a new file is created.

CREATE_NEW
Создает новый файл. Функция завершается ошибкой, если заданный файл уже существует.

А получается, что ошибку на существующем не выдает?

Я бы попробовал зайти с другой стороны, т.е. открыть без создания