mirror of
https://github.com/moparisthebest/Simba
synced 2025-02-07 10:40:19 -05:00
376 lines
11 KiB
ObjectPascal
376 lines
11 KiB
ObjectPascal
unit psextension;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, virtualextension, forms, client, uPSComponent,uPSCompiler,
|
|
uPSRuntime, stdCtrls, uPSPreProcessor,MufasaTypes,MufasaBase, web,
|
|
bitmaps, plugins, libloader, dynlibs,internets,scriptproperties, settingssandbox;
|
|
|
|
|
|
|
|
type
|
|
|
|
{ TSimbaPSExtension }
|
|
|
|
TSimbaPSExtension = class(TVirtualSimbaExtension)
|
|
private
|
|
PSInstance: TPSScript;
|
|
FWorking: Boolean;
|
|
Script: TStringList;
|
|
FClient : TClient;
|
|
procedure StartExtension;
|
|
function FreeScript: boolean;
|
|
function InitScript: Boolean;
|
|
procedure OutputMessages;
|
|
protected
|
|
procedure RegisterPSCComponents(Sender: TObject; x: TPSPascalCompiler);
|
|
procedure RegisterPSRComponents(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
|
|
procedure RegisterMyMethods(x: TPSScript);
|
|
procedure OnPSExecute(Sender: TPSScript);
|
|
procedure SetEnabled(bool : boolean);override;
|
|
public
|
|
constructor Create(FileStr: String; StartDisabled : boolean = false);
|
|
destructor Destroy; override;
|
|
function HookExists(const HookName: String): Boolean;override;
|
|
function ExecuteHook(const HookName: String;var Args:TVariantArray; out OutVariant : Variant): Integer;override;
|
|
property Working : boolean read FWorking;
|
|
end;
|
|
|
|
implementation
|
|
uses
|
|
colour_conv,dtmutil,
|
|
{$ifdef mswindows}windows, MMSystem,{$endif}//MMSystem -> Sounds
|
|
uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms, uPSC_menus,
|
|
uPSC_extctrls, uPSC_mml, uPSC_dll, //Compile-libs
|
|
uPSUtils,
|
|
fontloader,
|
|
IOmanager,//TTarget_Exported
|
|
IniFiles,//Silly INI files
|
|
stringutil, //String st00f
|
|
|
|
uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms, uPSR_mml,
|
|
uPSR_menus, uPSI_ComCtrls, uPSI_Dialogs, uPSR_dll,
|
|
files,
|
|
dialogs,
|
|
dtm, //Dtms!
|
|
uPSR_extctrls, //Runtime-libs
|
|
Graphics, //For Graphics types
|
|
math, //Maths!
|
|
mmath, //Real maths!
|
|
strutils,
|
|
fileutil,
|
|
tpa, //Tpa stuff
|
|
SynRegExpr,
|
|
lclintf,
|
|
SimbaUnit,updateform, mmisc, mmlpsthread; // for GetTickCount and others.//Writeln
|
|
|
|
{$ifdef Linux}
|
|
{$define PS_SafeCall}
|
|
{$else}
|
|
//{$define PS_SafeCall}
|
|
{$endif}
|
|
{$MACRO ON}
|
|
{$ifdef PS_SafeCall}
|
|
{$define extdecl := safecall}
|
|
{$else}
|
|
{$define extdecl := register}
|
|
{$endif}
|
|
|
|
procedure psWriteLn(s: string);
|
|
begin
|
|
formWritelnEx(s);
|
|
end;
|
|
|
|
function TSimbaPSExtension.HookExists(const HookName: String): Boolean;
|
|
begin
|
|
Result := False;
|
|
if FWorking then
|
|
if PSInstance.Exec.GetProc(HookName) <> InvalidVal then
|
|
result := True;
|
|
end;
|
|
|
|
function TSimbaPSExtension.ExecuteHook(const HookName: String;var Args: TVariantArray; out OutVariant : Variant): Integer;
|
|
begin
|
|
result := SExt_error;
|
|
if not FWorking then
|
|
exit;
|
|
try
|
|
outvariant := PSInstance.ExecuteFunction(Args, HookName);
|
|
result := SExt_ok;
|
|
except
|
|
on e : exception do
|
|
psWriteLn(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;
|
|
FClient := TClient.Create('',SimbaForm.Manager);
|
|
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;
|
|
Args : TVariantArray;
|
|
begin
|
|
if not HookExists('Free') then
|
|
exit(false);
|
|
result := ExecuteHook('Free',Args,bla) = SExt_ok;
|
|
end;
|
|
|
|
{$DEFINE MML_EXPORT_THREADSAFE}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/other.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/settings.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/bitmap.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/window.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/tpa.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/strings.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/colour.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/colourconv.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/math.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/mouse.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/file.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/keyboard.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/dtm.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/ocr.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/internets.inc}
|
|
{$I ../../Units/MMLAddon/PSInc/Wrappers/extensions.inc}
|
|
|
|
procedure TSimbaPSExtension.RegisterMyMethods(x: TPSScript);
|
|
|
|
procedure SetCurrSection(s: string);
|
|
begin
|
|
end;
|
|
|
|
var
|
|
AppPath, ScriptPath: string;
|
|
i: Integer;
|
|
begin
|
|
AppPath := MainDir + DirectorySeparator;
|
|
ScriptPath := ExtractFileDir(Filename);
|
|
|
|
with SimbaForm, x do
|
|
begin
|
|
with Comp do
|
|
begin
|
|
{$I ../../Units/MMLAddon/PSInc/pscompile.inc}
|
|
AddTypes('TStringArray','Array of String');
|
|
AddConstantN('ExtPath','string').SetString(ExtPath);
|
|
AddTypeS('TMsgDlgType', '( mtWarning, mtError, mtInformation, mtConfirmation, mtCustom )');
|
|
AddTypeS('TMsgDlgBtn', '( mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, mbIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp )');
|
|
AddTypeS('TMsgDlgButtons', 'set of TMsgDlgBtn');
|
|
|
|
for i := 0 to high(VirtualKeys) do
|
|
AddConstantN(Format('VK_%S',[VirtualKeys[i].Str]),'Byte').SetInt(VirtualKeys[i].Key);
|
|
end;
|
|
|
|
{$i ../../Units/MMLAddon/PSInc/psexportedmethods.inc}
|
|
|
|
AddFunction(@ext_SDTMToMDTM,'function SDTMToMDTM(Const DTM: TSDTM): TMDTM;');
|
|
AddFunction(@ext_GetPage,'function GetPage(const url : string) : string');
|
|
AddFunction(@ext_DecompressBZip2,'function DecompressBZip2(const input: string;out output : string; const BlockSize: Cardinal): boolean;');
|
|
AddFunction(@ext_UnTar,'function UnTar(const Input : string; out Content : TStringArray) : boolean;');
|
|
AddFunction(@ext_UnTarEx,'function UnTarEx(const Input : string;const outputdir : string; overwrite : boolean): boolean;');
|
|
AddFunction(@ext_MessageDlg,'function MessageDlg(const aCaption, aMsg: string; DlgType: TMsgDlgType;Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;');
|
|
AddFunction(@ext_InputQuery,'function InputQuery(const ACaption, APrompt : String; var Value : String) : Boolean;');
|
|
AddRegisteredPTRVariable('Settings','TMMLSettingsSandbox');
|
|
AddRegisteredVariable('Simba','TForm');
|
|
AddRegisteredVariable('Simba_MainMenu','TMainMenu');
|
|
AddRegisteredVariable('Client','TClient');
|
|
end;
|
|
end;
|
|
|
|
procedure TSimbaPSExtension.OnPSExecute(Sender: TPSScript);
|
|
begin
|
|
Sender.SetVarToInstance('Simba',SimbaForm);
|
|
Sender.SetVarToInstance('Simba_MainMenu',SimbaForm.MainMenu);
|
|
Sender.SetVarToInstance('Client',FClient);
|
|
Sender.SetPointerToData('Settings',@Self.Settings,Sender.FindNamedType('TMMLSettingsSandbox'));
|
|
end;
|
|
|
|
procedure TSimbaPSExtension.SetEnabled(bool: boolean);
|
|
var
|
|
temp : variant;
|
|
Args : TVariantArray;
|
|
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',Args,temp);
|
|
end;
|
|
end else
|
|
if HookExists('detach') then
|
|
ExecuteHook('detach',Args,temp);
|
|
end;
|
|
inherited SetEnabled(bool);
|
|
end;
|
|
|
|
|
|
procedure TMufasaBitmapCopyClientToBitmap(self : TMufasaBitmap; Resize : boolean;x,y : integer; xs, ys, xe, ye: Integer);
|
|
begin
|
|
self.CopyClientToBitmap(SimbaForm.Manager,resize,x,y,xs,ys,xe,ye);
|
|
end;
|
|
|
|
procedure TSimbaPSExtension.RegisterPSCComponents(Sender: TObject; x: TPSPascalCompiler);
|
|
begin
|
|
SIRegister_Std(x);
|
|
SIRegister_Controls(x);
|
|
SIRegister_Classes(x, true);
|
|
SIRegister_Graphics(x, true);
|
|
SIRegister_stdctrls(x);
|
|
SIRegister_Forms(x);
|
|
SIRegister_ExtCtrls(x);
|
|
SIRegister_Menus(x);
|
|
SIRegister_ComCtrls(x);
|
|
SIRegister_Dialogs(x);
|
|
SIRegister_MML(x);
|
|
RegisterDll_Compiletime(x);
|
|
|
|
with x.AddFunction('procedure writeln;').decl do
|
|
with AddParam do
|
|
begin
|
|
OrgName:= 'x';
|
|
Mode:= pmIn;
|
|
end;
|
|
with x.AddFunction('function ToStr:string').decl do
|
|
with addparam do
|
|
begin
|
|
OrgName:= 'x';
|
|
Mode:= pmIn;
|
|
end;
|
|
with x.AddFunction('procedure swap;').decl do
|
|
begin
|
|
with addparam do
|
|
begin
|
|
OrgName:= 'x';
|
|
Mode:= pmInOut;
|
|
end;
|
|
with addparam do
|
|
begin
|
|
OrgName:= 'y';
|
|
Mode:= pmInOut;
|
|
end;
|
|
end;
|
|
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_ComCtrls(x);
|
|
RIRegister_Dialogs(x);
|
|
RegisterDLLRuntime(se);
|
|
RIRegister_MML(x);
|
|
with x.FindClass('TMufasaBitmap') do
|
|
begin
|
|
RegisterMethod(@TMufasaBitmapCopyClientToBitmap,'CopyClientToBitmap');
|
|
end;
|
|
|
|
se.RegisterFunctionName('WRITELN',@Writeln_,nil,nil);
|
|
se.RegisterFunctionName('TOSTR',@ToStr_,nil,nil);
|
|
se.RegisterFunctionName('SWAP',@swap_,nil,nil);
|
|
end;
|
|
|
|
destructor TSimbaPSExtension.Destroy;
|
|
begin
|
|
FClient.free;
|
|
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);
|
|
|
|
with PSInstance do
|
|
begin
|
|
{$I ../../Units/MMLAddon/PSInc/psdefines.inc}
|
|
end;
|
|
|
|
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.
|
|
|