mirror of
https://github.com/moparisthebest/Simba
synced 2024-12-23 07:48:50 -05:00
001a593789
Renamed all the setting methods..
272 lines
7.9 KiB
ObjectPascal
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.
|
|
|