lcore/trunk/wcore.pas

unit wcore;

{
lcore compatible interface for windows

- messageloop

- tltimer

}
//note: events after release are normal and are the apps responsibility to deal with safely
interface

  uses
    classes,windows,mmsystem;

  type
    float=double;

    tlcomponent = class(tcomponent)
    public
      released:boolean;
      procedure release;
      destructor destroy; override;
    end;

    tltimer=class(tlcomponent)
    private
      fenabled : boolean;
      procedure setenabled(newvalue : boolean);
    public
      ontimer:tnotifyevent;
      initialevent:boolean;
      initialdone:boolean;
      prevtimer:tltimer;
      nexttimer:tltimer;
      interval:integer;        {milliseconds, default 1000}
      nextts:integer;
      property enabled:boolean read fenabled write setenabled;
      constructor create(aowner:tcomponent);override;
      destructor destroy;override;
    end;

    ttaskevent=procedure(wparam,lparam:longint) of object;

    tltask=class(tobject)
    public
      handler  : ttaskevent;
      obj      : tobject;
      wparam   : longint;
      lparam   : longint;
      nexttask : tltask;
      constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
    end;

procedure messageloop;
procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
procedure disconnecttasks(aobj:tobject);
procedure exitmessageloop;
procedure processmessages;
procedure wcoreinit;

var
  onshutdown:procedure(s:ansistring);

implementation

uses
  {$ifdef fpc}
  bmessages;
  {$else}
  messages;
  {$endif}


const
  WINMSG_TASK=WM_USER;

var
  hwndwcore:hwnd;
  firsttimer:tltimer;
  timesubtract:integer;
  firsttask,lasttask,currenttask:tltask;

procedure tlcomponent.release;
begin
  released := true;
end;

destructor tlcomponent.destroy;
begin
  disconnecttasks(self);
  inherited destroy;
end;

{------------------------------------------------------------------------------}

procedure tltimer.setenabled(newvalue : boolean);
begin
  fenabled := newvalue;
  nextts := 0;
  initialdone := false;
end;

constructor tltimer.create;
begin
  inherited create(AOwner);
  nexttimer := firsttimer;
  prevtimer := nil;

  if assigned(nexttimer) then nexttimer.prevtimer := self;
  firsttimer := self;

  interval := 1000;
  enabled := true;
  released := false;
end;

destructor tltimer.destroy;
begin
  if prevtimer <> nil then begin
    prevtimer.nexttimer := nexttimer;
  end else begin
    firsttimer := nexttimer;
  end;
  if nexttimer <> nil then begin
    nexttimer.prevtimer := prevtimer;
  end;
  inherited destroy;
end;

{------------------------------------------------------------------------------}

function wcore_timehandler:integer;
const
  rollover_bits=30;
var
  tv,tvnow:integer;
  currenttimer,temptimer:tltimer;
begin
  if not assigned(firsttimer) then begin
    result := 1000;
    exit;
  end;

  tvnow := timegettime;
  if (tvnow and ((-1) shl rollover_bits)) <> timesubtract then begin
    currenttimer := firsttimer;
    while assigned(currenttimer) do begin
      dec(currenttimer.nextts,(1 shl rollover_bits));
      currenttimer := currenttimer.nexttimer;
    end;
    timesubtract := tvnow and ((-1) shl rollover_bits);
  end;
  tvnow := tvnow and ((1 shl rollover_bits)-1);

  currenttimer := firsttimer;
  while assigned(currenttimer) do begin
    if tvnow >= currenttimer.nextts then begin
      if assigned(currenttimer.ontimer) then begin
        if currenttimer.enabled then begin
          if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);
          currenttimer.initialdone := true;
        end;
      end;
      currenttimer.nextts := tvnow+currenttimer.interval;
    end;
    temptimer := currenttimer;
    currenttimer := currenttimer.nexttimer;
    if temptimer.released then temptimer.free;
  end;

  tv := maxlongint;
  currenttimer := firsttimer;
  while assigned(currenttimer) do begin
    if currenttimer.nextts < tv then tv := currenttimer.nextts;
    currenttimer := currenttimer.nexttimer;
  end;
  result := tv-tvnow;
  if result < 15 then result := 15;
end;

{------------------------------------------------------------------------------}

constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
begin
  inherited create;
  handler   := ahandler;
  obj       := aobj;
  wparam    := awparam;
  lparam    := alparam;
  {nexttask  := firsttask;
  firsttask := self;}
  if assigned(lasttask) then begin
    lasttask.nexttask := self;
  end else begin
    firsttask := self;
    postmessage(hwndwcore,WINMSG_TASK,0,0);
  end;
  lasttask := self;
  //ahandler(wparam,lparam);
end;

procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
begin
  tltask.create(ahandler,aobj,awparam,alparam);
end;

procedure disconnecttasks(aobj:tobject);
var
  currenttasklocal : tltask ;
  counter          : byte   ;
begin
  for counter := 0 to 1 do begin
    if counter = 0 then begin
      currenttasklocal := firsttask; //main list of tasks
    end else begin
      currenttasklocal := currenttask; //needed in case called from a task
    end;
    // note i don't bother to destroy the links here as that will happen when
    // the list of tasks is processed anyway
    while assigned(currenttasklocal) do begin
      if currenttasklocal.obj = aobj then begin
        currenttasklocal.obj := nil;
        currenttasklocal.handler := nil;
      end;
      currenttasklocal := currenttasklocal.nexttask;
    end;
  end;
end;

procedure dotasks;
var
  temptask:tltask;
begin
  if firsttask = nil then exit;

  currenttask := firsttask;
  firsttask := nil;
  lasttask  := nil;
  while assigned(currenttask) do begin
    if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);
    temptask := currenttask;
    currenttask := currenttask.nexttask;
    temptask.free;
  end;
  currenttask := nil;
end;

{------------------------------------------------------------------------------}

procedure exitmessageloop;
begin
  postmessage(hwndwcore,WM_QUIT,0,0);
end;

  {$ifdef threadtimer}
  'thread timer'
  {$else}
const timerid_wcore=$1000;
  {$endif}

function MyWindowProc(
    ahWnd   : HWND;
    auMsg   : Integer;
    awParam : WPARAM;
    alParam : LPARAM): Integer; stdcall;
var
    MsgRec : TMessage;
    a:integer;
begin
  Result := 0;  // This means we handled the message

  {MsgRec.hwnd    := ahWnd;}
  MsgRec.wParam  := awParam;
  MsgRec.lParam  := alParam;

  dotasks;
  case auMsg of
    {$ifndef threadtimer}
    WM_TIMER: begin
      if msgrec.wparam = timerid_wcore then begin
        a := wcore_timehandler;
        killtimer(hwndwcore,timerid_wcore);
        settimer(hwndwcore,timerid_wcore,a,nil);
      end;
    end;
    {$endif}

    {WINMSG_TASK:dotasks;}

    WM_CLOSE: begin
      {}
    end;
    WM_DESTROY: begin
      {}
    end;
  else
      Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
  end;
end;


var
  MyWindowClass : TWndClass = (style         : 0;
                                 lpfnWndProc   : @MyWindowProc;
                                 cbClsExtra    : 0;
                                 cbWndExtra    : 0;
                                 hInstance     : 0;
                                 hIcon         : 0;
                                 hCursor       : 0;
                                 hbrBackground : 0;
                                 lpszMenuName  : nil;
                                 lpszClassName : 'wcoreClass');

procedure wcoreinit;
begin
  if Windows.RegisterClass(MyWindowClass) = 0 then halt;
  //writeln('about to create wcore handle, hinstance=',hinstance);
  hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,
                               MyWindowClass.lpszClassName,
                               '',        { Window name   }
                               WS_POPUP,  { Window Style  }
                               0, 0,      { X, Y          }
                               0, 0,      { Width, Height }
                               0,         { hWndParent    }
                               0,         { hMenu         }
                               HInstance, { hInstance     }
                               nil);      { CreateParam   }

  if hwndwcore = 0 then halt;

  {$ifdef threadtimer}
  'thread timer'
  {$else}
  if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;
  {$endif}


end;

procedure messageloop;
var
  MsgRec : TMsg;

begin

  while GetMessage(MsgRec, 0, 0, 0) do begin
    TranslateMessage(MsgRec);
    DispatchMessage(MsgRec);
    {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}
  end;

  if hWndwcore <> 0 then begin
    DestroyWindow(hwndwcore);
    hWndwcore := 0;
  end;

  {$ifdef threadtimer}
  'thread timer'
  {$else}
  killtimer(hwndwcore,timerid_wcore);
  {$endif}
end;

function ProcessMessage : Boolean;
var
    MsgRec : TMsg;
begin
    Result := FALSE;
    if PeekMessage(MsgRec, 0, 0, 0, PM_REMOVE) then begin
      Result := TRUE;
      TranslateMessage(MsgRec);
      DispatchMessage(MsgRec);
    end;
end;

procedure processmessages;
begin
  while processmessage do;
end;


end.

1	unit wcore;
2
3	{
4	lcore compatible interface for windows
5
6	- messageloop
7
8	- tltimer
9
10	}
11	//note: events after release are normal and are the apps responsibility to deal with safely
12	interface
13
14	uses
15	classes,windows,mmsystem;
16
17	type
18	float=double;
19
20	tlcomponent = class(tcomponent)
21	public
22	released:boolean;
23	procedure release;
24	destructor destroy; override;
25	end;
26
27	tltimer=class(tlcomponent)
28	private
29	fenabled : boolean;
30	procedure setenabled(newvalue : boolean);
31	public
32	ontimer:tnotifyevent;
33	initialevent:boolean;
34	initialdone:boolean;
35	prevtimer:tltimer;
36	nexttimer:tltimer;
37	interval:integer; {milliseconds, default 1000}
38	nextts:integer;
39	property enabled:boolean read fenabled write setenabled;
40	constructor create(aowner:tcomponent);override;
41	destructor destroy;override;
42	end;
43
44	ttaskevent=procedure(wparam,lparam:longint) of object;
45
46	tltask=class(tobject)
47	public
48	handler : ttaskevent;
49	obj : tobject;
50	wparam : longint;
51	lparam : longint;
52	nexttask : tltask;
53	constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
54	end;
55
56	procedure messageloop;
57	procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
58	procedure disconnecttasks(aobj:tobject);
59	procedure exitmessageloop;
60	procedure processmessages;
61	procedure wcoreinit;
62
63	var
64	onshutdown:procedure(s:ansistring);
65
66	implementation
67
68	uses
69	{$ifdef fpc}
70	bmessages;
71	{$else}
72	messages;
73	{$endif}
74
75
76	const
77	WINMSG_TASK=WM_USER;
78
79	var
80	hwndwcore:hwnd;
81	firsttimer:tltimer;
82	timesubtract:integer;
83	firsttask,lasttask,currenttask:tltask;
84
85	procedure tlcomponent.release;
86	begin
87	released := true;
88	end;
89
90	destructor tlcomponent.destroy;
91	begin
92	disconnecttasks(self);
93	inherited destroy;
94	end;
95
96	{------------------------------------------------------------------------------}
97
98	procedure tltimer.setenabled(newvalue : boolean);
99	begin
100	fenabled := newvalue;
101	nextts := 0;
102	initialdone := false;
103	end;
104
105	constructor tltimer.create;
106	begin
107	inherited create(AOwner);
108	nexttimer := firsttimer;
109	prevtimer := nil;
110
111	if assigned(nexttimer) then nexttimer.prevtimer := self;
112	firsttimer := self;
113
114	interval := 1000;
115	enabled := true;
116	released := false;
117	end;
118
119	destructor tltimer.destroy;
120	begin
121	if prevtimer <> nil then begin
122	prevtimer.nexttimer := nexttimer;
123	end else begin
124	firsttimer := nexttimer;
125	end;
126	if nexttimer <> nil then begin
127	nexttimer.prevtimer := prevtimer;
128	end;
129	inherited destroy;
130	end;
131
132	{------------------------------------------------------------------------------}
133
134	function wcore_timehandler:integer;
135	const
136	rollover_bits=30;
137	var
138	tv,tvnow:integer;
139	currenttimer,temptimer:tltimer;
140	begin
141	if not assigned(firsttimer) then begin
142	result := 1000;
143	exit;
144	end;
145
146	tvnow := timegettime;
147	if (tvnow and ((-1) shl rollover_bits)) <> timesubtract then begin
148	currenttimer := firsttimer;
149	while assigned(currenttimer) do begin
150	dec(currenttimer.nextts,(1 shl rollover_bits));
151	currenttimer := currenttimer.nexttimer;
152	end;
153	timesubtract := tvnow and ((-1) shl rollover_bits);
154	end;
155	tvnow := tvnow and ((1 shl rollover_bits)-1);
156
157	currenttimer := firsttimer;
158	while assigned(currenttimer) do begin
159	if tvnow >= currenttimer.nextts then begin
160	if assigned(currenttimer.ontimer) then begin
161	if currenttimer.enabled then begin
162	if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);
163	currenttimer.initialdone := true;
164	end;
165	end;
166	currenttimer.nextts := tvnow+currenttimer.interval;
167	end;
168	temptimer := currenttimer;
169	currenttimer := currenttimer.nexttimer;
170	if temptimer.released then temptimer.free;
171	end;
172
173	tv := maxlongint;
174	currenttimer := firsttimer;
175	while assigned(currenttimer) do begin
176	if currenttimer.nextts < tv then tv := currenttimer.nextts;
177	currenttimer := currenttimer.nexttimer;
178	end;
179	result := tv-tvnow;
180	if result < 15 then result := 15;
181	end;
182
183	{------------------------------------------------------------------------------}
184
185	constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
186	begin
187	inherited create;
188	handler := ahandler;
189	obj := aobj;
190	wparam := awparam;
191	lparam := alparam;
192	{nexttask := firsttask;
193	firsttask := self;}
194	if assigned(lasttask) then begin
195	lasttask.nexttask := self;
196	end else begin
197	firsttask := self;
198	postmessage(hwndwcore,WINMSG_TASK,0,0);
199	end;
200	lasttask := self;
201	//ahandler(wparam,lparam);
202	end;
203
204	procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
205	begin
206	tltask.create(ahandler,aobj,awparam,alparam);
207	end;
208
209	procedure disconnecttasks(aobj:tobject);
210	var
211	currenttasklocal : tltask ;
212	counter : byte ;
213	begin
214	for counter := 0 to 1 do begin
215	if counter = 0 then begin
216	currenttasklocal := firsttask; //main list of tasks
217	end else begin
218	currenttasklocal := currenttask; //needed in case called from a task
219	end;
220	// note i don't bother to destroy the links here as that will happen when
221	// the list of tasks is processed anyway
222	while assigned(currenttasklocal) do begin
223	if currenttasklocal.obj = aobj then begin
224	currenttasklocal.obj := nil;
225	currenttasklocal.handler := nil;
226	end;
227	currenttasklocal := currenttasklocal.nexttask;
228	end;
229	end;
230	end;
231
232	procedure dotasks;
233	var
234	temptask:tltask;
235	begin
236	if firsttask = nil then exit;
237
238	currenttask := firsttask;
239	firsttask := nil;
240	lasttask := nil;
241	while assigned(currenttask) do begin
242	if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);
243	temptask := currenttask;
244	currenttask := currenttask.nexttask;
245	temptask.free;
246	end;
247	currenttask := nil;
248	end;
249
250	{------------------------------------------------------------------------------}
251
252	procedure exitmessageloop;
253	begin
254	postmessage(hwndwcore,WM_QUIT,0,0);
255	end;
256
257	{$ifdef threadtimer}
258	'thread timer'
259	{$else}
260	const timerid_wcore=$1000;
261	{$endif}
262
263	function MyWindowProc(
264	ahWnd : HWND;
265	auMsg : Integer;
266	awParam : WPARAM;
267	alParam : LPARAM): Integer; stdcall;
268	var
269	MsgRec : TMessage;
270	a:integer;
271	begin
272	Result := 0; // This means we handled the message
273
274	{MsgRec.hwnd := ahWnd;}
275	MsgRec.wParam := awParam;
276	MsgRec.lParam := alParam;
277
278	dotasks;
279	case auMsg of
280	{$ifndef threadtimer}
281	WM_TIMER: begin
282	if msgrec.wparam = timerid_wcore then begin
283	a := wcore_timehandler;
284	killtimer(hwndwcore,timerid_wcore);
285	settimer(hwndwcore,timerid_wcore,a,nil);
286	end;
287	end;
288	{$endif}
289
290	{WINMSG_TASK:dotasks;}
291
292	WM_CLOSE: begin
293	{}
294	end;
295	WM_DESTROY: begin
296	{}
297	end;
298	else
299	Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
300	end;
301	end;
302
303
304	var
305	MyWindowClass : TWndClass = (style : 0;
306	lpfnWndProc : @MyWindowProc;
307	cbClsExtra : 0;
308	cbWndExtra : 0;
309	hInstance : 0;
310	hIcon : 0;
311	hCursor : 0;
312	hbrBackground : 0;
313	lpszMenuName : nil;
314	lpszClassName : 'wcoreClass');
315
316	procedure wcoreinit;
317	begin
318	if Windows.RegisterClass(MyWindowClass) = 0 then halt;
319	//writeln('about to create wcore handle, hinstance=',hinstance);
320	hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,
321	MyWindowClass.lpszClassName,
322	'', { Window name }
323	WS_POPUP, { Window Style }
324	0, 0, { X, Y }
325	0, 0, { Width, Height }
326	0, { hWndParent }
327	0, { hMenu }
328	HInstance, { hInstance }
329	nil); { CreateParam }
330
331	if hwndwcore = 0 then halt;
332
333	{$ifdef threadtimer}
334	'thread timer'
335	{$else}
336	if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;
337	{$endif}
338
339
340	end;
341
342	procedure messageloop;
343	var
344	MsgRec : TMsg;
345
346	begin
347
348	while GetMessage(MsgRec, 0, 0, 0) do begin
349	TranslateMessage(MsgRec);
350	DispatchMessage(MsgRec);
351	{if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}
352	end;
353
354	if hWndwcore <> 0 then begin
355	DestroyWindow(hwndwcore);
356	hWndwcore := 0;
357	end;
358
359	{$ifdef threadtimer}
360	'thread timer'
361	{$else}
362	killtimer(hwndwcore,timerid_wcore);
363	{$endif}
364	end;
365
366	function ProcessMessage : Boolean;
367	var
368	MsgRec : TMsg;
369	begin
370	Result := FALSE;
371	if PeekMessage(MsgRec, 0, 0, 0, PM_REMOVE) then begin
372	Result := TRUE;
373	TranslateMessage(MsgRec);
374	DispatchMessage(MsgRec);
375	end;
376	end;
377
378	procedure processmessages;
379	begin
380	while processmessage do;
381	end;
382
383
384	end.
385
No admin address has been configured">No admin address has been configured	ViewVC Help
Powered by ViewVC 1.1.26