1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-12-23 07:48:50 -05:00
Simba/Projects/SAMufasaGUI/psextension.pas

272 lines
7.9 KiB
ObjectPascal

unit psextension;
{$mode objfpc}
interface
uses
Classes, SysUtils,mufasabase, virtualextension,
uPSComponent,uPSCompiler, uPSRuntime, uPSPreProcessor,forms;
type
{ TSimbaPSExtension }
TSimbaPSExtension = class(TVirtualSimbaExtension)
public
constructor Create(FileStr: String; StartDisabled : boolean = false);
destructor Destroy; override;
private
PSInstance: TPSScript;
FWorking: Boolean;
Script: TStringList;
procedure StartExtension;
private
function FreeScript: boolean;
function InitScript: Boolean;
procedure OutputMessages;
procedure SIRegister_Settings(Cl: TPSPascalCompiler);
procedure RIRegister_Settings(Cl: TPSRuntimeClassImporter);
public
function HookExists(HookName: String): Boolean;override;
function ExecuteHook(HookName: String; fArgs: Array of Variant; out OutVariant : Variant): Integer;override;
property Working : boolean read FWorking;
protected
procedure RegisterPSCComponents(Sender: TObject; x: TPSPascalCompiler);
procedure RegisterPSRComponents(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
procedure RegisterMyMethods(Sender: TPSScript);
procedure OnPSExecute(Sender: TPSScript);
procedure SetEnabled(bool : boolean);override;
end;
implementation
uses
uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms,
uPSC_extctrls,uPSC_menus, //Compile libs
uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms,
uPSR_extctrls,uPSR_menus, //Runtime-libs
testunit,updateform,settingssandbox//Writeln
;
function TSimbaPSExtension.HookExists(HookName: String): Boolean;
begin
Result := False;
if FWorking then
if PSInstance.Exec.GetProc(HookName) <> InvalidVal then
result := True;
end;
function TSimbaPSExtension.ExecuteHook(HookName: String; fArgs: Array of Variant; out OutVariant : Variant): Integer;
begin
result := SExt_error;
if not FWorking then
exit;
try
outvariant := PSInstance.ExecuteFunction(fArgs, HookName);
result := SExt_ok;
except
on e : exception do
formWritelnEx(format('Error in Simba extension (%s): %s',[Self.GetName,e.message]));
end;
end;
constructor TSimbaPSExtension.Create(FileStr: String; StartDisabled: boolean = false);
begin
inherited create;
FWorking := False;
FileName := FileStr;
try
Script := TStringList.Create;
Script.LoadFromFile(FileName);
except
raise Exception.CreateFmt('File %s could not be read', [FileName]);
end;
FEnabled := false;
PSInstance := nil;
if not StartDisabled then
StartExtension;
end;
function TSimbaPSExtension.InitScript: Boolean;
begin
if not HookExists('init') then
exit(false);
result := true;
try
PSInstance.ExecuteFunction([], 'init');
except
result := false;
end;
end;
function TSimbaPSExtension.FreeScript: boolean;
var
bla : variant;
begin
if not HookExists('Free') then
exit(false);
result := ExecuteHook('Free',[],bla) = SExt_ok;
end;
{$I ../../Units/MMLAddon/PSInc/Wrappers/extensions.inc}
procedure TSimbaPSExtension.RegisterMyMethods(Sender: TPSScript);
begin
Sender.AddFunction(@formWritelnEx,'procedure Writeln(s : string)');
Sender.AddFunction(@ext_GetPage,'function GetPage(url : string) : string');
Sender.AddRegisteredPTRVariable('Settings','TMMLSettingsSandbox');
Sender.AddRegisteredVariable('Simba','TForm');
Sender.AddRegisteredVariable('Simba_MainMenu','TMainMenu');
end;
procedure TSimbaPSExtension.OnPSExecute(Sender: TPSScript);
begin
Sender.SetVarToInstance('simba',Form1);
Sender.SetVarToInstance('Simba_MainMenu',Form1.MainMenu);
Sender.SetPointerToData('Settings',@Self.Settings,Sender.FindNamedType('TMMLSettingsSandbox'));
end;
procedure TSimbaPSExtension.SetEnabled(bool: boolean);
var
temp : variant;
begin
if bool <> FEnabled then
begin
if bool then
begin;
if not assigned(PSInstance) then //We enable it for the first time, calls SetEnabled.
StartExtension
else
begin
if not FWorking then
Exit;
if hookexists('attach') then
ExecuteHook('attach',[],temp);
end;
end else
if HookExists('detach') then
ExecuteHook('detach',[],temp);
end;
inherited SetEnabled(bool);
end;
procedure TSimbaPSExtension.SIRegister_Settings(Cl: TPSPascalCompiler);
begin
with cl.AddClassN(nil,'TMMLSettingsSandbox') do
begin;
RegisterMethod('function IsKey(KeyName: String): Boolean;');
RegisterMethod('function IsDirectory(KeyName: String): Boolean;');
RegisterMethod('function SetKeyValue(Keyname : string; Value : string) : boolean;');
RegisterMethod('function GetKeyValue(KeyName: String): String;');
RegisterMethod('function GetKeyValueDef(KeyName, defVal: String): String;');
RegisterMethod('function ListKeys(KeyName: String): TStringArray;');
RegisterMethod('function DeleteKey(KeyName: String): Boolean;');
RegisterMethod('function DeleteSubKeys(KeyName: String): Boolean;');
RegisterProperty('Prefix','String',iptR);
end;
end;
procedure SettingsPrefix(self : TMMLSettingsSandbox; var Prefix : String);
begin; Prefix := self.Prefix; end;
procedure TSimbaPSExtension.RIRegister_Settings(Cl: TPSRuntimeClassImporter);
begin
with cl.Add(TMMLSettingsSandbox) do
begin
RegisterMethod(@TMMLSettingsSandbox.IsKey,'ISKEY');
RegisterMethod(@TMMLSettingsSandbox.IsDirectory,'ISDIRECTORY');
RegisterMethod(@TMMLSettingsSandbox.SetKeyValue,'SETKEYVALUE');
RegisterMethod(@TMMLSettingsSandbox.GetKeyValue,'GETKEYVALUE');
RegisterMethod(@TMMLSettingsSandbox.GetKeyValueDef,'GETKEYVALUEDEF');
RegisterMethod(@TMMLSettingsSandbox.ListKeys,'LISTKEYS');
RegisterMethod(@TMMLSettingsSandbox.DeleteKey,'DELETEKEY');
RegisterMethod(@TMMLSettingsSandbox.DeleteSubKeys,'DELETESUBKEYS');
RegisterPropertyHelper(@SettingsPrefix,nil,'Prefix');
end;
end;
procedure TSimbaPSExtension.RegisterPSCComponents(Sender: TObject; x: TPSPascalCompiler);
begin
SIRegister_Std(x);
SIRegister_Classes(x, True);
SIRegister_Controls(x);
SIRegister_Graphics(x, True);
SIRegister_stdctrls(x);
SIRegister_Forms(x);
SIRegister_ExtCtrls(x);
SIRegister_Menus(x);
SIRegister_Settings(x);
end;
procedure TSimbaPSExtension.RegisterPSRComponents(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
begin
RIRegister_Std(x);
RIRegister_Classes(x, True);
RIRegister_Controls(x);
RIRegister_Graphics(x, True);
RIRegister_stdctrls(x);
RIRegister_Forms(x);
RIRegister_ExtCtrls(x);
RIRegister_Menus(x);
RIRegister_Settings(x);
end;
destructor TSimbaPSExtension.Destroy;
begin
FreeScript;
if Assigned(PSInstance) then
FreeAndNil(PSInstance);
inherited;
end;
procedure TSimbaPSExtension.StartExtension;
begin
if assigned(PSInstance) then
exit;//Already started..
{ Create script, and see if the extension is valid. (If it compiles) }
PSInstance := TPSScript.Create(nil);
PSInstance.Script := Self.Script;
PSInstance.OnCompImport:=@RegisterPSCComponents;
PSInstance.OnExecImport:=@RegisterPSRComponents;
PSInstance.OnCompile:=@RegisterMyMethods;
PSInstance.OnExecute:=@OnPSExecute;
formWritelnEx(Format('Loading extension %s', [FileName]));
try
FWorking := PSInstance.Compile;
except
on e : exception do
FormWritelnEx(format('Error in Simba extension (%s) : %s',[FileName,e.message]));
end;
if FWorking then
formWritelnEx('Extension Enabled')
else
begin
formWritelnEx('Extension Disabled - Did not compile');
OutputMessages;
end;
if InitScript then
mDebugLn('Init procedure succesfully called')
else
mDebugLn('Init procedure didn''t execute right, or couldn''t be found');
Enabled:= FWorking;
end;
procedure TSimbaPSExtension.OutputMessages;
var
l: Longint;
begin
for l := 0 to PSInstance.CompilerMessageCount - 1 do
formWritelnEx(PSInstance.CompilerErrorToStr(l) + ' at line ' + inttostr(PSInstance.CompilerMessages[l].Row));
end;
end.