diff --git a/Projects/SAMufasaGUI/project1.lpi b/Projects/SAMufasaGUI/project1.lpi index c329bdc..c9d5315 100644 --- a/Projects/SAMufasaGUI/project1.lpi +++ b/Projects/SAMufasaGUI/project1.lpi @@ -33,15 +33,15 @@ - + - + - + @@ -170,10 +170,10 @@ - - - - + + + + @@ -302,10 +302,10 @@ - + - + @@ -315,7 +315,7 @@ - + @@ -331,16 +331,16 @@ - + - - - - + + + + @@ -375,10 +375,10 @@ - - + + - + @@ -394,7 +394,7 @@ - + @@ -406,10 +406,10 @@ - - - - + + + + @@ -417,17 +417,13 @@ - - - - @@ -468,9 +464,7 @@ - - @@ -484,9 +478,7 @@ - - @@ -527,9 +519,7 @@ - - @@ -541,18 +531,16 @@ - - - - - - + + + + @@ -565,17 +553,15 @@ - - + - - + @@ -687,17 +673,13 @@ - - - - @@ -712,14 +694,14 @@ - + - - + + @@ -732,9 +714,7 @@ - - @@ -774,8 +754,8 @@ - - + + @@ -812,184 +792,189 @@ - - - + + - - - - + - - - - - - - - - - + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + - + - + - + - + - + - + - + - + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + diff --git a/Projects/SAMufasaGUI/project1.lpr b/Projects/SAMufasaGUI/project1.lpr index 734b80f..a0f38f7 100644 --- a/Projects/SAMufasaGUI/project1.lpr +++ b/Projects/SAMufasaGUI/project1.lpr @@ -8,7 +8,7 @@ uses {$ENDIF}{$ENDIF} Interfaces, // this includes the LCL widgetset Forms, LResources, Window, files, MufasaTypes, Client, TestUnit, finder, - MMLThread, mmlpsthread, bitmaps, colour_conv, plugins; + MMLThread, mmlpsthread, bitmaps, colour_conv, plugins, DTM; {$IFDEF WINDOWS}{$R project1.rc}{$ENDIF} diff --git a/Units/MMLAddon/mmlpsthread.pas b/Units/MMLAddon/mmlpsthread.pas index 775a65b..387d251 100644 --- a/Units/MMLAddon/mmlpsthread.pas +++ b/Units/MMLAddon/mmlpsthread.pas @@ -1,282 +1,280 @@ -unit mmlpsthread; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, Plugins,uPSPreProcessor; - -type - - { TMMLPSThread } - - TMMLPSThread = class(TThread) - procedure PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; - Parser: TPSPascalPreProcessorParser; const Active: Boolean; - const DirectiveName, DirectiveParam: string; var Continue: Boolean); - protected - PSScript : TPSScript; - DebugTo : TMemo; - PluginsToload : Array of integer; - procedure OnCompile(Sender: TPSScript); - procedure AfterExecute(Sender : TPSScript); - function RequireFile(Sender: TObject; const OriginFileName: String; - var FileName, OutPut: string): Boolean; - procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler); - procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter); - procedure OutputMessages; - procedure OnThreadTerminate(Sender: TObject); - procedure Execute; override; - public - Client : TClient; - procedure SetPSScript(Script : string); - procedure SetDebug( Strings : TMemo ); - constructor Create(CreateSuspended: Boolean); - destructor Destroy; override; - end; - -implementation -uses - MufasaTypes, - {$ifdef mswindows}windows,{$endif} - uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms, - uPSC_extctrls, //Compile-libs - - uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms, - uPSR_extctrls, //Runtime-libs - Graphics, //For Graphics types - math, //Maths! - lclintf; // for GetTickCount and others. - - -threadvar - CurrThread : TMMLPSThread; - -{Some General PS Functions here} -procedure psWriteln(str : string); -begin - {$IFNDEF MSWINDOWS} - writeln(str); - {$ELSE} - if CurrThread.DebugTo <> nil then - CurrThread.DebugTo.lines.add(str); - - {$ENDIF} - //Just overwriting itz.. soz. -end; - -function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; -var - i : integer; -begin; - Writeln('We have a length of: ' + inttostr(length(v))); - Try - Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname)); - Except - Writeln('We has some errors :-('); - end; -end; - - -{ - Note to Raymond: For PascalScript, Create it on the .Create, - Execute it on the .Execute, and don't forget to Destroy it on .Destroy. - - 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. - (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. - Unit "MMLPSThread", perhaps? - - See the TestUnit for use of this thread, it's pretty straightforward. - - It may also be wise to turn the "Importing of wrappers" into an include as - well, it will really make the unit more straightforward to use and read. -} - - -constructor TMMLPSThread.Create(CreateSuspended : boolean); -begin - SetLength(PluginsToLoad,0); - Client := TClient.Create; - PSScript := TPSScript.Create(nil); - PSScript.UsePreProcessor:= True; - PSScript.OnNeedFile := @RequireFile; - PSScript.OnProcessUnknowDirective:=@PSScriptProcessUnknowDirective; - PSScript.OnCompile:= @OnCompile; - PSScript.OnCompImport:= @OnCompImport; - PSScript.OnExecImport:= @OnExecImport; - PSScript.OnAfterExecute:= @AfterExecute; - - // Set some defines - {$I PSInc/psdefines.inc} - - - FreeOnTerminate := True; - Self.OnTerminate := @Self.OnThreadTerminate; - inherited Create(CreateSuspended); -end; - -procedure TMMLPSThread.OnThreadTerminate(Sender: TObject); -begin -// Writeln('Terminating the thread'); -end; - -destructor TMMLPSThread.Destroy; -begin - SetLength(PluginsToLoad,0); - Client.Free; - PSScript.Free; - inherited; -end; - -// include PS wrappers -{$I PSInc/Wrappers/other.inc} -{$I PSInc/Wrappers/bitmap.inc} -{$I PSInc/Wrappers/colour.inc} -{$I PSInc/Wrappers/math.inc} -{$I PSInc/Wrappers/mouse.inc} - - - -procedure TMMLPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; - Parser: TPSPascalPreProcessorParser; const Active: Boolean; - const DirectiveName, DirectiveParam: string; var Continue: Boolean); -var - TempNum : integer; - I,II : integer; -begin - if DirectiveName= 'LOADDLL' then - if DirectiveParam <> '' then - begin; - TempNum := PluginsGlob.LoadPlugin(DirectiveParam); - if TempNum < 0 then - Writeln(Format('Your DLL %s has not been found',[DirectiveParam])) - else - begin; - for i := High(PluginsToLoad) downto 0 do - if PluginsToLoad[i] = TempNum then - Exit; - SetLength(PluginsToLoad,Length(PluginsToLoad)+1); - PluginsToLoad[High(PluginsToLoad)] := TempNum; - end; - end; - Continue:= True; -end; - -procedure TMMLPSThread.OnCompile(Sender: TPSScript); -var - i,ii : integer; -begin - for i := high(PluginsToLoad) downto 0 do - for ii := 0 to PluginsGlob.MPlugins[PluginsToLoad[i]].MethodLen - 1 do - PSScript.AddFunctionEx(PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncPtr, - PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncStr, cdStdCall); - // Here we add all the functions to the engine. - {$I PSInc/pscompile.inc} -end; - -procedure TMMLPSThread.AfterExecute(Sender: TPSScript); -begin - //Here we add all the Script-freeing-leftovers (like BMParray etc) - // ^ This will all be done with Client.Destroy; -end; - -function TMMLPSThread.RequireFile(Sender: TObject; - const OriginFileName: String; var FileName, OutPut: string): Boolean; -begin - -end; - -procedure TMMLPSThread.OnCompImport(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); -end; - -procedure TMMLPSThread.OnExecImport(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); -end; - -procedure TMMLPSThread.OutputMessages; -var - l: Longint; - b: Boolean; -begin - b := False; - for l := 0 to PSScript.CompilerMessageCount - 1 do - begin - psWriteln(PSScript.CompilerErrorToStr(l)); - if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then - begin - b := True; -// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos; - - end; - end; -end; - -procedure TMMLPSThread.Execute; -var - time, i, ii: Integer; -begin; - CurrThread := Self; - time := lclintf.GetTickCount; - try - if PSScript.Compile then - begin - OutputMessages; - psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.'); -// if not (ScriptState = SCompiling) then - if not PSScript.Execute then - begin -// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition; - psWriteln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.' - +Inttostr(PSScript.ExecErrorByteCodePosition)); - end else psWriteln('Succesfully executed'); - end else - begin - OutputMessages; - psWriteln('Compiling failed'); - end; - except - on E : Exception do - psWriteln('Error: ' + E.Message); - end; -end; - -procedure TMMLPSThread.SetPSScript(Script: string); -begin - PSScript.Script.Text:= Script; -end; - -procedure TMMLPSThread.SetDebug(Strings: TMemo); -begin - DebugTo := Strings; -end; - - -{ Include stuff here? } - -//{$I inc/colors.inc} -//{$I inc/bitmaps.inc} - - -end. - - +unit mmlpsthread; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, Plugins,uPSPreProcessor; + +type + + { TMMLPSThread } + + TMMLPSThread = class(TThread) + procedure PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; const Active: Boolean; + const DirectiveName, DirectiveParam: string; var Continue: Boolean); + protected + PSScript : TPSScript; + DebugTo : TMemo; + PluginsToload : Array of integer; + procedure OnCompile(Sender: TPSScript); + procedure AfterExecute(Sender : TPSScript); + function RequireFile(Sender: TObject; const OriginFileName: String; + var FileName, OutPut: string): Boolean; + procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler); + procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter); + procedure OutputMessages; + procedure OnThreadTerminate(Sender: TObject); + procedure Execute; override; + public + Client : TClient; + procedure SetPSScript(Script : string); + procedure SetDebug( Strings : TMemo ); + constructor Create(CreateSuspended: Boolean); + destructor Destroy; override; + end; + +implementation +uses + MufasaTypes, + {$ifdef mswindows}windows,{$endif} + uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms, + uPSC_extctrls, //Compile-libs + + uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms, + uPSR_extctrls, //Runtime-libs + Graphics, //For Graphics types + math, //Maths! + lclintf; // for GetTickCount and others. + + +threadvar + CurrThread : TMMLPSThread; + +{Some General PS Functions here} +procedure psWriteln(str : string); +begin + {$IFNDEF MSWINDOWS} + writeln(str); + {$ELSE} + if CurrThread.DebugTo <> nil then + CurrThread.DebugTo.lines.add(str); + {$ENDIF} +end; + +function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; +var + i : integer; +begin; + Writeln('We have a length of: ' + inttostr(length(v))); + Try + Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname)); + Except + Writeln('We has some errors :-('); + end; +end; + + +{ + Note to Raymond: For PascalScript, Create it on the .Create, + Execute it on the .Execute, and don't forget to Destroy it on .Destroy. + + 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. + (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. + Unit "MMLPSThread", perhaps? + + See the TestUnit for use of this thread, it's pretty straightforward. + + It may also be wise to turn the "Importing of wrappers" into an include as + well, it will really make the unit more straightforward to use and read. +} + + +constructor TMMLPSThread.Create(CreateSuspended : boolean); +begin + SetLength(PluginsToLoad,0); + Client := TClient.Create; + PSScript := TPSScript.Create(nil); + PSScript.UsePreProcessor:= True; + PSScript.OnNeedFile := @RequireFile; + PSScript.OnProcessUnknowDirective:=@PSScriptProcessUnknowDirective; + PSScript.OnCompile:= @OnCompile; + PSScript.OnCompImport:= @OnCompImport; + PSScript.OnExecImport:= @OnExecImport; + PSScript.OnAfterExecute:= @AfterExecute; + + // Set some defines + {$I PSInc/psdefines.inc} + + + FreeOnTerminate := True; + Self.OnTerminate := @Self.OnThreadTerminate; + inherited Create(CreateSuspended); +end; + +procedure TMMLPSThread.OnThreadTerminate(Sender: TObject); +begin +// Writeln('Terminating the thread'); +end; + +destructor TMMLPSThread.Destroy; +begin + SetLength(PluginsToLoad,0); + Client.Free; + PSScript.Free; + inherited; +end; + +// include PS wrappers +{$I PSInc/Wrappers/other.inc} +{$I PSInc/Wrappers/bitmap.inc} +{$I PSInc/Wrappers/colour.inc} +{$I PSInc/Wrappers/math.inc} +{$I PSInc/Wrappers/mouse.inc} + + + +procedure TMMLPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; const Active: Boolean; + const DirectiveName, DirectiveParam: string; var Continue: Boolean); +var + TempNum : integer; + I,II : integer; +begin + if DirectiveName= 'LOADDLL' then + if DirectiveParam <> '' then + begin; + TempNum := PluginsGlob.LoadPlugin(DirectiveParam); + if TempNum < 0 then + Writeln(Format('Your DLL %s has not been found',[DirectiveParam])) + else + begin; + for i := High(PluginsToLoad) downto 0 do + if PluginsToLoad[i] = TempNum then + Exit; + SetLength(PluginsToLoad,Length(PluginsToLoad)+1); + PluginsToLoad[High(PluginsToLoad)] := TempNum; + end; + end; + Continue:= True; +end; + +procedure TMMLPSThread.OnCompile(Sender: TPSScript); +var + i,ii : integer; +begin + for i := high(PluginsToLoad) downto 0 do + for ii := 0 to PluginsGlob.MPlugins[PluginsToLoad[i]].MethodLen - 1 do + PSScript.AddFunctionEx(PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncPtr, + PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncStr, cdStdCall); + // Here we add all the functions to the engine. + {$I PSInc/pscompile.inc} +end; + +procedure TMMLPSThread.AfterExecute(Sender: TPSScript); +begin + //Here we add all the Script-freeing-leftovers (like BMParray etc) + // ^ This will all be done with Client.Destroy; +end; + +function TMMLPSThread.RequireFile(Sender: TObject; + const OriginFileName: String; var FileName, OutPut: string): Boolean; +begin + +end; + +procedure TMMLPSThread.OnCompImport(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); +end; + +procedure TMMLPSThread.OnExecImport(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); +end; + +procedure TMMLPSThread.OutputMessages; +var + l: Longint; + b: Boolean; +begin + b := False; + for l := 0 to PSScript.CompilerMessageCount - 1 do + begin + psWriteln(PSScript.CompilerErrorToStr(l)); + if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then + begin + b := True; +// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos; + + end; + end; +end; + +procedure TMMLPSThread.Execute; +var + time, i, ii: Integer; +begin; + CurrThread := Self; + time := lclintf.GetTickCount; + try + if PSScript.Compile then + begin + OutputMessages; + psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.'); +// if not (ScriptState = SCompiling) then + if not PSScript.Execute then + begin +// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition; + psWriteln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.' + +Inttostr(PSScript.ExecErrorByteCodePosition)); + end else psWriteln('Succesfully executed'); + end else + begin + OutputMessages; + psWriteln('Compiling failed'); + end; + except + on E : Exception do + psWriteln('Error: ' + E.Message); + end; +end; + +procedure TMMLPSThread.SetPSScript(Script: string); +begin + PSScript.Script.Text:= Script; +end; + +procedure TMMLPSThread.SetDebug(Strings: TMemo); +begin + DebugTo := Strings; +end; + + +{ Include stuff here? } + +//{$I inc/colors.inc} +//{$I inc/bitmaps.inc} + + +end. + +