+++ /dev/null
-{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
- For conditions of distribution and use, see copyright notice in zlib_license.txt\r
- which is included in the package\r
- ----------------------------------------------------------------------------- }\r
-\r
-unit wcore;\r
-\r
-{\r
-lcore compatible interface for windows\r
-\r
-- messageloop\r
-\r
-- tltimer\r
-\r
-}\r
-//note: events after release are normal and are the apps responsibility to deal with safely\r
-interface\r
-\r
- uses\r
- classes,windows,mmsystem;\r
-\r
- type\r
- float=double;\r
-\r
- tlcomponent = class(tcomponent)\r
- public\r
- released:boolean;\r
- procedure release;\r
- destructor destroy; override;\r
- end;\r
-\r
- tltimer=class(tlcomponent)\r
- public\r
- ontimer:tnotifyevent;\r
- initialevent:boolean;\r
- initialdone:boolean;\r
- prevtimer:tltimer;\r
- nexttimer:tltimer;\r
- interval:integer; {miliseconds, default 1000}\r
- enabled:boolean;\r
- nextts:integer;\r
- constructor create(aowner:tcomponent);override;\r
- destructor destroy;override;\r
- end;\r
-\r
- ttaskevent=procedure(wparam,lparam:longint) of object;\r
-\r
- tltask=class(tobject)\r
- public\r
- handler : ttaskevent;\r
- obj : tobject;\r
- wparam : longint;\r
- lparam : longint;\r
- nexttask : tltask;\r
- constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
- end;\r
-\r
-procedure messageloop;\r
-procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
-procedure disconnecttasks(aobj:tobject);\r
-procedure exitmessageloop;\r
-procedure processmessages;\r
-\r
-var\r
- onshutdown:procedure(s:string);\r
-\r
-implementation\r
-\r
-uses\r
- {$ifdef fpc}\r
- bmessages;\r
- {$else}\r
- messages;\r
- {$endif}\r
-\r
-\r
-const\r
- WINMSG_TASK=WM_USER;\r
-\r
-var\r
- hwndwcore:hwnd;\r
- firsttimer:tltimer;\r
- timesubstract:integer;\r
- firsttask,lasttask,currenttask:tltask;\r
-\r
-procedure tlcomponent.release;\r
-begin\r
- released := true;\r
-end;\r
-\r
-destructor tlcomponent.destroy;\r
-begin\r
- disconnecttasks(self);\r
- inherited destroy;\r
-end;\r
-\r
-{------------------------------------------------------------------------------}\r
-\r
-constructor tltimer.create;\r
-begin\r
- inherited create(AOwner);\r
- nexttimer := firsttimer;\r
- prevtimer := nil;\r
-\r
- if assigned(nexttimer) then nexttimer.prevtimer := self;\r
- firsttimer := self;\r
-\r
- interval := 1000;\r
- enabled := true;\r
- released := false;\r
-end;\r
-\r
-destructor tltimer.destroy;\r
-begin\r
- if prevtimer <> nil then begin\r
- prevtimer.nexttimer := nexttimer;\r
- end else begin\r
- firsttimer := nexttimer;\r
- end;\r
- if nexttimer <> nil then begin\r
- nexttimer.prevtimer := prevtimer;\r
- end;\r
- inherited destroy;\r
-end;\r
-\r
-{------------------------------------------------------------------------------}\r
-\r
-function wcore_timehandler:integer;\r
-const\r
- rollover_bits=30;\r
-var\r
- tv,tvnow:integer;\r
- currenttimer,temptimer:tltimer;\r
-begin\r
- if not assigned(firsttimer) then begin\r
- result := 1000;\r
- exit;\r
- end;\r
-\r
- tvnow := timegettime;\r
- if (tvnow and ((-1) shl rollover_bits)) <> timesubstract then begin\r
- currenttimer := firsttimer;\r
- while assigned(currenttimer) do begin\r
- dec(currenttimer.nextts,(1 shl rollover_bits));\r
- currenttimer := currenttimer.nexttimer;\r
- end;\r
- timesubstract := tvnow and ((-1) shl rollover_bits);\r
- end;\r
- tvnow := tvnow and ((1 shl rollover_bits)-1);\r
-\r
- currenttimer := firsttimer;\r
- while assigned(currenttimer) do begin\r
- if tvnow >= currenttimer.nextts then begin\r
- if assigned(currenttimer.ontimer) then begin\r
- if currenttimer.enabled then begin\r
- if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
- currenttimer.initialdone := true;\r
- end;\r
- end;\r
- currenttimer.nextts := tvnow+currenttimer.interval;\r
- end;\r
- temptimer := currenttimer;\r
- currenttimer := currenttimer.nexttimer;\r
- if temptimer.released then temptimer.free;\r
- end;\r
-\r
- tv := maxlongint;\r
- currenttimer := firsttimer;\r
- while assigned(currenttimer) do begin\r
- if currenttimer.nextts < tv then tv := currenttimer.nextts;\r
- currenttimer := currenttimer.nexttimer;\r
- end;\r
- result := tv-tvnow;\r
- if result < 15 then result := 15;\r
-end;\r
-\r
-{------------------------------------------------------------------------------}\r
-\r
-constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
-begin\r
- inherited create;\r
- handler := ahandler;\r
- obj := aobj;\r
- wparam := awparam;\r
- lparam := alparam;\r
- {nexttask := firsttask;\r
- firsttask := self;}\r
- if assigned(lasttask) then begin\r
- lasttask.nexttask := self;\r
- end else begin\r
- firsttask := self;\r
- postmessage(hwndwcore,WINMSG_TASK,0,0);\r
- end;\r
- lasttask := self;\r
- //ahandler(wparam,lparam);\r
-end;\r
-\r
-procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
-begin\r
- tltask.create(ahandler,aobj,awparam,alparam);\r
-end;\r
-\r
-procedure disconnecttasks(aobj:tobject);\r
-var\r
- currenttasklocal : tltask ;\r
- counter : byte ;\r
-begin\r
- for counter := 0 to 1 do begin\r
- if counter = 0 then begin\r
- currenttasklocal := firsttask; //main list of tasks\r
- end else begin\r
- currenttasklocal := currenttask; //needed in case called from a task\r
- end;\r
- // note i don't bother to sestroy the links here as that will happen when\r
- // the list of tasks is processed anyway\r
- while assigned(currenttasklocal) do begin\r
- if currenttasklocal.obj = aobj then begin\r
- currenttasklocal.obj := nil;\r
- currenttasklocal.handler := nil;\r
- end;\r
- currenttasklocal := currenttasklocal.nexttask;\r
- end;\r
- end;\r
-end;\r
-\r
-procedure dotasks;\r
-var\r
- temptask:tltask;\r
-begin\r
- if firsttask = nil then exit;\r
-\r
- currenttask := firsttask;\r
- firsttask := nil;\r
- lasttask := nil;\r
- while assigned(currenttask) do begin\r
- if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
- temptask := currenttask;\r
- currenttask := currenttask.nexttask;\r
- temptask.free;\r
- end;\r
- currenttask := nil;\r
-end;\r
-\r
-{------------------------------------------------------------------------------}\r
-\r
-procedure exitmessageloop;\r
-begin\r
- postmessage(hwndwcore,WM_QUIT,0,0);\r
-end;\r
-\r
- {$ifdef threadtimer}\r
- 'thread timer'\r
- {$else}\r
-const timerid_wcore=$1000;\r
- {$endif}\r
-\r
-function MyWindowProc(\r
- ahWnd : HWND;\r
- auMsg : Integer;\r
- awParam : WPARAM;\r
- alParam : LPARAM): Integer; stdcall;\r
-var\r
- MsgRec : TMessage;\r
- a:integer;\r
-begin\r
- Result := 0; // This means we handled the message\r
-\r
- {MsgRec.hwnd := ahWnd;}\r
- MsgRec.wParam := awParam;\r
- MsgRec.lParam := alParam;\r
-\r
- dotasks;\r
- case auMsg of\r
- {$ifndef threadtimer}\r
- WM_TIMER: begin\r
- if msgrec.wparam = timerid_wcore then begin\r
- a := wcore_timehandler;\r
- killtimer(hwndwcore,timerid_wcore);\r
- settimer(hwndwcore,timerid_wcore,a,nil);\r
- end;\r
- end;\r
- {$endif}\r
-\r
- {WINMSG_TASK:dotasks;}\r
-\r
- WM_CLOSE: begin\r
- {}\r
- end;\r
- WM_DESTROY: begin\r
- {}\r
- end;\r
- else\r
- Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
- end;\r
-end;\r
-\r
-\r
-var\r
- MyWindowClass : TWndClass = (style : 0;\r
- lpfnWndProc : @MyWindowProc;\r
- cbClsExtra : 0;\r
- cbWndExtra : 0;\r
- hInstance : 0;\r
- hIcon : 0;\r
- hCursor : 0;\r
- hbrBackground : 0;\r
- lpszMenuName : nil;\r
- lpszClassName : 'wcoreClass');\r
-\r
-procedure messageloop;\r
-var\r
- MsgRec : TMsg;\r
-begin\r
-\r
- if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
- //writeln('about to create wcore handle, hinstance=',hinstance);\r
- hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
- MyWindowClass.lpszClassName,\r
- '', { Window name }\r
- WS_POPUP, { Window Style }\r
- 0, 0, { X, Y }\r
- 0, 0, { Width, Height }\r
- 0, { hWndParent }\r
- 0, { hMenu }\r
- HInstance, { hInstance }\r
- nil); { CreateParam }\r
-\r
- if hwndwcore = 0 then halt;\r
-\r
- {$ifdef threadtimer}\r
- 'thread timer'\r
- {$else}\r
- if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;\r
- {$endif}\r
-\r
-\r
- while GetMessage(MsgRec, 0, 0, 0) do begin\r
- TranslateMessage(MsgRec);\r
- DispatchMessage(MsgRec);\r
- {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}\r
- end;\r
-\r
- if hWndwcore <> 0 then begin\r
- DestroyWindow(hwndwcore);\r
- hWndwcore := 0;\r
- end;\r
-\r
- {$ifdef threadtimer}\r
- 'thread timer'\r
- {$else}\r
- killtimer(hwndwcore,timerid_wcore);\r
- {$endif}\r
-end;\r
-\r
-function ProcessMessage : Boolean;\r
-var\r
- Msg : TMsg;\r
-begin\r
- Result := FALSE;\r
- if PeekMessage(Msg, hwndwcore, 0, 0, PM_REMOVE) then begin\r
- Result := TRUE;\r
- DispatchMessage(Msg);\r
- end;\r
-end;\r
-\r
-procedure processmessages;\r
-begin\r
- while processmessage do;\r
-end;\r
-\r
-\r
-end.\r
lcore.org gitweb / lcore.git / blobdiff