paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-23 17:29:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

Ami-Extra: some more MUI Helper for custom classes and hooks

Browse Source 
git-svn-id: trunk@35167 -
This commit is contained in:
marcus 2016-12-18 19:35:59 +00:00
parent b08297a667
commit 29abfe9dd3
2 changed files with 106 additions and 1 deletions
packages/ami-extra
examples
muihelloworld.pas
src
muihelper.pas

3
packages/ami-extra/examples/muihelloworld.pas
View File

@ -3,6 +3,9 @@ program muihelloworld;
// Example Source for MUIHelper, Simple Window and Button
uses
{$if defined(MorphOS) or defined(Amiga)}
amigalib,
{$endif}
Exec, Utility, intuition, AmigaDos, mui, muihelper;
procedure StartMe;

104
packages/ami-extra/src/muihelper.pas
View File

@ -23,8 +23,15 @@ unit muihelper;
interface
uses intuition, mui, amigados, utility;
uses
{$if defined(MorphOS) or defined(Amiga)}
amigalib,
{$endif}
exec, intuition, mui, amigados, utility;
type
THookFunc = function(Hook: PHook; Obj: PObject_; Msg: Pointer): LongInt;
TDispatcherFunc = function(Hook: PIClass; Obj: PObject_; Msg: Intuition.PMsg): LongWord;
const
MUI_TRUE = 1;
@ -307,8 +314,88 @@ procedure MH_SetString(Obj: PObject_; s: PChar);
procedure MH_SetCheckmark(Obj: PObject_; b: Boolean);
procedure MH_SetSlider(Obj: PObject_; l: LongInt);
function MH_NewObject(ClassPtr: PIClass; ClassID: PChar; const Tags: array of PtrUInt): APTR;
function MH_NewObject(var Obj; ClassPtr: PIClass; ClassID: PChar; const Tags: array of PtrUInt): APTR;
// Connect a Hook to a hook function, platform specific implementation
procedure MH_SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
function MH_CreateCustomClass(Base: PLibrary; Supername: PChar; Supermcc: PMUI_CustomClass; DataSize: LongInt; Dispatcher: TDispatcherFunc): PMUI_CustomClass;
implementation
{$undef SetHook}
{$ifdef CPU68}
{$define SetHook}
procedure MH_SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
begin
{$if defined(VER3_0)}
Hook.h_Entry := @HookEntry; { is defined in AmigaLib unit now }
{$else}
Hook.h_Entry := @HookEntryPas; { is defined in AmigaLib unit now }
{$endif}
Hook.h_SubEntry := Func;
Hook.h_Data := Data;
end;
{$endif}
{$if defined(CPU86) or defined(CPUARM) or defined(CPU64)}
{$define SetHook}
procedure HookEntry(h: PHook; obj: PObject_; Msg: Pointer); cdecl;
var
Proc: THookFunc;
begin
Proc := THookFunc(h^.h_SubEntry);
Proc(h, obj, msg);
end;
procedure MH_SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
begin
Hook.h_Entry := PtrUInt(@HookEntry);
Hook.h_SubEntry := PtrUInt(Func);
Hook.h_Data := Data;
end;
{$endif}
{$ifdef CPUPOWERPC}
{$ifdef MorphOS}
{$define SetHook}
procedure MH_SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
{ This is MorphOS magic. Basically, CallHookPkt is designed to enter 68k code
(remember, MorphOS is 68k AmigaOS binary compatible!) so this TRAP just
redirects that call back to native PPC code. HookEntry is defined in
AmigaLib unit }
const
HOOKENTRY_TRAP: TEmulLibEntry = ( Trap: TRAP_LIB; Extension: 0; Func: @HookEntry );
begin
Hook.h_Entry := @HOOKENTRY_TRAP;
Hook.h_SubEntry := Func;
Hook.h_Data := Data;
end;
{$endif}
{$ifdef AMIGAOS4}
{$define SetHook}
procedure MH_SetHook(var Hook: THook; Func: THookFunc; Data: Pointer);
begin
Hook.h_Entry := Func;
Hook.h_SubEntry := Func;
Hook.h_Data := Data;
end;
{$endif}
{$endif}
{$ifndef SetHook}
{$FATAL "SetHook not implemented for this platform"}
{$endif}
function MH_CreateCustomClass(Base: PLibrary; Supername: PChar; Supermcc: PMUI_CustomClass; DataSize: LongInt; Dispatcher: TDispatcherFunc): PMUI_CustomClass;
begin
MH_CreateCustomClass := MUI_CreateCustomClass(Base, Supername, Supermcc, DataSize, nil);
if Assigned(MH_CreateCustomClass) then
MH_SetHook(MH_CreateCustomClass^.mcc_Class^.cl_Dispatcher, THookFunc(Dispatcher), nil);
end;
function MAKE_ID(c1, c2, c3, c4: char): LongWord; inline;
begin
MAKE_ID := (LongWord(Ord(c1)) shl 24) or
@ -1500,4 +1587,19 @@ begin
MH_VBar := PObject_(VBar);
end;
// Creates a MUI object abstract
// ************************************************************************
function MH_NewObject(ClassPtr: PIClass; ClassID: PChar; const Tags: array of PtrUInt): APTR;
begin
MH_NewObject := NewObject(ClassPtr, ClassID, Tags);
end;
function MH_NewObject(var Obj; ClassPtr: PIClass; ClassID: PChar; const Tags: array of PtrUInt): APTR;
begin
PObject_(Obj) := NewObject(ClassPtr, ClassID, Tags);
MH_NewObject := PObject_(Obj);
end;
end.