lcorelazarus.pas

   1 { Copyright (C) 2005-2017 Robin Green, Bas Steendijk, Peter Green\r
   2   For conditions of distribution and use, see copyright notice in zlib_license.\r
   3 txt\r
   4   which is included in the package\r
   5   -----------------------------------------------------------------------------\r
   6 }\r
   7 \r
   8 unit lcorelazarus;\r
   9 {$mode delphi}\r
  10 interface\r
  11 \r
  12 uses\r
  13   lcore,\r
  14   Classes, SysUtils,Forms,fd_utils,LCLIntf,InterfaceBase,ExtCtrls;\r
  15 \r
  16 \r
  17 procedure lcoreinit;\r
  18 \r
  19 implementation\r
  20 const\r
  21   absolutemaxs_select = (sizeof(fdset)*8)-1;\r
  22 \r
  23 var\r
  24   fdreverse:array[0..absolutemaxs_select] of tlasio;\r
  25   fdEventHandlers:array[0..absolutemaxs_select] of PEventHandler;\r
  26   fdflags:array[0..absolutemaxs_select] of byte;\r
  27   tasksoutstanding : boolean;\r
  28 type\r
  29   tlazaruseventcore=class(teventcore)\r
  30   public\r
  31     procedure processmessages; override;\r
  32     procedure messageloop; override;\r
  33     procedure exitmessageloop;override;\r
  34     procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
  35     procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
  36     procedure rmasterclr(fd: integer); override;\r
  37     procedure wmasterset(fd : integer); override;\r
  38     procedure wmasterclr(fd: integer); override;\r
  39     procedure WaitHandleEvent(AData: PtrInt; AFlags: dword);\r
  40     procedure taskcb(Data: PtrInt);\r
  41   end;\r
  42 \r
  43   tlaztimerwrapperinterface=class(ttimerwrapperinterface)\r
  44   public\r
  45     function createwrappedtimer : tobject;override;\r
  46 //    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
  47     procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
  48     procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
  49     procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
  50   end;\r
  51 const\r
  52   G_IO_IN  = 1;\r
  53   G_IO_OUT = 4;\r
  54 \r
  55 procedure tlazaruseventcore.taskcb(Data: PtrInt);\r
  56 begin\r
  57 \r
  58    tasksoutstanding := false;\r
  59    processtasks;\r
  60 end;\r
  61 \r
  62 procedure tlazaruseventcore.WaitHandleEvent(AData: PtrInt; AFlags: dword);\r
  63 var lasio:tlasio;\r
  64 begin\r
  65    lasio:=fdreverse[AData];\r
  66    if lasio<>nil then lasio.handlefdtrigger((AFlags and G_IO_IN)<>0,(AFlags and G_IO_OUT)<>0);\r
  67 end;\r
  68 \r
  69 procedure tlazaruseventcore.processmessages;\r
  70 begin\r
  71    Application.ProcessMessages;\r
  72 end;\r
  73 procedure tlazaruseventcore.messageloop;\r
  74 begin\r
  75    Application.Run;\r
  76 end;\r
  77 procedure tlazaruseventcore.exitmessageloop;\r
  78 begin\r
  79    Application.Terminate;\r
  80 end;\r
  81 procedure tlazaruseventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
  82 begin\r
  83   fdreverse[fd] := reverseto;\r
  84 \r
  85 end;\r
  86 procedure addfdflags(fd : integer;flags:byte);\r
  87 begin\r
  88    fdflags[fd]:=fdflags[fd] or flags;\r
  89    if fdEventHandlers[fd]=nil then  begin\r
  90       fdEventHandlers[fd]:=AddEventHandler(fd,flags,tlazaruseventcore(eventcore).WaitHandleEvent,fd);\r
  91    end else begin\r
  92 \r
  93       SetEventHandlerFlags(fdEventHandlers[fd], fdflags[fd]);\r
  94    end;\r
  95 end;\r
  96 \r
  97 procedure removefdflags(fd : integer;flags:byte);\r
  98 begin\r
  99    if fdEventHandlers[fd]<>nil then  begin\r
 100       fdflags[fd]:=fdflags[fd] and (not flags);\r
 101       if fdflags[fd]=0 then begin\r
 102          RemoveEventHandler(fdEventHandlers[fd]);\r
 103          fdEventHandlers[fd]:=nil;\r
 104       end else begin\r
 105 \r
 106          SetEventHandlerFlags(fdEventHandlers[fd], fdflags[fd]);\r
 107       end;\r
 108    end;\r
 109 end;\r
 110 \r
 111 procedure tlazaruseventcore.rmasterset(fd : integer;islistensocket : boolean);\r
 112 begin\r
 113    addfdflags(fd,G_IO_IN);\r
 114 end;\r
 115 procedure tlazaruseventcore.rmasterclr(fd: integer);\r
 116 begin\r
 117    removefdflags(fd,G_IO_IN);\r
 118 end;\r
 119 procedure tlazaruseventcore.wmasterset(fd : integer);\r
 120 begin\r
 121    addfdflags(fd,G_IO_OUT);\r
 122 \r
 123 end;\r
 124 procedure tlazaruseventcore.wmasterclr(fd: integer);\r
 125 begin\r
 126    removefdflags(fd,G_IO_OUT);\r
 127 end;\r
 128 \r
 129 procedure lazaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 130 begin\r
 131   if not tasksoutstanding then  Application.QueueAsyncCall(tlazaruseventcore(eventcore).taskcb,0);\r
 132   tasksoutstanding := true;\r
 133 end;\r
 134 \r
 135 function tlaztimerwrapperinterface.createwrappedtimer : tobject;\r
 136 begin\r
 137   result := ttimer.create(nil);\r
 138 end;\r
 139 procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
 140 begin\r
 141   ttimer(wrappedtimer).ontimer := newvalue;\r
 142 end;\r
 143 procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
 144 begin\r
 145   ttimer(wrappedtimer).enabled := newvalue;\r
 146 end;\r
 147 \r
 148 \r
 149 procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
 150 begin\r
 151   ttimer(wrappedtimer).interval := newvalue;\r
 152 end;\r
 153 var\r
 154   inited:boolean;\r
 155 procedure lcoreinit;\r
 156 begin\r
 157   if (inited) then exit;\r
 158   eventcore := tlazaruseventcore.create;\r
 159   onaddtask := lazaddtask;\r
 160 \r
 161   absolutemaxs := absolutemaxs_select;\r
 162   inited := true;\r
 163 end;\r
 164 \r
 165 end.\r
 166 \r