Модератор: Модераторы
Если не устраивает привязка компонента к LCL, из него можно выковырять значимый код -- создание SimpleIPC сервера и подключение к нему.
coyot.rush писал(а):Ссылка на закачку компонента битая
UniqueInstance https://svn.bountysource.com/luipack/trunk/uniqueinstance/
Nik писал(а):...Можно просто использовать TUniqueInstance...
Это как-то соотносится с Виндусовским Mutex? Или это совсем из другой оперы?
Код: Выделить всё
function TWinMsgClientComm.ServerRunning: Boolean;
begin
Result:=FindWindow(MsgWndClassName,PChar(FWindowName))<>0;
end;Odyssey 13.01.2011 23:24:52
С сокетами идея интересная -- задач с ней можно решить побольше, но она и потруднее, и возможно потребует сторонних библиотек.
Не понимаю, зачем изобретать велосипед. UniqueInstance использует уже имеющийся в FPC кроссплатформенный механизм взаимодействия процессов -- SimpleIPC. Если не устраивает привязка компонента к LCL, из него можно выковырять значимый код -- создание SimpleIPC сервера и подключение к нему. Никаких платформозависимых решений, никаких временных файлов.
никаких временных файлов
Код: Выделить всё
procedure TPipeServerComm.StartServer;
begin
If not FileExists(FFileName) then
If (fpmkFifo(FFileName,438)<>0) then
Owner.DoError(SErrFailedToCreatePipe,[FFileName]);
FStream:=TFileStream.Create(FFileName,fmOpenReadWrite);
end;coyot.rush писал(а):Код: Выделить всё
function TWinMsgClientComm.ServerRunning: Boolean;
begin
Result:=FindWindow(MsgWndClassName,PChar(FWindowName))<>0;
end;
coyot.rush писал(а):Фрагмент SimpleIPC под WindowsКод: Выделить всё
...
Result:=FindWindow(MsgWndClassName,PChar(FWindowName))<>0;
...
Напоминает старый антиотладочный приём
Серьёзных недостатков в этом коде не вижу, кроме неприятных воспоминаний.coyot.rush писал(а):Odyssey 13.01.2011 23:24:52
С сокетами идея интересная -- задач с ней можно решить побольше, но она и потруднее, и возможно потребует сторонних библиотек.
1) Ни каких сторонних библиотек не под Windows, не под Linux не надо (libc и kernel32.dll)
coyot.rush писал(а):2)Имхо, под Windows код нужно исправлять и заменить на Named Pipes
coyot.rush писал(а):3)никаких временных файлов
Unix
...
, но работает 
Код: Выделить всё
{
UsendParam Copyright (c) 2011 by Coyot.RusH
version 08/02/2011
This unit is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
unit usendparam;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils{$ifdef windows},Windows{$endif}{$ifdef linux},libc{$endif};
type
TOnMessageEvent = procedure (const Sender:TObject;const Msg:string ) of object;
TOnErrorEvent =procedure (const Sender:TObject;const Error:integer ) of object;
type
infoParamLine=record
Count:integer;
Tail:integer;
end;
type
{ TSendParam }
TSendParam=class(TThread)
private
FOnError: TOnErrorEvent;
FOnMessage:TOnMessageEvent;
FIDServer:string;
FMode:Boolean;
SError:integer;
SMessage:String;
{$ifdef windows}
hpipe:Thandle;
FPipe: PHANDLE;
pSD: PSECURITY_DESCRIPTOR;
sa: SECURITY_ATTRIBUTES;
FOverLapWrt: OVERLAPPED;
FEventWrt: THANDLE;
{$endif}
{$ifdef linux}
hpipe:integer;
{$endif}
function GetCommandLine():string;
function GetCountNumberCommandLine(const Str:string):infoParamLine;
function CheckRunningServer():Boolean;
function RunServer():Boolean;
function RunClient():Boolean;
function WriteMessage(Msg:String):integer;
procedure DoError(const Error:integer);
procedure DoMessage(const Msg:string);
procedure CallError();
procedure CallMessage();
public
constructor Create(const AppId:string);
destructor Destroy; override;
procedure Execute; override;
property CheckTwoApp: Boolean read FMode;
property OnMessage:TOnMessageEvent read FOnMessage write FOnMessage;
property OnError:TOnErrorEvent read FOnError write FOnError;
property ParamLine:string read GetCommandLine;
end;
function DecodeError(const Error:integer):string;
implementation
uses main;
const
FailedToRunningServer=0;
FailedToRunningClient=1;
FailedToPreviousRun=2;
FailedToAllocationMemoryForSD=3;
FailedToInitializeSecurityDescriptor=4;
FailedToSetSecurityDescriptor=5;
CannotFindPipe=6;//Assure Server32 is started, check share name.
FailedToCreateFile=7;
FailedToCreateNamedPipe=8;
FailedToReadFile=9;
Block_Size=10;
{$ifdef windows}
MAX_PIPE_INSTANCES = 100;
NAME_SIZE = 25;
LINE_LEN = 80;
IN_BUF_SIZE = Block_Size;
OUT_BUF_SIZE = Block_Size;
TIME_OUT = 0;
MAX_READ = Block_Size*Sizeof(Char);
MAX_WRITE =Block_Size*sizeof(Char);
{$endif}
CR=#13;
function DecodeError(const Error: integer): string;
begin
case Error of
FailedToRunningServer:Result:='Failed To Running Server';
FailedToRunningClient:Result:='Failed To Running Client';
FailedToPreviousRun:Result:='Failed To Previous Run';
FailedToAllocationMemoryForSD:Result:='Failed To Allocation Memory For Security Descriptor';
FailedToInitializeSecurityDescriptor:Result:='Failed To Initialize Security Descriptor';
FailedToSetSecurityDescriptor:Result:='Failed To Set Security Descriptor';
CannotFindPipe:Result:='Cannot Find Pipe: Assure Server32 is started, check share name';
FailedToCreateFile:Result:='Failed To Create File';
FailedToCreateNamedPipe:Result:='Failed To Create Named Pipe';
FailedToReadFile:Result:='Failed To Read File';
else;
Result:='Unknown Error';
end;
end;
{ TSendParam }
procedure TSendParam.DoError(const Error: integer);
begin
if Assigned(OnError) then
begin
SError:=Error;
Synchronize(@CallError);
end;
end;
procedure TSendParam.DoMessage(const Msg: string);
begin
if Assigned(OnMessage) then
begin
SMessage:=Msg;
Synchronize(@CallMessage);
end;
end;
procedure TSendParam.CallError();
begin
FOnError(self,SError);
end;
procedure TSendParam.CallMessage();
begin
FOnMessage(self,SMessage);
end;
function TSendParam.GetCommandLine: string;
var
Iparam:integer;
tmpS:string;
begin
tmpS:='';
for iparam:=1 to Paramcount do
begin
tmpS:=tmpS+ParamStr(iparam)+CR;
end;
Result:=tmpS{$ifdef linux}+CR{$endif};
end;
function TSendParam.CheckRunningServer(): Boolean;
{$IFDEF WINDOWS}
var
r:integer;
begin
Result := False;
r:=CreateFile(PChar(sysutils.GetEnvironmentVariable('USERPROFILE')+'\.'+FIDServer+'.lock'),
GENERIC_READ or GENERIC_WRITE,0,nil, CREATE_ALWAYS,FILE_ATTRIBUTE_NORMAL, 0);
if r=-1
then Result:=True;
end;
{$ENDIF}
{$IFDEF LINUX}
var
FileHandle, Tvar: Integer;
LockVar: TFlock;
smode: Byte;
FileAccessRights:integer;
begin
Result :=False;
FileAccessRights:=S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH;
begin
FileHandle := open(PChar(GetEnvironmentVariable('HOME')+'/.'+FIDServer+'.lock'),O_CREAT or O_TRUNC or O_RDWR, FileAccessRights);
if FileHandle = -1 then Exit;
begin
with LockVar do
begin
l_whence := SEEK_SET;
l_start := 0;
l_len := 0;
l_type :=F_WRLCK ;
end;
Tvar := fcntl(FileHandle, F_SETLK, LockVar);
if Tvar = -1 then
begin
Result:=True;
__close(FileHandle);
Exit;
end;
end;
Result :=False;
end;
end;
{$ENDIF}
function TSendParam.RunServer(): Boolean;
{$IFDEF WINDOWS}
var
tmpNamePipe:string;
begin
Result:=True;
pSD := PSECURITY_DESCRIPTOR(LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH));
if not Assigned(pSD) then
begin
DoError(FailedToAllocationMemoryForSD);
Result:=False;
Exit;
end;
if not InitializeSecurityDescriptor (pSD,SECURITY_DESCRIPTOR_REVISION) then
begin
DoError(FailedToInitializeSecurityDescriptor);
LocalFree(HLOCAL(pSD));
Result:=False;
Exit;
end;
if not SetSecurityDescriptorDacl(pSD, true, nil, false) then
begin
DoError(FailedToSetSecurityDescriptor);
LocalFree(HLOCAL(pSD));
Result:=False;
Exit;
end;
sa.nLength := sizeof(sa);
sa.lpSecurityDescriptor := pSD;
sa.bInheritHandle := true;
tmpNamePipe:='\\.\PIPE\'+FIDServer;
hPipe := CreateNamedPipe (PChar(tmpNamePipe),
PIPE_ACCESS_DUPLEX,
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
DoError(FailedToCreateNamedPipe);
Result:=False;
Exit;
end;
end;
{$ENDIF}
{$ifdef linux}
var
Path:string;
const
a=0400;
begin
Result:=False;
Path:=GetEnvironmentVariable('HOME') + '/.pipe.' + FIDServer;
if libc.mkfifo(PChar(Path), a) = 0 then
begin
Result:=True;// Create Pipes
end;
hpipe :=libc.Open(Pchar(Path), O_RDWR);
if hpipe>-1 then Result:=True;
end;
{$ENDIF}
function TSendParam.RunClient(): Boolean;
{$IFDEF WINDOWS}
var
tmpName:string;
retCode: DWORD;
begin
Result:=True;
New(FPipe);
tmpName:='\\.\PIPE\'+FIDServer;
if WaitNamedPipe(PChar(tmpName),2000) then
begin
FPipe^ := CreateFile (PChar(tmpName),
GENERIC_WRITE or
GENERIC_READ,
FILE_SHARE_READ or
FILE_SHARE_WRITE,
nil,
OPEN_EXISTING,
FILE_FLAG_OVERLAPPED,
0);
if FPipe^ = INVALID_HANDLE_VALUE then
begin
retCode := GetLastError;
if (retCode = ERROR_SEEK_ON_DEVICE) or (retCode = ERROR_FILE_NOT_FOUND) then
begin
DoError(CannotFindPipe);
Result:=False;
end
else
begin
DoError(FailedToCreateFile);
Result:=False;
end;
Result:=False;
Exit;
end;
end;
end;
{$ENDIF}
{$ifdef linux}
var
Path:string;
begin
Result:=true;
Path:=GetEnvironmentVariable('HOME') + '/.pipe.' + FIDServer;
hpipe:=Open(PChar(Path), O_RDWR);
if hpipe=-1 then Result:=False;
end;
{$ENDIF}
function TSendParam.WriteMessage(Msg: String): integer;
{$IFDEF WINDOWS}
var
rc: Boolean;
bytesWritten: DWORD;
lastError: DWORD;
hEventWRT: THANDLE;
begin
rc := WriteFile (FPipe^, MSg[1],Length(Msg), bytesWritten,@FOverLapWrt);
if not rc then
begin
lastError := GetLastError;
if lastError = ERROR_IO_PENDING then WaitForSingleObject (hEventWRT, INFINITE);
end;
DisconnectNamedPipe(FPipe^);
Result:=bytesWritten;
end;
{$ENDIF}
{$ifdef linux}
begin
Result:=libc.__write(hpipe,Msg[1] ,Length(Msg));
end;
{$ENDIF}
constructor TSendParam.Create(const AppId:string);
var
iL:integer;
iC:infoParamLine;
CL:string;
tmp:string;
begin
inherited Create(True);
FIDServer:=AppId;
FMode:=False;
FMode:=CheckRunningServer();
if FMode=False then
begin
//If not running Server
end
else
begin
//If Running Server
if RunClient()=False then
begin
DoError(FailedToRunningClient);
end
else
begin
CL:=GetCommandLine;
ic:=GetCountNumberCommandLine(CL);
for iL:=0 to iC.count-1 do
begin
tmp:=Copy(CL,(iL*Block_Size)+1,Block_Size);
if (iL=ic.count-1) and (ic.tail>0) then
begin
SetLength(tmp,ic.tail);
WriteMessage(tmp);
end
else
begin
WriteMessage(Copy(CL,(iL*Block_Size)+1,Block_Size));
end;
end;
end;
end;
end;
destructor TSendParam.Destroy;
begin
//TODO Free procedure
inherited Destroy;
end;
function TSendParam.GetCountNumberCommandLine(const Str:string):infoParamLine;
var
L,C,M:integer;
begin
L:=Length(Str);
C:=0;
C:=L div Block_Size;
M:=L mod Block_Size;
Result.tail:=M;
if M>0 then C:=c+1;
Result.Count:=c;
end;
procedure TSendParam.Execute;
{$IFDEF WINDOWS}
var
Msg,tmp:string;
bytesRead: DWORD;
bytesTransRd: DWORD;
rc: Boolean;
LastError: DWORD;
ExitLoop: Boolean;
OverLapWrt: OVERLAPPED;
OverLapRd: OVERLAPPED;
hEventRd: THANDLE;
CL:string;
begin
tmp:='';
if FMode=True then
begin
//Client
end
else
begin
//Server
while not Terminated do
begin
SetLength(Msg,Block_Size);
if RunServer=False then
begin
DoError(FailedToRunningServer);
//Exit;
end;
ExitLoop := false;
lastError := 0;
ConnectNamedPipe(hPipe, nil);
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, Msg[1], MAX_READ, bytesRead, @OverLapRd);
if not rc then
begin
lastError := GetLastError;
DoError(FailedToReadFile);
case lastError of
ERROR_IO_PENDING:
begin
WaitForSingleObject (hEventRd, INFINITE);
end;
ERROR_BROKEN_PIPE:
begin
ExitLoop := true;
end;
else
begin
DoError(FailedToReadFile);
ExitLoop := true;
end;
end;
end
else
begin
if bytesRead<Block_Size then
begin
SetLength(Msg,bytesRead);
end;
tmp:=tmp+Copy(Msg,1,bytesRead);
end;
if not ExitLoop then
begin
GetOverlappedResult (hPipe, OverLapRd, bytesTransRd, false);
end;
until ExitLoop;
DoMessage(tmp);
tmp:='';
CloseHandle (hPipe);
CloseHandle (hEventRd);
DisconnectNamedPipe (hPipe);
end;
end;
end;
{$ENDIF}
{$ifdef linux}
var
c: char;
tmpstr: string;
begin
if FMode=False then
begin
//Server
if RunServer=False then
begin
DoError(FailedToRunningServer);
//Exit;
end;
while not Terminated do
begin
tmpstr := '';
repeat
begin
if libc.__read(hpipe, c, 1) > 0 then
begin
tmpstr := tmpstr + c;
end;
end;
until c=Cr;
DoMessage(tmpstr);
end;
end;
end;
{$ENDIF}
end.
Код: Выделить всё
program pr_sendparam;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
{$ifdef FPC}
{$ifdef mswindows}{$apptype gui}{$endif}
{$endif}
uses
{$ifdef FPC}{$ifdef linux}cthreads,{$endif}{$endif}msegui,mseforms,main,usendparam;
begin
cta:=TSendParam.Create('Pr_SendParam');
if cta.CheckTwoApp=False then
begin
application.createform(tmainfo,mainfo);
CTA.OnMessage:=@mainfo.OnGetParam;
CTA.OnError:=@mainfo.OnError;
application.run;
end;
end.Код: Выделить всё
unit main;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
interface
uses
mseglob,mseguiglob,mseguiintf,mseapplication,msestat,msemenus,msegui,
msegraphics,msegraphutils,mseevent,mseclasses,mseforms,msesimplewidgets,
msewidgets,msedataedits,mseedit,msestrings,msetypes,msesplitter,usendparam;
type
tmainfo = class(tmainform)
Mlog: tmemoedit;
b_clear: tbutton;
procedure _onclear(const sender: TObject);
procedure OnGetParam(const Sender:TObject;const Msg:string );
procedure OnError(const Sender:TObject;const Error:integer);
procedure _oncreate(const sender: TObject);
end;
var
mainfo: tmainfo;
CTA:TSendParam;
implementation
uses
main_mfm;
procedure tmainfo._onclear(const sender: TObject);
begin
Mlog.text:='';
end;
procedure tmainfo.OnGetParam(const Sender: TObject; const Msg: string);
begin
mainfo.mlog.text:=mainfo.mlog.text+Msg;
end;
procedure tmainfo.OnError(const Sender: TObject;const Error: integer);
begin
mainfo.mlog.text:=mainfo.mlog.text+DecodeError(Error)+#13;
end;
zub писал(а):Ктонибудь юзает UniqueInstance? Приделал, в винде всё прекрасно работает, в линуксе нет(( - вторая копия видит первую, отправляет ей свою командную строку и закрывется. но в первой копии UniqueInstanceBase.FIPCServer.OnMessage почемуто несрабатывает при этом.
Код: Выделить всё
type
{ TMessageHook }
TMessageHook = class(TThread)
private
DebugServer: TSimpleIPCServer;
procedure ApplyMessage;
protected
procedure Execute; override;
public
constructor Create(CreateSuspended: Boolean; ASrv: TSimpleIPCServer);
end;
implementation
{ TMessageHook }
procedure TMessageHook.ApplyMessage;
begin
DebugServer.PeekMessage(3, True);
end;
procedure TMessageHook.Execute;
begin
while (not Terminated) and (true) do
begin
if DebugServer.Active then
if DebugServer.PeekMessage(3, False) then
begin
Synchronize(@ApplyMessage);
end;
end;
end;
constructor TMessageHook.Create(CreateSuspended: Boolean;
ASrv: TSimpleIPCServer);
begin
inherited Create(CreateSuspended);
DebugServer := ASrv;
end;\0
zub писал(а):Потоков у меня нет, всё в одном. Могу я обойтись onidle? что мне проверить у UniqueInstanceBase.FIPCServer чтоб самому вызвать OnMessage?
Извиняюсь за тупость, но первый раз сталкиваюсь с TSimpleIPCServer((
Код: Выделить всё
{$ifdef linux}
UniqueInstanceBase.FIPCServer.PeekMessage(0,true);
{$endif}