From 3220330c90ffb1d5dbbe72d631fb4223c1d0020d Mon Sep 17 00:00:00 2001 From: Wizzup? Date: Sat, 17 Oct 2009 22:54:08 +0000 Subject: [PATCH] Fix for linux. git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@137 3f818213-9676-44b0-a9b4-5e4c4e03d09d --- Units/MMLAddon/mmlpsthread.pas | 629 +++++++++++++++++---------------- 1 file changed, 318 insertions(+), 311 deletions(-) diff --git a/Units/MMLAddon/mmlpsthread.pas b/Units/MMLAddon/mmlpsthread.pas index 55bd555..20d6ad2 100644 --- a/Units/MMLAddon/mmlpsthread.pas +++ b/Units/MMLAddon/mmlpsthread.pas @@ -1,311 +1,318 @@ -{ - This file is part of the Mufasa Macro Library (MML) - Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer - - MML is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - MML is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with MML. If not, see . - - See the file COPYING, included in this distribution, - for details about the copyright. - - MMLPSThread for the Mufasa Macro Library -} - -unit mmlpsthread; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, uPSPreProcessor; - -type - - { TMMLPSThread } - - TMMLPSThread = class(TThread) - procedure PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; - Parser: TPSPascalPreProcessorParser; const Active: Boolean; - const DirectiveName, DirectiveParam: string; var Continue: Boolean); - protected - 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 - PSScript : TPSScript; // Moved to public, as we can't kill it otherwise. - Client : TClient; - procedure SetPSScript(Script : string); - procedure SetDebug( Strings : TMemo ); - constructor Create(CreateSuspended: Boolean); - destructor Destroy; override; - end; - -implementation -uses - MufasaTypes, dtmutil, - {$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! - bitmaps, - lclintf; // for GetTickCount and others. - - -threadvar - CurrThread : TMMLPSThread; - -{Some General PS Functions here} -procedure psWriteln(str : string); -var - CriticalSec : TRTLCriticalSection; -begin - System.InitCriticalSection(CriticalSec); - System.EnterCriticalSection(CriticalSec); - try - if CurrThread.DebugTo <> nil then - begin; - CurrThread.DebugTo.lines.add(str); - CurrThread.DebugTo.Refresh; - end; - finally - System.LeaveCriticalSection(CriticalSec); - end; -end; - -function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; - -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} -{$I PSInc/Wrappers/dtm.inc} - - -procedure TMMLPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; - Parser: TPSPascalPreProcessorParser; const Active: Boolean; - const DirectiveName, DirectiveParam: string; var Continue: Boolean); -var - TempNum : integer; - I: 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 - - Result := False; -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: DWord; -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. - - +{ + This file is part of the Mufasa Macro Library (MML) + Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer + + MML is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + MML is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with MML. If not, see . + + See the file COPYING, included in this distribution, + for details about the copyright. + + MMLPSThread for the Mufasa Macro Library +} + +unit mmlpsthread; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, uPSPreProcessor; + +type + + { TMMLPSThread } + + TMMLPSThread = class(TThread) + procedure PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; const Active: Boolean; + const DirectiveName, DirectiveParam: string; var Continue: Boolean); + protected + 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 + PSScript : TPSScript; // Moved to public, as we can't kill it otherwise. + Client : TClient; + procedure SetPSScript(Script : string); + procedure SetDebug( Strings : TMemo ); + constructor Create(CreateSuspended: Boolean); + destructor Destroy; override; + end; + +implementation +uses + MufasaTypes, dtmutil, + {$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! + bitmaps, + lclintf; // for GetTickCount and others. + + +threadvar + CurrThread : TMMLPSThread; + +{Some General PS Functions here} +procedure psWriteln(str : string); +{$IFDEF WINDOWS} +var + CriticalSec : TRTLCriticalSection; +begin + System.InitCriticalSection(CriticalSec); + System.EnterCriticalSection(CriticalSec); + try + if CurrThread.DebugTo <> nil then + begin; + CurrThread.DebugTo.lines.add(str); + CurrThread.DebugTo.Refresh; + end; + finally + System.LeaveCriticalSection(CriticalSec); + end; +end; +{$ELSE} +begin +writeln(str); +end; +{$ENDIF} + + +function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; + +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} +{$I PSInc/Wrappers/dtm.inc} + + +procedure TMMLPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; const Active: Boolean; + const DirectiveName, DirectiveParam: string; var Continue: Boolean); +var + TempNum : integer; + I: 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 + + Result := False; +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: DWord; +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. + +