X-Git-Url: http://www.lcore.org/git/lcore.git/blobdiff_plain/f04d9ac0ffbe96ead372b84dad0786daba7f5ed7..70e049261c2b49411fbc9cefc737bc18ee6c4365:/lmessages.pas?ds=inline

diff --git a/lmessages.pas b/lmessages.pas
old mode 100755
new mode 100644
index db26b38..d5521e5
--- a/lmessages.pas
+++ b/lmessages.pas
@@ -1,9 +1,24 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+  For conditions of distribution and use, see copyright notice in zlib_license.txt
+  which is included in the package
+  ----------------------------------------------------------------------------- }
+
+//this unit provides a rough approximation of windows messages on linux
+//it is useful for multithreaded applications on linux to communicate back to
+//the main lcore thread
+//This unit is *nix only, on windows you should use the real thing
+
 unit lmessages;
 //windows messages like system based on lcore tasks
 interface
 
 uses pgtypes,sysutils,bsearchtree,strings,syncobjs;
 
+
+{$if (fpc_version < 2) or ((fpc_version=2) and ((fpc_release < 2) or ((fpc_release = 2) and (fpc_patch < 2)) ))}
+  {$error this code is only supported under fpc 2.2.2 and above due to bugs in the eventobject code in older versions}
+{$endif}
+
 type
   lparam=taddrint;
   wparam=taddrint;
@@ -58,11 +73,13 @@ type
 const
   WS_EX_TOOLWINDOW = $80;
   WS_POPUP = longint($80000000);
+  CW_USEDEFAULT=$80000000;
   hinstance=nil;
   PM_REMOVE = 1;
   WM_USER = 1024;
   WM_TIMER = 275;
   INFINITE = syncobjs.infinite;
+
 function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;
 function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;
 function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;
@@ -84,10 +101,11 @@ procedure init;
 
 implementation
 uses
-  baseunix,unix,lcore,unixutil;//,safewriteln;
+  baseunix,unix,lcore,unixutil,ltimevalstuff,sockets;//,safewriteln;
 {$i unixstuff.inc}
 
 type
+  
   tmessageintransit = class
     msg : tmsg;
     next : tmessageintransit;
@@ -99,7 +117,7 @@ type
     waiting : boolean;
     lcorethread : boolean;
     nexttimer : ttimeval;
-    threadid : integer;
+    threadid : tthreadid;
   end;
   twindow=class
     hwnd : hwnd;
@@ -116,22 +134,22 @@ var
   lcorelinkpiperecv : tlasio;
   windows : thashtable;
   //I would rather things crash immediately
-  //if they use an insufficiant size type
+  //if they use an insufficient size type
   //than crash after over four billion
   //windows have been made ;)
   nextwindowhandle : qword = $100000000;
-{$i ltimevalstuff.inc}
+
 
 //findthreaddata should only be called while holding the structurelock
-function findthreaddata(threadid : integer) : tthreaddata;
+function findthreaddata(threadid : tthreadid) : tthreaddata;
 begin
-  result := tthreaddata(findtree(@threaddata,inttostr(threadid)));
+  result := tthreaddata(findtree(@threaddata,inttostr(taddrint(threadid))));
   if result = nil then begin
     result := tthreaddata.create;
     result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result)));
     result.nexttimer := tv_invalidtimebig;
     result.threadid := threadid;
-    addtree(@threaddata,inttostr(threadid),result);
+    addtree(@threaddata,inttostr(taddrint(threadid)),result);
   end;
 end;
 
@@ -145,7 +163,7 @@ begin
     //writeln('freeing thread data object');
     athreaddata.free;
     //writeln('deleting thread data object from hashtable');
-    deltree(@threaddata,inttostr(athreaddata.threadid));
+    deltree(@threaddata,inttostr(taddrint(athreaddata.threadid)));
     //writeln('finished deleting thread data');
   end else begin
     //writeln('thread data is not unused');
@@ -217,7 +235,7 @@ begin
         //swriteln('duplicate window class registered with different settings');
         raise exception.create('duplicate window class registered with different settings');
       end else begin
-        //swriteln('duplicate window class registered with same settings, tollerated');
+        //swriteln('duplicate window class registered with same settings, tolerated');
       end;
     end else begin
       //swriteln('about to allocate memory for new windowclass');
@@ -274,10 +292,10 @@ begin
     window := twindow(findtree(@windows,inttostr(ahwnd)));
     if window <> nil then begin
       freemem(window.extrawindowmemory);
-      //writeln('aboute to delete window from windows structure');
+      //writeln('about to delete window from windows structure');
       deltree(@windows,inttostr(ahwnd));
       //writeln('deleted window from windows structure');
-      windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(window.threadid)));
+      windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(taddrint(window.threadid))));
 
       if windowthreaddata <> nil then begin
         //writeln('found thread data scanning for messages to clean up');
@@ -394,11 +412,15 @@ begin
       //we have to get the window procedure while the structurelock
       //is still held as the window could be destroyed from another thread
       //otherwise.
-      windowproc := window.windowproc;
+      if window <> nil then begin
+        windowproc := window.windowproc;
+      end else begin
+        windowproc := nil;
+      end;
     finally
       structurelock.release;
     end;
-    if window <> nil then begin
+    if assigned(windowproc) then begin
       result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam);
     end else begin
       result := -1;
@@ -475,7 +497,7 @@ end;
 
 function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;
 begin
-  result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,true);
+  result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,wRemoveMsg,true);
 end;
 
 function SetEvent(hEvent:THevent):WINBOOL;