From: plugwash <plugwash@p10link.net>
Date: Sun, 10 Sep 2017 20:02:13 +0000 (+0000)
Subject: Replace obsolete/broken lcoregtklaz with new lcorelazarus
X-Git-Url: http://www.lcore.org/git/lcore.git/commitdiff_plain/7b8a26e75924ecff47d3e347eb4e2685656c728e?ds=inline
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
---
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;