{*******************************************************} { } { AppCtrlServer } { } { Copyright (C) 2023 kku } { } {*******************************************************} unit AppCtrlServer; interface uses Tocsg.ClientBase, System.SysUtils, System.Classes, WinApi.Windows, Tocsg.Packet, Winapi.Messages, Tocsg.Process.IPC, System.Generics.Collections, AppCtrlDefine; const WM_NOTIFY_CONNECT_MODULE = WM_USER + 5938; type PCMEnt = ^TCMEnt; TCMEnt = record // Connect Module hPipe: THandle; dwPid: DWORD; sPName, sPPath: String; end; TDcCMEnt = TDictionary; TEvtSendCtrlOpt = procedure(pEnt: PCMEnt) of object; TAppCtrlServer = class(TTgClientBase) private hRcvWnd_: HWND; evSendCtrlOpt_: TEvtSendCtrlOpt; procedure OnCMEntNotify(Sender: TObject; const Item: PCMEnt; Action: TCollectionNotification); protected DcCMEnt_: TDcCMEnt; dwLastSaveTick_: DWORD; procedure OnNpDisconnected(Sender: TTgNpBase; hPipe: THandle); function HasCMEnt(hPipe: THandle): Boolean; procedure ConnectedEvent; override; procedure DisconnectedEvent; override; procedure ProcessRcvPacket(aRcv: IRcvPacket); override; public Constructor Create(hRcvWnd: HWND); Destructor Destroy; override; function CountEnt: Integer; function ActiveNp(sPipeName: String; bNpServer: Boolean): Boolean; override; property OnSendCtrlOpt: TEvtSendCtrlOpt write evSendCtrlOpt_; end; implementation uses Tocsg.Exception, superobject, GlobalDefine, Tocsg.Path, Tocsg.Json; { TAppCtrlServer } Constructor TAppCtrlServer.Create(hRcvWnd: HWND); begin Inherited Create('', -1); hRcvWnd_ := hRcvWnd; evSendCtrlOpt_ := nil; dwLastSaveTick_ := 0; DcCMEnt_ := TDcCMEnt.Create; DcCMEnt_.OnValueNotify := OnCMEntNotify; end; Destructor TAppCtrlServer.Destroy; begin FreeAndNIl(DcCMEnt_); Inherited; end; procedure TAppCtrlServer.OnCMEntNotify(Sender: TObject; const Item: PCMEnt; Action: TCollectionNotification); begin if Action = cnRemoved then Dispose(Item); end; procedure TAppCtrlServer.OnNpDisconnected(Sender: TTgNpBase; hPipe: THandle); begin // ¿¬°á ¸ðµâ Á¾·á if hRcvWnd_ <> 0 then SendMessage(hRcvWnd_, WM_NOTIFY_CONNECT_MODULE, 0, hPipe); Lock; try if DcCMEnt_.ContainsKey(hPipe) then DcCMEnt_.Remove(hPipe); finally Unlock; end; end; function TAppCtrlServer.HasCMEnt(hPipe: THandle): Boolean; begin Lock; try Result := DcCMEnt_.ContainsKey(hPipe); finally Unlock; end; end; function TAppCtrlServer.CountEnt: Integer; begin Lock; try Result := DcCMEnt_.Count; finally Unlock; end; end; function TAppCtrlServer.ActiveNp(sPipeName: String; bNpServer: Boolean): Boolean; begin Result := Inherited; if bNpServer and Result and (NpIpc_ <> nil) then NpIpc_.OnDisconnected := OnNpDisconnected; end; procedure TAppCtrlServer.ConnectedEvent; var Send: ISendPacket; begin try // Inherited; // SetSendPauseState(false); _Trace('Connected.'); except on E: Exception do ETgException.TraceException(Self, E, 'Fail .. ConnectedEvent()'); end; end; procedure TAppCtrlServer.DisconnectedEvent; begin try // Inherited; QSendPacket_.Clear; _Trace('Disconnected'); except on E: Exception do ETgException.TraceException(Self, E, 'Fail .. DisconnectedEvent()'); end; end; procedure TAppCtrlServer.ProcessRcvPacket(aRcv: IRcvPacket); var Send: ISendPacket; procedure process_ACC_TEST_LOG; begin _Trace(aRcv.S['Msg']); // Send := TTgPacket.Create(aRcv); // Send.S['Msg'] := aRcv.S['Msg'] + ' ÇÏÇÏÇÏ'; // SendPacket(Send); end; procedure process_ACC_APP_INFO; var pEnt: PCMEnt; sPath: String; begin if HasCMEnt(aRcv.Toss) then begin _Trace('Fail .. process_ACC_APP_INFO() .. Already PipeInfo'); exit; end; New(pEnt); pEnt.hPipe := aRcv.Toss; pEnt.dwPid := aRcv.I['PID']; sPath := aRcv.S['Path']; pEnt.sPName := ExtractFileName(sPath); pEnt.sPPath := ExtractFilePath(sPath); Lock; try DcCMEnt_.Add(pEnt.hPipe, pEnt); finally Unlock; end; if hRcvWnd_ <> 0 then SendMessage(hRcvWnd_, WM_NOTIFY_CONNECT_MODULE, 1, NativeInt(pEnt)); // Send := TTgPacket.Create(ACC_SET_POLICY); // Send.Toss := aRcv.Toss; // Send.O['Opt'] := TTgJson.ValueToJsonObject(AppCtrlOpt_); // SendPacket(Send); if Assigned(evSendCtrlOpt_) then evSendCtrlOpt_(pEnt); end; begin try case aRcv.Command of ACC_TEST_LOG : process_ACC_TEST_LOG; ACC_APP_INFO : process_ACC_APP_INFO; ACC_SET_POLICY : ; end; except on E: Exception do ETgException.TraceException(Self, E, 'Fail .. ProcessRcvPacket(), Cmd=%d', [aRcv.Command]); end; end; end.