From 7b8a26e75924ecff47d3e347eb4e2685656c728e Mon Sep 17 00:00:00 2001
From: plugwash <plugwash@p10link.net>
Date: Sun, 10 Sep 2017 20:02:13 +0000
Subject: [PATCH 1/1] Replace obsolete/broken lcoregtklaz with new lcorelazarus
 Rename lmessages to lcoremessages due to unit name conflict with Lazarus

git-svn-id: file:///svnroot/lcore/trunk@149 b1de8a11-f9be-4011-bde0-cc7ace90066a
---
 bsearchtree.pas                    |   3 +
 btime.pas                          |   8 +-
 dnsasync.pas                       |   4 +-
 lcoregtklaz.pas                    | 142 ------------------------
 lcorelazarus.pas                   | 166 +++++++++++++++++++++++++++++
 lcorelocalips.pas                  |   6 +-
 lmessages.pas => lcoremessages.pas |   2 +-
 lcorernd.pas                       |   4 +-
 lcoretest.dpr                      |   2 +-
 lcorewsaasyncselect.pas            |   1 +
 unitfork.pas                       |   4 +-
 unitwindowobject.pas               |   4 +-
 wmessages.pas                      |   4 +-
 13 files changed, 193 insertions(+), 157 deletions(-)
 delete mode 100644 lcoregtklaz.pas
 create mode 100644 lcorelazarus.pas
 rename lmessages.pas => lcoremessages.pas (96%)

diff --git a/bsearchtree.pas b/bsearchtree.pas
index 9ec804c..249a6ff 100644
--- a/bsearchtree.pas
+++ b/bsearchtree.pas
@@ -7,6 +7,9 @@
 
 unit bsearchtree;
 
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
 interface
 
 uses blinklist;
diff --git a/btime.pas b/btime.pas
index ff77de9..8218e64 100644
--- a/btime.pas
+++ b/btime.pas
@@ -9,7 +9,9 @@ works on windows/delphi, and on freepascal on unix.
 
 
 unit btime;
-
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
 interface
 
 {$ifdef mswindows}
@@ -105,9 +107,7 @@ var
 
 implementation
 
-{$ifdef fpc}
-  {$mode delphi}
-{$endif}
+
 
 uses
   {$ifdef UNIX}
diff --git a/dnsasync.pas b/dnsasync.pas
index 68b5c1f..f9fa50e 100644
--- a/dnsasync.pas
+++ b/dnsasync.pas
@@ -7,7 +7,9 @@
 //not seem to have any form of retry code.
 
 unit dnsasync;
-
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
 interface
 
 uses
diff --git a/lcoregtklaz.pas b/lcoregtklaz.pas
deleted file mode 100644
index 6473784..0000000
--- a/lcoregtklaz.pas
+++ /dev/null
@@ -1,142 +0,0 @@
-{ 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
-  ----------------------------------------------------------------------------- }
-      
-unit lcoregtklaz;
-{$mode delphi}
-interface
-	
-uses baseunix,unix,glib, gdk, gtk,lcore,forms,fd_utils,classes;
-//procedure lcoregtklazrun;
-const
-  G_IO_IN=1;
-  G_IO_OUT=4;
-  G_IO_PRI=2;
-  G_IO_ERR=8;
-
-  G_IO_HUP=16;
-  G_IO_NVAL=32;
-type
-  tlaztimerwrapperinterface=class(ttimerwrapperinterface)
-  public
-    function createwrappedtimer : tobject;override;
-//    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;
-    procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;
-    procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;
-    procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;
-  end;
-
-procedure lcoregtklazinit;
-implementation
-  uses
-    ExtCtrls;
-{$I unixstuff.inc}
-var
-  giochannels : array[0..absolutemaxs] of pgiochannel;
-
-function iocallback(source:PGIOChannel; condition:TGIOCondition; data:gpointer):gboolean;cdecl;
-// return true if we want the callback to stay
-var
-  fd                    : integer ;
-  fdsrlocal , fdswlocal : fdset   ;
-  currentasio           : tlasio  ;
-begin
-  fd := g_io_channel_unix_get_fd(source);
-  fd_zero(fdsrlocal);
-  fd_set(fd,fdsrlocal);
-  fdswlocal := fdsrlocal;
-  select(fd+1,@fdsrlocal,@fdswlocal,nil,0);
-  if fd_isset(fd,fdsrlocal) or fd_isset(fd,fdsrlocal) then begin
-    currentasio := fdreverse[fd];
-    if assigned(currentasio) then begin
-      currentasio.handlefdtrigger(fd_isset(currentasio.fdhandlein,fdsrlocal),fd_isset(currentasio.fdhandleout,fdswlocal));
-    end else begin
-      rmasterclr(fd);
-      wmasterclr(fd);
-    end;
-  end;
-  case condition of
-    G_IO_IN : begin
-      result := rmasterisset(fd);
-    end;
-    G_IO_OUT : begin
-      result := wmasterisset(fd);
-    end;
-  end;
-end;
-
-procedure gtkrmasterset(fd : integer);
-begin
-  if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);
-  g_io_add_watch(giochannels[fd],G_IO_IN,iocallback,nil);
-end;
-
-procedure gtkrmasterclr(fd: integer);
-begin
-end;
-  
-procedure gtkwmasterset(fd : integer);
-begin
-  if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);
-  g_io_add_watch(giochannels[fd],G_IO_OUT,iocallback,nil);
-end;
-
-procedure gtkwmasterclr(fd: integer);
-begin
-end;
-
-type
-  tsc = class
-    procedure dotasksandsink(sender:tobject;error:word);
-  end;
-var
-  taskloopback : tlloopback;
-  sc           : tsc;
-procedure tsc.dotasksandsink(sender:tobject;error:word);
-begin
-  with tlasio(sender) do begin
-    sinkdata(sender,error);
-    processtasks;
-  end;
-end;
-procedure gtkaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
-begin
-  taskloopback.sendstr(' ');
-  
-end;
-
-procedure lcoregtklazinit;
-begin
-  onrmasterset := gtkrmasterset;
-  onrmasterclr := gtkrmasterclr;
-  onwmasterset := gtkwmasterset;
-  onwmasterclr := gtkwmasterclr;
-  onaddtask := gtkaddtask;
-  taskloopback := tlloopback.create(nil);
-  taskloopback.ondataavailable := sc.dotasksandsink;
-  timerwrapperinterface := tlaztimerwrapperinterface.create(nil);
-end;
-
-function tlaztimerwrapperinterface.createwrappedtimer : tobject;
-begin
-  result := ttimer.create(nil);
-end;
-procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);
-begin
-  ttimer(wrappedtimer).ontimer := newvalue;
-end;
-procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);
-begin
-  ttimer(wrappedtimer).enabled := newvalue;
-end;
-
-
-procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);
-begin
-  ttimer(wrappedtimer).interval := newvalue;
-end;
-
-
-end.
-
diff --git a/lcorelazarus.pas b/lcorelazarus.pas
new file mode 100644
index 0000000..d347703
--- /dev/null
+++ b/lcorelazarus.pas
@@ -0,0 +1,166 @@
+{ Copyright (C) 2005-2017 Robin Green, Bas Steendijk, Peter Green
+  For conditions of distribution and use, see copyright notice in zlib_license.
+txt
+  which is included in the package
+  -----------------------------------------------------------------------------
+}
+
+unit lcorelazarus;
+{$mode delphi}
+interface
+
+uses
+  lcore,
+  Classes, SysUtils,Forms,fd_utils,LCLIntf,InterfaceBase,ExtCtrls;
+
+
+procedure lcoreinit;
+
+implementation
+const
+  absolutemaxs_select = (sizeof(fdset)*8)-1;
+
+var
+  fdreverse:array[0..absolutemaxs_select] of tlasio;
+  fdEventHandlers:array[0..absolutemaxs_select] of PEventHandler;
+  fdflags:array[0..absolutemaxs_select] of byte;
+  tasksoutstanding : boolean;
+type
+  tlazaruseventcore=class(teventcore)
+  public
+    procedure processmessages; override;
+    procedure messageloop; override;
+    procedure exitmessageloop;override;
+    procedure setfdreverse(fd : integer;reverseto : tlasio); override;
+    procedure rmasterset(fd : integer;islistensocket : boolean); override;
+    procedure rmasterclr(fd: integer); override;
+    procedure wmasterset(fd : integer); override;
+    procedure wmasterclr(fd: integer); override;
+    procedure WaitHandleEvent(AData: PtrInt; AFlags: dword);
+    procedure taskcb(Data: PtrInt);
+  end;
+
+  tlaztimerwrapperinterface=class(ttimerwrapperinterface)
+  public
+    function createwrappedtimer : tobject;override;
+//    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;
+    procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;
+    procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;
+    procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;
+  end;
+const
+  G_IO_IN  = 1;
+  G_IO_OUT = 4;
+
+procedure tlazaruseventcore.taskcb(Data: PtrInt);
+begin
+
+   tasksoutstanding := false;
+   processtasks;
+end;
+
+procedure tlazaruseventcore.WaitHandleEvent(AData: PtrInt; AFlags: dword);
+var lasio:tlasio;
+begin
+   lasio:=fdreverse[AData];
+   if lasio<>nil then lasio.handlefdtrigger((AFlags and G_IO_IN)<>0,(AFlags and G_IO_OUT)<>0);
+end;
+
+procedure tlazaruseventcore.processmessages;
+begin
+   Application.ProcessMessages;
+end;
+procedure tlazaruseventcore.messageloop;
+begin
+   Application.Run;
+end;
+procedure tlazaruseventcore.exitmessageloop;
+begin
+   Application.Terminate;
+end;
+procedure tlazaruseventcore.setfdreverse(fd : integer;reverseto : tlasio);
+begin
+  fdreverse[fd] := reverseto;
+
+end;
+procedure addfdflags(fd : integer;flags:byte);
+begin
+   fdflags[fd]:=fdflags[fd] or flags;
+   if fdEventHandlers[fd]=nil then  begin
+      fdEventHandlers[fd]:=AddEventHandler(fd,flags,tlazaruseventcore(eventcore).WaitHandleEvent,fd);
+   end else begin
+
+      SetEventHandlerFlags(fdEventHandlers[fd], fdflags[fd]);
+   end;
+end;
+
+procedure removefdflags(fd : integer;flags:byte);
+begin
+   if fdEventHandlers[fd]<>nil then  begin
+      fdflags[fd]:=fdflags[fd] and (not flags);
+      if fdflags[fd]=0 then begin
+         RemoveEventHandler(fdEventHandlers[fd]);
+         fdEventHandlers[fd]:=nil;
+      end else begin
+
+         SetEventHandlerFlags(fdEventHandlers[fd], fdflags[fd]);
+      end;
+   end;
+end;
+
+procedure tlazaruseventcore.rmasterset(fd : integer;islistensocket : boolean);
+begin
+   addfdflags(fd,G_IO_IN);
+end;
+procedure tlazaruseventcore.rmasterclr(fd: integer);
+begin
+   removefdflags(fd,G_IO_IN);
+end;
+procedure tlazaruseventcore.wmasterset(fd : integer);
+begin
+   addfdflags(fd,G_IO_OUT);
+
+end;
+procedure tlazaruseventcore.wmasterclr(fd: integer);
+begin
+   removefdflags(fd,G_IO_OUT);
+end;
+
+procedure lazaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
+begin
+  if not tasksoutstanding then  Application.QueueAsyncCall(tlazaruseventcore(eventcore).taskcb,0);
+  tasksoutstanding := true;
+end;
+
+function tlaztimerwrapperinterface.createwrappedtimer : tobject;
+begin
+  result := ttimer.create(nil);
+end;
+procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);
+begin
+  ttimer(wrappedtimer).ontimer := newvalue;
+end;
+procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);
+begin
+  ttimer(wrappedtimer).enabled := newvalue;
+end;
+
+
+procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);
+begin
+  ttimer(wrappedtimer).interval := newvalue;
+end;
+var
+  inited:boolean;
+procedure lcoreinit;
+begin
+  if (inited) then exit;
+  eventcore := tlazaruseventcore.create;
+  onaddtask := lazaddtask;
+
+  absolutemaxs := absolutemaxs_select;
+  inited := true;
+end;
+
+end.
+
diff --git a/lcorelocalips.pas b/lcorelocalips.pas
index d275012..8698a8c 100644
--- a/lcorelocalips.pas
+++ b/lcorelocalips.pas
@@ -36,7 +36,9 @@ notes:
 }
 
 unit lcorelocalips;
-
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
 interface
 
 uses binipstuff,pgtypes;
@@ -416,4 +418,4 @@ begin
 end;
 {$endif}
 
-end.
+end.
\ No newline at end of file
diff --git a/lmessages.pas b/lcoremessages.pas
similarity index 96%
rename from lmessages.pas
rename to lcoremessages.pas
index d5521e5..8a2bd54 100644
--- a/lmessages.pas
+++ b/lcoremessages.pas
@@ -8,7 +8,7 @@
 //the main lcore thread
 //This unit is *nix only, on windows you should use the real thing
 
-unit lmessages;
+unit lcoremessages;
 //windows messages like system based on lcore tasks
 interface
 
diff --git a/lcorernd.pas b/lcorernd.pas
index b76ab49..d278852 100644
--- a/lcorernd.pas
+++ b/lcorernd.pas
@@ -4,7 +4,9 @@
   ----------------------------------------------------------------------------- }
 
 unit lcorernd;
-
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
 interface
 
 {$include lcoreconfig.inc}
diff --git a/lcoretest.dpr b/lcoretest.dpr
index bfba054..288c0b4 100644
--- a/lcoretest.dpr
+++ b/lcoretest.dpr
@@ -17,7 +17,7 @@ uses
   {$ifndef mswindows}
     ,
     {$ifndef nomessages}
-      lmessages,
+      lcoremessages,
       unitwindowobject,
     {$endif}
     unitfork
diff --git a/lcorewsaasyncselect.pas b/lcorewsaasyncselect.pas
index d029103..6b4c01b 100644
--- a/lcorewsaasyncselect.pas
+++ b/lcorewsaasyncselect.pas
@@ -166,6 +166,7 @@ end;
 procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
 begin
   if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);
+  tasksoutstanding := true;
 end;
 type
   twcoretimer = wcore.tltimer;
diff --git a/unitfork.pas b/unitfork.pas
index 019695b..3bcb3b1 100644
--- a/unitfork.pas
+++ b/unitfork.pas
@@ -3,7 +3,9 @@
     which is included in the package
       ----------------------------------------------------------------------------- }
 unit unitfork;
-
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
 interface
 
 procedure dofork(const programname:string);
diff --git a/unitwindowobject.pas b/unitwindowobject.pas
index 414f975..ec5d955 100644
--- a/unitwindowobject.pas
+++ b/unitwindowobject.pas
@@ -12,9 +12,9 @@ uses
   {$ifdef mswindows}
     windows,messages,wmessages,
   {$else}
-    lmessages,
+    lcoremessages,
     {$macro on}
-    {$define windows := lmessages}
+    {$define windows := lcoremessages}
   {$endif}
   sysutils,
   pgtypes;
diff --git a/wmessages.pas b/wmessages.pas
index 205e79d..526eba5 100644
--- a/wmessages.pas
+++ b/wmessages.pas
@@ -5,7 +5,7 @@
       
 unit wmessages;
 //this unit contains various functions and types to make it easier to write
-//code that works with both real windows messages and lmessages
+//code that works with both real windows messages and lcoremessages
 
 interface
 uses windows,messages,pgtypes;
@@ -15,7 +15,7 @@ type
 
 //according to MS you are supposed to use get/setwindowlongptr to get/set
 //pointers in extra window memory so your program can be built for win64, this
-//is also the only interface to window memory that lmessages offers but delphi
+//is also the only interface to window memory that lcoremessages offers but delphi
 //doesn't define it so alias it to getwindowlong here for win32.
 {$ifndef win64} //future proofing ;)
   function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;
-- 
2.30.2