unit2.pas

DELPHI与其它进程通信

//终对PDM与ERP通信，用命名管道进行通信的处理方法。
//张河阳，2007-12-31
unit Unit2;

interface

uses
  Classes, Windows,forms,SyncObjs;

const
  cShutDownMsg = 'Stop';
  cPipeFormat = '\\%s\pipe\%s';


type

  RPIPEMessage = record
    Size: DWORD;
    Count: DWORD;
    Kind: Byte;
    Data: array[0..8095] of Char;
  end;
  RERPMsg=record
    kind:byte;
    Msg:String;
  end;
  TPDMEventHandle = procedure (Sender: TObject; Data: RErpMsg) of object;

  TPipeServer = class(TThread)
  private
    FOpened:boolean;
    FHandle: THandle;
    FPipeName: string;
    ERPMsg:RErpMsg;
    FOnPDMEvent: TPDMEventHandle;
   // MsgStrLock : TCriticalSection;
    function GetOpened: boolean;
    procedure Updata;


  protected
  public
    constructor CreatePipeServer(aServer, aPipe: string; StartServer: Boolean);
    destructor Destroy; override;

    procedure StartUpServer;
    procedure ShutDownServer;
    procedure Execute; override;
    property Opended:boolean read GetOpened;
    property OnPDMEvent: TPDMEventHandle read FOnPDMEvent write FOnPDMEvent;

  end;

  TPipeClient = class
  private

    FPipeName: string;
    function ProcessMsg(aMsg: RPIPEMessage): RPIPEMessage;
  protected
  public
    constructor Create(aServer, aPipe: string);

    function SendString(aStr: string): string;
  end;
implementation

uses
  SysUtils, Unit1;


procedure CalcMsgSize(var Msg: RPIPEMessage);
begin
  Msg.Size :=
    SizeOf(Msg.Size) +
    SizeOf(Msg.Kind) +
    SizeOf(Msg.Count) +
    Msg.Count +
    3;
end;

{ TPipeServer }

constructor TPipeServer.CreatePipeServer(
  aServer, aPipe: string; StartServer: Boolean
  );
begin
  self.FOpened:=false;
  //MsgStrLock:=TCriticalSection.Create;
  if aServer = '' then
    FPipeName := Format(cPipeFormat, ['.', aPipe])
  else
    FPipeName := Format(cPipeFormat, [aServer, aPipe]);
  // 初始化
  FHandle := INVALID_HANDLE_VALUE;
  if StartServer then
    StartUpServer;
  //创建基类
  Create(not StartServer);
end;

destructor TPipeServer.Destroy;
begin
  if FHandle <> INVALID_HANDLE_VALUE then
    // must shut down the server first
    ShutDownServer;
  inherited Destroy;
end;

procedure TPipeServer.Execute;
var
   Written: Cardinal;
  InMsg, OutMsg: RPIPEMessage;
  Exed:boolean;
  //bytes:array [0..8107] of byte;
begin
  while not Terminated do
  begin
    if FHandle = INVALID_HANDLE_VALUE then
    begin
      Sleep(250);
    end
    else
    begin
      Exed:=false;
      if ConnectNamedPipe(FHandle, nil) then
      try
        //从管道取数据
        InMsg.Size := SizeOf(InMsg);
        ReadFile(FHandle, InMsg, 8108, InMsg.Size, nil);

        if (InMsg.Kind = 0) and  (StrPas(InMsg.Data) = cShutDownMsg + FPipeName) then
        begin
          //线程停止
          OutMsg.Kind := 0;
          OutMsg.Count := 3;
          OutMsg.Data := 'OK'#0;
          Terminate;
          self.FOpened:=false;
        end
        else
        begin
          Exed:=true;
          // data send to pipe should be processed here
          OutMsg := InMsg;
          ErpMsg.Msg:=inMsg.Data;
          ErpMsg.Msg:=UTF8Decode(ErpMsg.Msg);
          // 回复消息
        //  for I := 0 to Pred(InMsg.Count) do
        ///    OutMsg.Data[Pred(InMsg.Count) - I] := InMsg.Data[I];
          StrPCopy(outMsg.Data, UTF8Encode('OK'));      //全部用OK
        end;
        CalcMsgSize(OutMsg);
        WriteFile(FHandle, OutMsg, OutMsg.Size, Written, nil);
      finally
        DisconnectNamedPipe(FHandle);
      end;
      if Exed then  Synchronize(Updata);
    end;
  end;
end;
procedure TPipeServer.Updata;
begin
   if Assigned(FOnPDMEvent) then
   begin
     FOnPDMEvent(Self, ErpMsg);
   end;
end;
function TPipeServer.GetOpened: boolean;
begin
  result:=self.FOpened;
end;

procedure TPipeServer.ShutDownServer;
var
  BytesRead: Cardinal;
  OutMsg, InMsg: RPIPEMessage;
  ShutDownMsg: string;
begin
  if FHandle <> INVALID_HANDLE_VALUE then
  begin
    OutMsg.Size := SizeOf(OutMsg);
    with InMsg do
    begin
      Kind := 0;
      ShutDownMsg := cShutDownMsg + FPipeName;
      Count := Succ(Length(ShutDownMsg));
      StrPCopy(Data, ShutDownMsg);
    end;
    CalcMsgSize(InMsg);
    // 停止管道
    CallNamedPipe(
      PChar(FPipeName), @InMsg, InMsg.Size, @OutMsg, OutMsg.Size, BytesRead, 100
      );
    // 关闭管道
    CloseHandle(FHandle);
    self.FOpened:=false;
    // 清除handle
    FHandle := INVALID_HANDLE_VALUE;
  end;
end;

procedure TPipeServer.StartUpServer;
begin
     self.FOpened:=false;
  // 是否已存在同名管道
  if WaitNamedPipe(PChar(FPipeName), 100 {ms}) then
    raise Exception.Create('合名管道已存在');
  // 创建管道
  FHandle := CreateNamedPipe(
    PChar(FPipeName), PIPE_ACCESS_DUPLEX,
    PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_WAIT,
    PIPE_UNLIMITED_INSTANCES, SizeOf(RPIPEMessage), SizeOf(RPIPEMessage),
    NMPWAIT_USE_DEFAULT_WAIT, nil
    );
  if FHandle = INVALID_HANDLE_VALUE then
    raise Exception.Create('不能创建命名管道')
  else
    self.FOpened:=true;

end;

{ TPipeClient }

constructor TPipeClient.Create(aServer, aPipe: string);
begin
  inherited Create;

  if aServer = '' then
    FPipeName := Format(cPipeFormat, ['.', aPipe])
  else
    FPipeName := Format(cPipeFormat, [aServer, aPipe]);
   // FPipeName:='\\.\pipe\MyPipe';
end;

function TPipeClient.ProcessMsg(aMsg: RPIPEMessage): RPIPEMessage;
begin
  CalcMsgSize(aMsg);
  Result.Size := SizeOf(Result);
  if WaitNamedPipe(PChar(FPipeName), 10) then
    if not CallNamedPipe(
      PChar(FPipeName), @aMsg, aMsg.Size, @Result, Result.Size, Result.Size, 500 ) then
      raise Exception.Create('连接不到命名管道')
    else
  else
    raise Exception.Create('命名管道不存在');
end;

function TPipeClient.SendString(aStr: string): string;
var
  Msg: RPIPEMessage;
begin
  // prepare outgoing message
  astr:=UTF8Encode(astr);
  Msg.Kind := 1;
  Msg.Count := Length(aStr);
  StrPCopy(Msg.Data, aStr);
  // send message
  Msg := ProcessMsg(Msg);
  // return data send from server
  Result := Copy(Msg.Data, 1, Msg.Count);
  Result:=UTF8Decode(result);
end;

end.