moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-11 03:45:06 -05:00
Code Issues Releases Wiki Activity

Added few functions + made psWriteln use Critical Sections (Not sure wether it w0rks on linux).

Browse Source 
git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@135 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond 2009-10-17 18:53:08 +00:00
parent 7c2fd48297
commit 50adef2299
3 changed files with 375 additions and 347 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
Units/MMLAddon/PSInc/Wrappers/other.inc
View File

@ -1,42 +1,62 @@
{ {
This file is part of the Mufasa Macro Library (MML) This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer
MML is free software: you can redistribute it and/or modify MML is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or the Free Software Foundation, either version 3 of the License, or
(at your option) any later version. (at your option) any later version.
MML is distributed in the hope that it will be useful, MML is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details. GNU General Public License for more details.
You should have received a copy of the GNU General Public License You should have received a copy of the GNU General Public License
along with MML. If not, see <http://www.gnu.org/licenses/>. along with MML. If not, see <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution, See the file COPYING, included in this distribution,
for details about the copyright. for details about the copyright.
Other.inc for the Mufasa Macro Library Other.inc for the Mufasa Macro Library
} }
procedure GetClientDimensions(var w, h: integer); procedure GetClientDimensions(var w, h: integer);
begin begin
CurrThread.Client.MWindow.GetDimensions(w, h); CurrThread.Client.MWindow.GetDimensions(w, h);
end; end;
procedure Wait(t: Integer); procedure Wait(t: Integer);
begin begin
Sleep(t); Sleep(t);
end; end;
function Freeze: boolean; procedure SaveScreenshot(FileName: string);
begin var
result := CurrThread.Client.MWindow.Freeze(); w,h : integer;
end; begin;
with CurrThread.Client.MWindow do
function Unfreeze: boolean; begin;
begin GetDimensions(w,h);
result := CurrThread.Client.MWindow.Unfreeze; with CopyClientToBitmap(0,0,w-1,h-1) do
end; begin;
SaveToFile(FileName);
Free;
end;
end;
end;
function Distance(x1, y1, x2, y2: Integer): Integer;
begin;
Result := Round(Sqrt(Sqr(x2-x1) + Sqr(y2-y1)));
end;
function Freeze: boolean;
begin
result := CurrThread.Client.MWindow.Freeze();
end;
function Unfreeze: boolean;
begin
result := CurrThread.Client.MWindow.Unfreeze;
end;

2
Units/MMLAddon/PSInc/pscompile.inc
View File

@ -56,9 +56,11 @@ Sender.AddFunction(@max,'function Max(a, b: Integer): Integer;');
Sender.AddFunction(@min,'function Min(a, b: Integer): Integer;'); Sender.AddFunction(@min,'function Min(a, b: Integer): Integer;');
Sender.AddFunction(@pssqr,'function Sqr(e : extended) : extended;'); Sender.AddFunction(@pssqr,'function Sqr(e : extended) : extended;');
Sender.AddFunction(@classes.point,'function Point(x,y:integer) : TPoint;'); Sender.AddFunction(@classes.point,'function Point(x,y:integer) : TPoint;');
Sender.AddFunction(@Distance,'function Distance(x1,y1,x2,y2 : integer) : integer;');
Sender.AddFunction(@Freeze, 'function freeze:boolean;'); Sender.AddFunction(@Freeze, 'function freeze:boolean;');
Sender.AddFunction(@Unfreeze, 'function unfreeze: boolean;'); Sender.AddFunction(@Unfreeze, 'function unfreeze: boolean;');
Sender.AddFunction(@SaveScreenshot,'procedure SaveScreenshot(FileName: string);');
Sender.AddFunction(@GetColor,'function GetColor(x, y: Integer): Integer;'); Sender.AddFunction(@GetColor,'function GetColor(x, y: Integer): Integer;');
Sender.AddFunction(@FindColor, 'function findcolor(var x, y: integer; color, x1, y1, x2, y2: integer): boolean;'); Sender.AddFunction(@FindColor, 'function findcolor(var x, y: integer; color, x1, y1, x2, y2: integer): boolean;');

616
Units/MMLAddon/mmlpsthread.pas
View File

@ -1,305 +1,311 @@
{ {
This file is part of the Mufasa Macro Library (MML) This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer
MML is free software: you can redistribute it and/or modify MML is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or the Free Software Foundation, either version 3 of the License, or
(at your option) any later version. (at your option) any later version.
MML is distributed in the hope that it will be useful, MML is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details. GNU General Public License for more details.
You should have received a copy of the GNU General Public License You should have received a copy of the GNU General Public License
along with MML. If not, see <http://www.gnu.org/licenses/>. along with MML. If not, see <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution, See the file COPYING, included in this distribution,
for details about the copyright. for details about the copyright.
MMLPSThread for the Mufasa Macro Library MMLPSThread for the Mufasa Macro Library
} }
unit mmlpsthread; unit mmlpsthread;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses uses
Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, uPSPreProcessor; Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, uPSPreProcessor;
type type
{ TMMLPSThread } { TMMLPSThread }
TMMLPSThread = class(TThread) TMMLPSThread = class(TThread)
procedure PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; procedure PSScriptProcessUnknowDirective(Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser; const Active: Boolean; Parser: TPSPascalPreProcessorParser; const Active: Boolean;
const DirectiveName, DirectiveParam: string; var Continue: Boolean); const DirectiveName, DirectiveParam: string; var Continue: Boolean);
protected protected
DebugTo : TMemo; DebugTo : TMemo;
PluginsToload : Array of integer; PluginsToload : Array of integer;
procedure OnCompile(Sender: TPSScript); procedure OnCompile(Sender: TPSScript);
procedure AfterExecute(Sender : TPSScript); procedure AfterExecute(Sender : TPSScript);
function RequireFile(Sender: TObject; const OriginFileName: String; function RequireFile(Sender: TObject; const OriginFileName: String;
var FileName, OutPut: string): Boolean; var FileName, OutPut: string): Boolean;
procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler); procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler);
procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter); procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
procedure OutputMessages; procedure OutputMessages;
procedure OnThreadTerminate(Sender: TObject); procedure OnThreadTerminate(Sender: TObject);
procedure Execute; override; procedure Execute; override;
public public
PSScript : TPSScript; // Moved to public, as we can't kill it otherwise. PSScript : TPSScript; // Moved to public, as we can't kill it otherwise.
Client : TClient; Client : TClient;
procedure SetPSScript(Script : string); procedure SetPSScript(Script : string);
procedure SetDebug( Strings : TMemo ); procedure SetDebug( Strings : TMemo );
constructor Create(CreateSuspended: Boolean); constructor Create(CreateSuspended: Boolean);
destructor Destroy; override; destructor Destroy; override;
end; end;
implementation implementation
uses uses
MufasaTypes, dtmutil, MufasaTypes, dtmutil,
{$ifdef mswindows}windows,{$endif} {$ifdef mswindows}windows,{$endif}
uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms, uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms,
uPSC_extctrls, //Compile-libs uPSC_extctrls, //Compile-libs
uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms, uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms,
uPSR_extctrls, //Runtime-libs uPSR_extctrls, //Runtime-libs
Graphics, //For Graphics types Graphics, //For Graphics types
math, //Maths! math, //Maths!
bitmaps, bitmaps,
lclintf; // for GetTickCount and others. lclintf; // for GetTickCount and others.
threadvar threadvar
CurrThread : TMMLPSThread; CurrThread : TMMLPSThread;
{Some General PS Functions here} {Some General PS Functions here}
procedure psWriteln(str : string); procedure psWriteln(str : string);
begin var
{$IFNDEF MSWINDOWS} CriticalSec : TRTLCriticalSection;
writeln(str); begin
{$ELSE} System.InitCriticalSection(CriticalSec);
if CurrThread.DebugTo <> nil then System.EnterCriticalSection(CriticalSec);
CurrThread.DebugTo.lines.add(str); try
{$ENDIF} if CurrThread.DebugTo <> nil then
end; begin;
CurrThread.DebugTo.lines.add(str);
function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; CurrThread.DebugTo.Refresh;
end;
begin; finally
Writeln('We have a length of: ' + inttostr(length(v))); System.LeaveCriticalSection(CriticalSec);
Try end;
Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname)); end;
Except
Writeln('We has some errors :-('); function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;
end;
end; begin;
Writeln('We have a length of: ' + inttostr(length(v)));
Try
{ Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname));
Note to Raymond: For PascalScript, Create it on the .Create, Except
Execute it on the .Execute, and don't forget to Destroy it on .Destroy. Writeln('We has some errors :-(');
end;
Furthermore, all the wrappers can be in the unit "implementation" section. end;
Better still to create an .inc for it, otherwise this unit will become huge.
(You can even split up the .inc's in stuff like color, bitmap, etc. )
{
Also, don't add PS to this unit, but make a seperate unit for it. Note to Raymond: For PascalScript, Create it on the .Create,
Unit "MMLPSThread", perhaps? Execute it on the .Execute, and don't forget to Destroy it on .Destroy.
See the TestUnit for use of this thread, it's pretty straightforward. Furthermore, all the wrappers can be in the unit "implementation" section.
Better still to create an .inc for it, otherwise this unit will become huge.
It may also be wise to turn the "Importing of wrappers" into an include as (You can even split up the .inc's in stuff like color, bitmap, etc. )
well, it will really make the unit more straightforward to use and read.
} Also, don't add PS to this unit, but make a seperate unit for it.
Unit "MMLPSThread", perhaps?
constructor TMMLPSThread.Create(CreateSuspended : boolean); See the TestUnit for use of this thread, it's pretty straightforward.
begin
SetLength(PluginsToLoad,0); It may also be wise to turn the "Importing of wrappers" into an include as
Client := TClient.Create; well, it will really make the unit more straightforward to use and read.
PSScript := TPSScript.Create(nil); }
PSScript.UsePreProcessor:= True;
PSScript.OnNeedFile := @RequireFile;
PSScript.OnProcessUnknowDirective:=@PSScriptProcessUnknowDirective; constructor TMMLPSThread.Create(CreateSuspended : boolean);
PSScript.OnCompile:= @OnCompile; begin
PSScript.OnCompImport:= @OnCompImport; SetLength(PluginsToLoad,0);
PSScript.OnExecImport:= @OnExecImport; Client := TClient.Create;
PSScript.OnAfterExecute:= @AfterExecute; PSScript := TPSScript.Create(nil);
PSScript.UsePreProcessor:= True;
// Set some defines PSScript.OnNeedFile := @RequireFile;
{$I PSInc/psdefines.inc} PSScript.OnProcessUnknowDirective:=@PSScriptProcessUnknowDirective;
PSScript.OnCompile:= @OnCompile;
PSScript.OnCompImport:= @OnCompImport;
FreeOnTerminate := True; PSScript.OnExecImport:= @OnExecImport;
Self.OnTerminate := @Self.OnThreadTerminate; PSScript.OnAfterExecute:= @AfterExecute;
inherited Create(CreateSuspended);
end; // Set some defines
{$I PSInc/psdefines.inc}
procedure TMMLPSThread.OnThreadTerminate(Sender: TObject);
begin
// Writeln('Terminating the thread'); FreeOnTerminate := True;
end; Self.OnTerminate := @Self.OnThreadTerminate;
inherited Create(CreateSuspended);
destructor TMMLPSThread.Destroy; end;
begin
SetLength(PluginsToLoad,0); procedure TMMLPSThread.OnThreadTerminate(Sender: TObject);
Client.Free; begin
PSScript.Free; // Writeln('Terminating the thread');
inherited; end;
end;
destructor TMMLPSThread.Destroy;
// include PS wrappers begin
{$I PSInc/Wrappers/other.inc} SetLength(PluginsToLoad,0);
{$I PSInc/Wrappers/bitmap.inc} Client.Free;
{$I PSInc/Wrappers/colour.inc} PSScript.Free;
{$I PSInc/Wrappers/math.inc} inherited;
{$I PSInc/Wrappers/mouse.inc} end;
{$I PSInc/Wrappers/dtm.inc}
// include PS wrappers
{$I PSInc/Wrappers/other.inc}
{$I PSInc/Wrappers/bitmap.inc}
procedure TMMLPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; {$I PSInc/Wrappers/colour.inc}
Parser: TPSPascalPreProcessorParser; const Active: Boolean; {$I PSInc/Wrappers/math.inc}
const DirectiveName, DirectiveParam: string; var Continue: Boolean); {$I PSInc/Wrappers/mouse.inc}
var {$I PSInc/Wrappers/dtm.inc}
TempNum : integer;
I: integer;
begin procedure TMMLPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor;
if DirectiveName= 'LOADDLL' then Parser: TPSPascalPreProcessorParser; const Active: Boolean;
if DirectiveParam <> '' then const DirectiveName, DirectiveParam: string; var Continue: Boolean);
begin; var
TempNum := PluginsGlob.LoadPlugin(DirectiveParam); TempNum : integer;
if TempNum < 0 then I: integer;
Writeln(Format('Your DLL %s has not been found',[DirectiveParam])) begin
else if DirectiveName= 'LOADDLL' then
begin; if DirectiveParam <> '' then
for i := High(PluginsToLoad) downto 0 do begin;
if PluginsToLoad[i] = TempNum then TempNum := PluginsGlob.LoadPlugin(DirectiveParam);
Exit; if TempNum < 0 then
SetLength(PluginsToLoad,Length(PluginsToLoad)+1); Writeln(Format('Your DLL %s has not been found',[DirectiveParam]))
PluginsToLoad[High(PluginsToLoad)] := TempNum; else
end; begin;
end; for i := High(PluginsToLoad) downto 0 do
Continue:= True; if PluginsToLoad[i] = TempNum then
end; Exit;
SetLength(PluginsToLoad,Length(PluginsToLoad)+1);
procedure TMMLPSThread.OnCompile(Sender: TPSScript); PluginsToLoad[High(PluginsToLoad)] := TempNum;
var end;
i,ii : integer; end;
begin Continue:= True;
for i := high(PluginsToLoad) downto 0 do end;
for ii := 0 to PluginsGlob.MPlugins[PluginsToLoad[i]].MethodLen - 1 do
PSScript.AddFunctionEx(PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncPtr, procedure TMMLPSThread.OnCompile(Sender: TPSScript);
PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncStr, cdStdCall); var
// Here we add all the functions to the engine. i,ii : integer;
{$I PSInc/pscompile.inc} begin
end; for i := high(PluginsToLoad) downto 0 do
for ii := 0 to PluginsGlob.MPlugins[PluginsToLoad[i]].MethodLen - 1 do
procedure TMMLPSThread.AfterExecute(Sender: TPSScript); PSScript.AddFunctionEx(PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncPtr,
begin PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncStr, cdStdCall);
//Here we add all the Script-freeing-leftovers (like BMParray etc) // Here we add all the functions to the engine.
// ^ This will all be done with Client.Destroy; {$I PSInc/pscompile.inc}
end; end;
function TMMLPSThread.RequireFile(Sender: TObject; procedure TMMLPSThread.AfterExecute(Sender: TPSScript);
const OriginFileName: String; var FileName, OutPut: string): Boolean; begin
begin //Here we add all the Script-freeing-leftovers (like BMParray etc)
// ^ This will all be done with Client.Destroy;
Result := False; end;
end;
function TMMLPSThread.RequireFile(Sender: TObject;
procedure TMMLPSThread.OnCompImport(Sender: TObject; x: TPSPascalCompiler); const OriginFileName: String; var FileName, OutPut: string): Boolean;
begin begin
SIRegister_Std(x);
SIRegister_Controls(x); Result := False;
SIRegister_Classes(x, true); end;
SIRegister_Graphics(x, true);
SIRegister_stdctrls(x); procedure TMMLPSThread.OnCompImport(Sender: TObject; x: TPSPascalCompiler);
SIRegister_Forms(x); begin
SIRegister_ExtCtrls(x); SIRegister_Std(x);
end; SIRegister_Controls(x);
SIRegister_Classes(x, true);
procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec; SIRegister_Graphics(x, true);
x: TPSRuntimeClassImporter); SIRegister_stdctrls(x);
begin SIRegister_Forms(x);
RIRegister_Std(x); SIRegister_ExtCtrls(x);
RIRegister_Classes(x, True); end;
RIRegister_Controls(x);
RIRegister_Graphics(x, True); procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec;
RIRegister_stdctrls(x); x: TPSRuntimeClassImporter);
RIRegister_Forms(x); begin
RIRegister_ExtCtrls(x); RIRegister_Std(x);
end; RIRegister_Classes(x, True);
RIRegister_Controls(x);
procedure TMMLPSThread.OutputMessages; RIRegister_Graphics(x, True);
var RIRegister_stdctrls(x);
l: Longint; RIRegister_Forms(x);
b: Boolean; RIRegister_ExtCtrls(x);
begin end;
b := False;
for l := 0 to PSScript.CompilerMessageCount - 1 do procedure TMMLPSThread.OutputMessages;
begin var
psWriteln(PSScript.CompilerErrorToStr(l)); l: Longint;
if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then b: Boolean;
begin begin
b := True; b := False;
// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos; for l := 0 to PSScript.CompilerMessageCount - 1 do
begin
end; psWriteln(PSScript.CompilerErrorToStr(l));
end; if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then
end; begin
b := True;
procedure TMMLPSThread.Execute; // FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos;
var
time: DWord; end;
begin; end;
CurrThread := Self; end;
time := lclintf.GetTickCount;
try procedure TMMLPSThread.Execute;
if PSScript.Compile then var
begin time: DWord;
OutputMessages; begin;
psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.'); CurrThread := Self;
// if not (ScriptState = SCompiling) then time := lclintf.GetTickCount;
if not PSScript.Execute then try
begin if PSScript.Compile then
// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition; begin
psWriteln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.' OutputMessages;
+Inttostr(PSScript.ExecErrorByteCodePosition)); psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.');
end else psWriteln('Succesfully executed'); // if not (ScriptState = SCompiling) then
end else if not PSScript.Execute then
begin begin
OutputMessages; // FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition;
psWriteln('Compiling failed'); psWriteln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.'
end; +Inttostr(PSScript.ExecErrorByteCodePosition));
except end else psWriteln('Succesfully executed');
on E : Exception do end else
psWriteln('Error: ' + E.Message); begin
end; OutputMessages;
end; psWriteln('Compiling failed');
end;
procedure TMMLPSThread.SetPSScript(Script: string); except
begin on E : Exception do
PSScript.Script.Text:= Script; psWriteln('Error: ' + E.Message);
end; end;
end;
procedure TMMLPSThread.SetDebug(Strings: TMemo);
begin procedure TMMLPSThread.SetPSScript(Script: string);
DebugTo := Strings; begin
end; PSScript.Script.Text:= Script;
end;
{ Include stuff here? } procedure TMMLPSThread.SetDebug(Strings: TMemo);
begin
//{$I inc/colors.inc} DebugTo := Strings;
//{$I inc/bitmaps.inc} end;
end. { Include stuff here? }
//{$I inc/colors.inc}
//{$I inc/bitmaps.inc}
end.