In windows, it's relatively easy:
- Create a window handle with name appname_apphandle.
(can be reduced to simply appname if only one
instance will be running, see the thread about
single instances for my suggestion about that)
- Use this handle to send a message to with WM_COPY.
On linux/Unix:
- Create a unix socket /tmp/appname.appid under /tmp
or under ~/.appname/appid
(same remark about single instance)
- Use this socket to send message to with standard socket
functions.
I think that on Linux/unix you should use the X windows message passing,
so that you can talk between programs running on different machines. I
have had a stab at this in the past, and I attach a draft version.
Though not shown in the attached, under MS windows I used
RegisterWindowMessage('SpecialName');
and looked for this specific message in the appropriate wndproc (or it
could be the overall message loop)
Colin
{ Provides a interprogram system that can be used on both Windows and X11 }
unit CompatMsg;
interface
uses {$IFDEF MSWINDOWS} Windows, {$ENDIF}
{$IFDEF UNIX}
XLib,X
{$IFDEF KYLIX} Types, QGraphics, QControls, QForms, QDialogs, {$ENDIF}
{$IFDEF FPC} , Graphics, gdk, {$ENDIF}
{$ENDIF}
SysUtils, Classes;
type
{ Typedef to help compatibility - the X Window/Windows Window Type}
{$IFDEF MSWINDOWS}
TWnd = HWND;
{$ENDIF}
{$IFDEF UNIX}
TWnd = {$IFDEF CLX_}Window{$ENDIF}{$IFDEF LCL_}TWindow{$ENDIF};
{$ENDIF}
TOnCompatMsg = procedure (Sender: TObject; var Handled: Boolean) of object;
TCompatMsg = class(TComponent)
private
FMessageName: string;
FMessageID: {$IFDEF MSWINDOWS} UINT {$ENDIF} {$IFDEF UNIX} TAtom {$ENDIF};
FOnResultReceived: TOnCompatMsg;
FOnReceived: TOnCompatMsg;
FStatus: Integer;
procedure SetMessageName(const Value: string);
procedure SetOnReceived(const Value: TOnCompatMsg);
procedure SetOnResultReceived(const AValue: TOnCompatMsg);
procedure SetStatus(const AValue: Integer);
protected
FInternalHook: Boolean;
procedure DoOnReceived(var Handled: Boolean); virtual;
procedure DoOnResultReceived(var Handled: Boolean); virtual;
public
procedure CheckHooked;
destructor Destroy; override;
property MessageID: {$IFDEF MSWINDOWS} UINT {$ENDIF} {$IFDEF UNIX} TAtom {$ENDIF} read FMessageID;
published
property Status: Integer read FStatus write SetStatus;
property MessageName: string read FMessageName write SetMessageName;
property OnReceived: TOnCompatMsg read FOnReceived write SetOnReceived;
property OnResultReceived: TOnCompatMsg read FOnResultReceived write SetOnResultReceived;
end;
{$IFDEF UNIX}
function RootWindow:TWnd;
{ Handler for clipboard when type = XA_PIXMAP }
function LoadBitmapFromClipboard(Bitmap: TBitmap):Boolean;
function X11Display:PDisplay;
{$ENDIF}
function MainWindow:TWnd;
implementation
{$IFDEF MSWINDOWS}
uses Forms;
function MainWindow: TWnd;
begin
if Assigned(Application.MainForm) and Application.MainForm.HandleAllocated then
Result := Application.MainForm.Handle
else
Result := 0;
end;
{$ENDIF}
{$IFDEF UNIX}
uses
Clipbrd,
{$IFDEF KYLIX} Qt, Libc; {$ENDIF}
{$IFDEF LCL_} GTKProc, GTKDef, gtk, glib, Xatom, Forms; {$ENDIF}
{$ENDIF}
var
CompatMsgList: TList;
{$IFDEF UNIX}
{$IFDEF LCL_}
function X11Display:PDisplay;
begin
Result := gdk_display;
end;
{$ENDIF}
{$IFDEF LCL_}
function MainWindow: TWnd;
begin
if Assigned(Application.MainForm) and Application.MainForm.HandleAllocated then
Result := PGdkWindowPrivate(PGTKWidget(Application.MainForm.Handle)^.Window)^.xwindow
else
Result := 0;
end;
{$ENDIF}
{$IFDEF CLX_}
function X11Display:???what is the type
begin
Result := QtDisplay;
end;
function MainWindow: TWindow;
begin
Result := QWidget_winId(Application.MainForm.Handle);
end;
{$ENDIF}
var
RootWindowSave: TWnd;
function RootWindow:TWnd;
begin
if RootWindowSave = 0 then
RootWindowSave := XDefaultRootWindow(gdk_display);
Result := RootWindowSave;
end;
{$ENDIF}
{$IFDEF KYLIX}
{$IFNDEF DFS_KYLIX_3_UP}
{ Kylix 1/2 require this }
type
X11EventFilter = function(XEvent: PXEvent): Boolean; cdecl;
// bind using the mangled name export from libqt.so, determined using
// "objdump --dynamic-syms libqt.so | grep set_x11_event_filter". YMMV.
function SetX11EventFilter(Filter: X11EventFilter): X11EventFilter; cdecl;
external { 'libqt.so' } '' name QtNamePrefix + 'qt_set_x11_event_filter__FPFP7_XEvent_i';
{$ENDIF}
var
OldFilter: X11EventFilter = nil;
function CompatX11EventFilter(Event: PXEvent): Boolean; cdecl;
var
i: Integer;
begin
// Return False to continue processing, non-zero to prevent.
Result := False;
{ WriteLn('Event: ', Event^.xtype); }
if (Event^.xtype = PropertyNotify) and (Event^.xproperty.state <> PropertyDelete) then begin
for i := 0 to CompatMsgList.Count - 1 do
if TCompatMsg(CompatMsgList[i]).MessageID = Event^.xproperty.atom then begin
TCompatMsg(CompatMsgList[i]).DoOnReceived(Result);
if Result then Exit;
end;
end else if Event^.xtype = ClientMessage then begin
for i := 0 to CompatMsgList.Count - 1 do
if TCompatMsg(CompatMsgList[i]).MessageID = Event^.xclient.message_type then begin
TCompatMsg(CompatMsgList[i]).DoOnReceived(Result);
if Result then Exit;
end;
end;
if Assigned(OldFilter) then
Result := OldFilter(Event);
end;
{$ENDIF}
{$IFDEF LCL_}
function ClientMessageHook(xevent:PGdkXEvent; event:PGdkEvent; data:gpointer):TGdkFilterReturn;cdecl;
var
i: Integer;
Handled: Boolean;
begin
// WriteLn('Event: ', PGdkEventAny(xevent)^.thetype, ':', PXEvent(xevent)^.xclient.message_type, ' w:', PXEvent(xevent)^.xclient.window );
Handled := False;
if (PGdkEventAny(xevent)^.thetype = ClientMessage) and (Xlib.PXEvent(xevent)^.xclient.window = MainWindow)
and Assigned(CompatMsgList) then
{ Must search through list as there is no procedure to remove a filter,
and also to allow for multiple hooks on same message }
for i := 0 to CompatMsgList.Count - 1 do
with TCompatMsg(CompatMsgList.Items[i]) do
if MessageID = Xlib.PXEvent(xevent)^.xclient.message_type then begin
DoOnReceived(Handled);
if Handled then
Break;
end;
if Handled then
Result := GDK_FILTER_REMOVE
else
Result := GDK_FILTER_CONTINUE; { or possibly GDK_FILTER_TRANSLATE ? }
end;
{$ENDIF}
{$IFDEF LCL_}
var
AtomsMonitored: array of TAtom;
{$ENDIF}
procedure Hook(CompatMsg: TCompatMsg);
{$IFDEF LCL_}
var
i: Integer;
{$ENDIF}
begin
if not Assigned(CompatMsgList) then begin
CompatMsgList := TList.Create;
{$IFDEF KYLIX}
OldFilter := {$IFDEF DFS_KYLIX_3_UP}Application.{$ENDIF}
SetX11EventFilter(CompatX11EventFilter);
{$ENDIF}
// WriteLn(MainWindow);
end;
if CompatMsgList.IndexOf(CompatMsg) < 0 then
CompatMsgList.Add(CompatMsg);
{$IFDEF LCL_}
{ This logic is required because there is no gdk_remove_client_message function,
so we make sure we call the add function when absolutely necessary }
for i := 0 to High(AtomsMonitored) do
if AtomsMonitored[i] = CompatMsg.MessageID then
Exit;
SetLength(AtomsMonitored, Length(AtomsMonitored)+1);
AtomsMonitored[High(AtomsMonitored)] := CompatMsg.MessageID;
gdk_add_client_message_filter(CompatMsg.MessageID, @ClientMessageHook, nil);
{$ENDIF}
end;
procedure UnHookAll;
begin
if Assigned(CompatMsgList) then begin
FreeAndNil(CompatMsgList);
{$IFDEF KYLIX}
{$IFDEF DFS_KYLIX_3_UP}
OldFilter := Application.{$ENDIF} { Assignment seems to be required to keep compiler happy }
SetX11EventFilter(OldFilter);
{$ENDIF}
end;
end;
procedure UnHook(CompatMsg: TCompatMsg);
begin
if Assigned(CompatMsgList) and (CompatMsgList.IndexOf(CompatMsg) >= 0) then begin
CompatMsgList.Remove(CompatMsg);
CompatMsgList.Pack;
if CompatMsgList.Count = 0 then
UnHookAll;
end;
end;
{ TCompatMsg }
destructor TCompatMsg.Destroy;
begin
FInternalHook := False;
OnReceived := nil;
OnResultReceived := nil;
inherited;
end;
procedure TCompatMsg.DoOnReceived(var Handled: Boolean);
begin
if Assigned(FOnReceived) then begin
{$IFDEF UNIX}
try
Status := -1; { Processing }
FOnReceived(Self, Handled);
if Status = -1 then
Status := Ord(Handled);
except
Status := -2; { Flag crash }
Application.HandleException(Self);
end;
{$ENDIF}
end;
end;
procedure TCompatMsg.DoOnResultReceived(var Handled: Boolean);
begin
if Assigned(FOnResultReceived) then
FOnResultReceived(Self, Handled);
end;
procedure TCompatMsg.CheckHooked;
begin
if not (csDesigning in ComponentState) then begin
if not Assigned(OnReceived) and not Assigned(OnResultReceived) and not (FInternalHook) then
UnHook(Self)
else
Hook(Self);
end;
end;
procedure TCompatMsg.SetMessageName(const Value: string);
begin
FMessageName := Value;
if not (csDesigning in ComponentState) then begin
{$IFDEF MSWINDOWS}
FMessageID := RegisterWindowMessage(PChar(Value));
{$ENDIF}
{$IFDEF UNIX}
FMessageID := XInternAtom(gdk_display,PChar(Value), False);
{$ENDIF}
end;
end;
procedure TCompatMsg.SetOnReceived(const Value: TOnCompatMsg);
begin
FOnReceived := Value;
CheckHooked;
end;
procedure TCompatMsg.SetOnResultReceived(const AValue: TOnCompatMsg);
begin
FOnResultReceived := AValue;
CheckHooked;
end;
procedure TCompatMsg.SetStatus(const AValue: Integer);
begin
if (FStatus=AValue) or (MainWindow =0) or (MessageID = 0) then exit;
FStatus:=AValue;
{$IFDEF UNIX}
XChangeProperty(gdk_display, MainWindow, MessageID, XA_INTEGER, 32, PropModeReplace, @FStatus, 1);
XFlush(gdk_display);
{$ENDIF}
end;
initialization
finalization
UnHookAll;
end.
