1 {
2  *****************************************************************************
3  *                             MUIglobal.pas                                 *
4  *                              --------------                               *
5  *     Global functions for easier implementation of different Systems       *
6  *                                                                           *
7  *****************************************************************************
8 
9  *****************************************************************************
10   This file is part of the Lazarus Component Library (LCL)
11 
12   See the file COPYING.modifiedLGPL.txt, included in this distribution,
13   for details about the license.
14  *****************************************************************************
15 }
16 unit MUIglobal;
17 
18 {$mode objfpc}{$H+}
19 {$if defined(AROS) and defined(VER3_0)}
20   {$define FPC4AROS_VER3_FIXES}
21 {$endif}
22 interface
23 
24 uses
25   Classes, SysUtils, exec, amigados, intuition, agraphics, timer,
26 {$if defined(CPU68) or defined(CPUPOWERPC)}
27   {$if defined(AMIGA68k) or defined(MorphOS)}
28   amigalib,
29   {$endif}
30 {$endif}
31   utility, mui, tagsparamshelper;
32 
33 {$ifdef MorphOS}
34 // Missing in the fpc units
35 const
36   RPTAG_PenMode    = $80000080;
37   RPTAG_FgColor    = $80000081;
38   RPTAG_BgColor    = $80000082;
39 {$endif}
40 {$ifdef AmigaOS4}
41 // Colorsetting tags are different to AROS/MorphOS
42 const
43   RPTAG_FGCOLOR = RPTAG_APENCOLOR;
44   RPTAG_BGCOLOR = RPTAG_BPENCOLOR;
45   RPTAG_PENMODE = TAG_IGNORE;
46 {$endif}
47 {$if defined(Amiga68k) and (FPC_FULLVERSION<30101)}
48 const
49   IECODE_MBUTTON   = $6A;
50   IECODE_UP_PREFIX = $80;
51   MIDDLEUP         = IECODE_MBUTTON + IECODE_UP_PREFIX;
52   MIDDLEDOWN       = IECODE_MBUTTON;
53 {$endif}
54 
55 
56 type
ooknull57   THookFunc = function(Hook: PHook; Obj: PObject_; Msg: Pointer): LongInt;
58 
GetLCLTimenull59 function GetLCLTime: Int64;
60 
61 procedure ConnectHookFunction(MUIField: PtrUInt; TriggerValue: PtrUInt; Obj: PObject_; Data: TObject; Hook: PHook; HookFunc: THookFunc);
62 procedure SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
63 {$ifndef AROS}
CallHooknull64 function CallHook(h: PHook; obj: APTR; params: array of NativeUInt): LongWord;
65 {$endif}
CreateRastPortAnull66 function CreateRastPortA: PRastPort; inline;
CloneRastPortAnull67 function CloneRastPortA(Rp: PRastPort): PRastPort; inline;
68 procedure FreeRastPortA(Rp: PRastPort); inline;
69 
70 {$ifdef FPC4AROS_VER3_FIXES}
DoMethodnull71 function DoMethod(Obj: PObject_; const Args: array of PtrUInt): IPTR;
GetAttrnull72 function GetAttr(AttrID: LongWord; Object_: PObject_; var Storage: IPTR): LongWord; overload syscall IntuitionBase 109;
73 {$endif}
74 {$ifdef MorphOS}
DoMethodAnull75 function DoMethodA(obj : pObject_; msg1 : Pointer): longword; overload;
76 {$endif}
77 
78 {$ifdef Amiga68k}
79 var
80   IntuitionBase: PIntuitionBase;
81 {$endif}
82 {$ifdef Amiga}
DoMethodAnull83 function DoMethodA(obj : pObject_; msg : APTR): ulong;
DoMethodnull84 function DoMethod(obj: Pointer; params: array of DWord): LongWord; overload;
DoMethodnull85 function DoMethod(obj: LongWord; params: array of DWord): LongWord; overload;
86 {$endif}
87 
88 implementation
89 
90 // *****************************************************
91 // Use local GetMsCount with fixed timer.device, faster
92 // because it's polled very often (CheckTimer)
93 // But its not threadsafe!
94 // can be removed if a threadvar version is implemented in RTL
95 var
96   Tr: PTimeRequest = nil;
97 
98 procedure NewList (list: pList);
99 begin
100   with list^ do
101   begin
102     lh_Head := PNode(@lh_Tail);
103     lh_Tail := nil;
104     lh_TailPred := PNode(@lh_Head)
105   end;
106 end;
107 
108 function CreateExtIO(Port: PMsgPort; Size: LongInt): PIORequest;
109 begin
110   Result := nil;
111   if Port <> nil then
112   begin
113     {$if FPC_FULLVERSION<30101}
114     Result := Exec.AllocMem(Size, MEMF_CLEAR);
115     {$else}
116     Result := ExecAllocMem(Size, MEMF_CLEAR);
117     {$endif}
118     if Result <> nil then
119     begin
120       Result^.io_Message.mn_Node.ln_Type := 7;
121       Result^.io_Message.mn_Length := Size;
122       Result^.io_Message.mn_ReplyPort := Port;
123     end;
124   end;
125 end;
126 
127 procedure DeleteExtIO (IoReq: PIORequest);
128 begin
129   if IoReq <> nil then
130   begin
131     IoReq^.io_Message.mn_Node.ln_Type := $FF;
132     IoReq^.io_Message.mn_ReplyPort := PMsgPort(-1);
133     IoReq^.io_Device := PDevice(-1);
134     ExecFreeMem(IoReq, IoReq^.io_Message.mn_Length);
135   end
136 end;
137 
138 function Createport(Name: PChar; Pri: LongInt): PMsgPort;
139 var
140   sigbit: ShortInt;
141 begin
142   Result := nil;
143   SigBit := AllocSignal(-1);
144   if SigBit = -1 then
145    Exit;
146   {$if FPC_FULLVERSION<30101}
147   Result := Exec.AllocMem(SizeOf(TMsgPort), MEMF_CLEAR);
148   {$else}
149   Result := ExecAllocMem(SizeOf(TMsgPort), MEMF_CLEAR);
150   {$endif}
151   if Result = nil then
152   begin
153     FreeSignal(SigBit);
154     Exit;
155   end;
156   with Result^ do
157   begin
158     if Assigned(Name) then
159       mp_Node.ln_Name := Name
160     else
161       mp_Node.ln_Name := nil;
162     mp_Node.ln_Pri := Pri;
163     mp_Node.ln_Type := 4;
164     mp_Flags := 0;
165     mp_SigBit := SigBit;
166     mp_SigTask := FindTask(nil);
167   end;
168   if Assigned(Name) then
169     AddPort(Result)
170   else
171     NewList(Addr(Result^.mp_MsgList));
172 end;
173 
174 procedure DeletePort(Port: PMsgPort);
175 begin
176   if Port <> nil then
177   begin
178     if Port^.mp_Node.ln_Name <> nil then
179       RemPort(Port);
180     port^.mp_Node.ln_Type := $FF;
181     port^.mp_MsgList.lh_Head := PNode(-1);
182     FreeSignal(Port^.mp_SigBit);
183     ExecFreeMem(Port, SizeOf(TMsgPort));
184   end;
185 end;
186 
187 function Create_Timer(TheUnit: LongInt): PTimeRequest;
188 var
189   TimerPort: PMsgPort;
190 begin
191   Result := nil;
192   TimerPort := CreatePort(nil, 0);
193   if TimerPort = nil then
194     Exit;
195   Result := PTimeRequest(CreateExtIO(TimerPort, SizeOf(TTimeRequest)));
196   if Result = Nil then
197   begin
198     DeletePort(TimerPort);
199     Exit;
200   end;
201   if OpenDevice(TIMERNAME, TheUnit, PIORequest(Result), 0) <> 0 then
202   begin
203     DeleteExtIO(pIORequest(Result));
204     DeletePort(TimerPort);
205     Result := nil;
206   end;
207 end;
208 
209 Procedure Delete_Timer(WhichTimer: PTimeRequest);
210 var
211   WhichPort: PMsgPort;
212 begin
213   WhichPort := WhichTimer^.tr_Node.io_Message.mn_ReplyPort;
214   if assigned(WhichTimer) then
215   begin
216     CloseDevice(PIORequest(WhichTimer));
217     DeleteExtIO(PIORequest(WhichTimer));
218   end;
219   if Assigned(WhichPort) then
220     DeletePort(WhichPort);
221 end;
222 
223 function get_sys_time(tv: PTimeVal): LongInt;
224 begin
225   Result := -1;
226   if not Assigned(Tr) then
227     Tr := Create_Timer(UNIT_MICROHZ);
228   // non zero return says error
229   if tr = nil then
230     Exit;
231   tr^.tr_node.io_Command := TR_GETSYSTIME;
232   DoIO(PIORequest(tr));
233   // structure assignment
234   tv^ := tr^.tr_time;
235   Result := 0;
236 end;
237 
238 function GetLCLTime: Int64;
239 var
240   TV: TTimeVal;
241 begin
242   Get_Sys_Time(@TV);
243   Result := Int64(TV.TV_Secs) * 1000 + TV.TV_Micro div 1000;
244 end;
245 // End of LCLs own GetMsCount
246 //**************************************
247 
248 {$ifdef MorphOS}
249 function DoMethodA(obj : pObject_; msg1 : Pointer): longword;
250 begin
251   Result := Amigalib.DoMethodA(LongWord(Obj), Msg1);
252 end;
253 {$endif}
254 
255 {$undef SetHook}
256 
257 {$ifdef CPU68}
258 {$define SetHook}
259 procedure SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
260 begin
261   {$if defined(VER3_0)}
262   Hook.h_Entry := @HookEntry; { is defined in AmigaLib unit now }
263   {$else}
264   Hook.h_Entry := @HookEntryPas; { is defined in AmigaLib unit now }
265   {$endif}
266   Hook.h_SubEntry := Func;
267   Hook.h_Data := Data;
268 end;
269 {$endif}
270 
271 {$if defined(CPU86) or defined(CPUARM) or defined(CPU64)}
272 {$define SetHook}
273 procedure HookEntry(h: PHook; obj: PObject_; Msg: Pointer); cdecl;
274 var
275   Proc: THookFunc;
276 begin
277   Proc := THookFunc(h^.h_SubEntry);
278   Proc(h, obj, msg);
279 end;
280 
281 procedure SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
282 begin
283   Hook.h_Entry := IPTR(@HookEntry);
284   Hook.h_SubEntry := IPTR(Func);
285   Hook.h_Data := Data;
286 end;
287 {$endif}
288 
289 {$ifdef CPUPOWERPC}
290 {$ifdef MorphOS}
291 {$define SetHook}
292 procedure SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
293 { This is MorphOS magic. Basically, CallHookPkt is designed to enter 68k code
294   (remember, MorphOS is 68k AmigaOS binary compatible!) so this TRAP just
295   redirects that call back to native PPC code. HookEntry is defined in
296   AmigaLib unit }
297 const
298   HOOKENTRY_TRAP: TEmulLibEntry = ( Trap: TRAP_LIB; Extension: 0; Func: @HookEntry );
299 begin
300   Hook.h_Entry := @HOOKENTRY_TRAP;
301   Hook.h_SubEntry := Func;
302   Hook.h_Data := Data;
303 end;
304 {$endif}
305 {$ifdef AMIGAOS4}
306 {$define SetHook}
307 procedure SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
308 begin
309   Hook.h_Entry := Func;
310   Hook.h_SubEntry := Func;
311   Hook.h_Data := Data;
312 end;
313 {$endif}
314 {$endif}
315 
316 {$ifndef SetHook}
317 {$FATAL "SetHook not implemented for this platform"}
318 {$endif}
319 
320 procedure ConnectHookFunction(MUIField: PtrUInt; TriggerValue: PtrUInt; Obj: PObject_; Data: TObject; Hook: PHook; HookFunc: THookFunc);
321 var
322   Para: TAParamList;
323 begin
324   SetHook(Hook^, HookFunc, Data);
325 
326   Para.SetParams([
327     MUIM_Notify, MUIField, TriggerValue, MUIV_Notify_Self,
328     2,
329     MUIM_CallHook, NativeUInt(Hook),
330     0]);
331   //
332   DoMethodA(Obj, Para);
333 end;
334 
335 function CallHook(h: PHook; obj: APTR; params: array of NativeUInt): LongWord;
336 begin
337   Result := CallHookPkt(h, obj, @Params[0]);
338 end;
339 
340 function CreateRastPortA: PRastPort;
341 begin
342   {$if (not defined(AROS)) or defined(CPU64)}
343   Result := System.AllocMem(SizeOf(TRastPort));
344   InitRastPort(Result);
345   {$else}
346   Result := CreateRastPort;
347   {$endif}
348 end;
349 
350 function CloneRastPortA(Rp: PRastPort): PRastPort;
351 begin
352   {$if (not defined(AROS)) or defined(CPU64)}
353   Result := System.AllocMem(SizeOf(TRastPort));
354   Move(Rp^, Result^, SizeOf(TRastPort));
355   {$else}
356   Result := CloneRastPort(Rp);
357   {$endif}
358 end;
359 
360 procedure FreeRastPortA(Rp: PRastPort);
361 begin
362   {$if (not defined(AROS)) or defined(CPU64)}
363   FreeMem(Rp);
364   {$else}
365   FreeRastPort(Rp);
366   {$endif}
367 end;
368 
369 {$ifdef FPC4AROS_VER3_FIXES}
370 function DoMethod(Obj: PObject_; const Args: array of PtrUInt): IPTR; inline;
371 begin
372   DoMethod := 0;
373   if obj = nil then
374     Exit;
375   DoMethod := CALLHOOKPKT_(PHook(OCLASS(Obj)), Obj, @Args);
376 end;
377 {$endif}
378 
379 {$ifdef Amiga}
380 
381 function DoMethodA(obj : pObject_; msg : APTR): ulong;
382 begin
383   if assigned(obj) then
384   begin
385     DoMethodA := CallHookPkt(@THook(OCLASS(obj)^.cl_Dispatcher), obj, msg);
386   end
387   else
388     DoMethodA := 0;
389 end;
390 
391 function DoMethod(obj: Pointer; params: array of DWord): LongWord;
392 begin
393   Result := DoMethodA(obj, @params);
394 end;
395 
396 function DoMethod(obj: LongWord; params: array of DWord): LongWord;
397 begin
398   Result := DoMethodA(Pointer(obj), @params);
399 end;
400 {$endif}
401 
402 initialization
403   if not Assigned(Tr) then
404     Tr := create_timer(UNIT_MICROHZ);
405 {$ifdef Amiga68k}
406   IntuitionBase := _IntuitionBase;
407 {$endif}
408 
409 finalization
410   if Assigned(Tr) then
411     Delete_timer(tr);
412 end.
413