{ 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; {$Define PS_USESSUPPORT} {$mode objfpc}{$H+} interface uses Classes, SysUtils, client, uPSComponent,uPSCompiler, uPSRuntime,stdCtrls, uPSPreProcessor,MufasaTypes,MufasaBase, web, bitmaps, plugins, libloader, dynlibs,internets,scriptproperties, settings,settingssandbox, Rutis_Engine,Rutis_Defs; const m_Status = 0; //Data = PChar to new status m_Disguise = 1; //Data = PChar to new title m_DisplayDebugImgWindow = 2; //Data = PPoint to window size m_DrawBitmapDebugImg = 3; //Data = TMufasaBitmap m_GetDebugBitmap = 4; //Data = TMufasaBitmap m_ClearDebugImg = 5; //Data = nil m_ClearDebug = 6; //Data = nil type { TMMLPSThread } TCallBackData = record FormCallBack : procedure of object; cmd : integer; data : pointer; end; PCallBackData = ^TCallBackData; TSyncInfo = record V : MufasaTypes.PVariantArray; MethodName : string; Res : ^Variant; SyncMethod : procedure of object; OldThread : TThread; end; PSyncInfo = ^TSyncInfo; TErrorType = (errRuntime,errCompile); TOnError = procedure of object; TErrorData = record Row,Col,Position : integer; Error : string; ErrType : TErrorType; Module : string; IncludePath : string; end; PErrorData = ^TErrorData; TExpMethod = record Section : string; FuncDecl : string; FuncPtr : Pointer; end; TExpMethodArr = array of TExpMethod; TInputQueryData = record ACaption, APrompt,Value : String; Res : boolean; end; { TMThread } TMThread = class(TThread) private procedure SetOpenConnectionEvent(const AValue: TOpenConnectionEvent); procedure SetOpenFileEvent(const AValue: TOpenFileEvent); procedure SetWriteFileEvent(const AValue: TWriteFileEvent); protected ScriptPath, AppPath, IncludePath, PluginPath, FontPath: string; DebugTo: TWritelnProc; ExportedMethods : TExpMethodArr; Includes : TStringList; FOpenConnectionEvent : TOpenConnectionEvent; FWriteFileEvent : TWriteFileEvent; FOpenFileEvent : TOpenFileEvent; procedure LoadPlugin(plugidx: integer); virtual; abstract; public Prop: TScriptProperties; Client : TClient; MInternet : TMInternet; StartTime : LongWord; Settings: TMMLSettings; SimbaSettingsFile: String; Sett: TMMLSettingsSandbox; CallBackData : PCallBackData; //Handles general callback functions for threadsafety InputQueryData : TInputQueryData;//We need this for InputQuery SyncInfo : PSyncInfo; //We need this for callthreadsafe ErrorData : PErrorData; //We need this for thread-safety etc OnError : TOnError; //Error handeler CompileOnly : boolean; procedure FormCallBackEx(cmd : integer; var data : pointer); procedure FormCallBack(cmd : integer; data : pointer); procedure mInputQuery; procedure HandleError(ErrorRow,ErrorCol,ErrorPosition : integer; ErrorStr : string; ErrorType : TErrorType; ErrorModule : string); function ProcessDirective(DirectiveName, DirectiveArgs: string): boolean; function LoadFile(ParentFile : string; var filename, contents: string): boolean; procedure AddMethod(meth: TExpMethod); virtual; procedure SetDebug( writelnProc : TWritelnProc ); procedure SetPaths(ScriptP,AppP,IncludeP,PluginP,FontP : string); procedure SetSettings(S: TMMLSettings; SimbaSetFile: String); procedure OnThreadTerminate(Sender: TObject); procedure SetScript(script: string); virtual; abstract; procedure Execute; override; abstract; procedure Terminate; virtual; abstract; constructor Create(CreateSuspended: boolean; TheSyncInfo : PSyncInfo; plugin_dir: string); destructor Destroy; override; class function GetExportedMethods : TExpMethodArr; property OpenConnectionEvent : TOpenConnectionEvent read FOpenConnectionEvent write SetOpenConnectionEvent; property WriteFileEvent : TWriteFileEvent read FWriteFileEvent write SetWriteFileEvent; property OpenFileEvent : TOpenFileEvent read FOpenFileEvent write SetOpenFileEvent; end; { TPSThread } TPSThread = class(TMThread) public procedure OnProcessDirective(Sender: TPSPreProcessor; Parser: TPSPascalPreProcessorParser; const Active: Boolean; const DirectiveName, DirectiveParam: string; var Continue: Boolean); function PSScriptFindUnknownFile(Sender: TObject; const OrginFileName: string; var FileName, Output: string): Boolean; procedure PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; Parser: TPSPascalPreProcessorParser; const Active: Boolean; const DirectiveName, DirectiveParam: string; var Continue: Boolean); protected PluginsToload : array of integer; procedure LoadPlugin(plugidx: integer); override; procedure OnCompile(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 HandleScriptTerminates; public PSScript : TPSScript; constructor Create(CreateSuspended: Boolean; TheSyncInfo : PSyncInfo; plugin_dir: string); destructor Destroy; override; procedure SetScript(script: string); override; procedure Execute; override; procedure Terminate; override; end; TPrecompiler_Callback = function(name, args: PChar): boolean; stdcall; TErrorHandeler_Callback = procedure(line, pos: integer; err: PChar; runtime: boolean); stdcall; TCPThread = class(TMThread) protected instance: pointer; added_methods: array of TExpMethod; procedure LoadPlugin(plugidx: integer); override; public constructor Create(CreateSuspended: Boolean; TheSyncInfo : PSyncInfo; plugin_dir: string); destructor Destroy; override; procedure SetScript(script: string); override; procedure Execute; override; procedure Terminate; override; procedure AddMethod(meth: TExpMethod); override; end; { TRTThread } TRTThread = class(TMThread) private procedure RTOnWrite(s : String); procedure RTOnError(s : String; ErrorType : TRutisErrorType); public RUTIS : TRutisEngine; constructor Create(CreateSuspended: Boolean; TheSyncInfo : PSyncInfo; plugin_dir: string); destructor Destroy; override; procedure SetScript(script: string); override; procedure Execute; override; procedure Terminate; override; end; threadvar CurrThread : TMThread; var PluginsGlob: TMPlugins; libcpascal: integer; interp_init: function(precomp: TPrecompiler_Callback; err: TErrorHandeler_Callback): Pointer; cdecl; interp_meth: procedure(interp: Pointer; addr: Pointer; def: PChar); cdecl; interp_type: procedure(interp: Pointer; def: PChar); cdecl; interp_set: procedure(interp: Pointer; ppg: PChar); cdecl; interp_comp: function(interp: Pointer): boolean; cdecl; interp_run: function(interp: Pointer): boolean; cdecl; interp_free: procedure(interp: Pointer); cdecl; 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 forms,//Forms SynRegExpr, lclintf // for GetTickCount and others. ; {$ifdef Linux} {$define PS_SafeCall} {$else} //{$define PS_SafeCall} {$endif} {$MACRO ON} {$ifdef PS_SafeCall} {$define extdecl := safecall} {$else} {$define extdecl := register} {$endif} {Some General PS Functions here} procedure psWriteln(str : string); extdecl; begin if CurrThread.Prop.WriteTimeStamp then str := format('[%s]: %s', [TimeToStr(TimeStampToDateTime(MSecsToTimeStamp(GetTickCount - CurrThread.StartTime))), str]); if Assigned(CurrThread.DebugTo) then CurrThread.DebugTo(str) else mDebugLn(str); end; procedure ps_DebugLn(str : string); extdecl; begin if CurrThread.Prop.WriteTimeStamp then str := format('[%s]: %s', [TimeToStr(TimeStampToDateTime(MSecsToTimeStamp(GetTickCount - CurrThread.StartTime))), str]); mDebugLn(str); end; {***implementation TMThread***} constructor TMThread.Create(CreateSuspended: boolean; TheSyncInfo: PSyncInfo; plugin_dir: string); begin inherited Create(CreateSuspended); Client := TClient.Create(plugin_dir); if Assigned(WriteFileEvent) then Client.MFiles.WriteFileEvent := WriteFileEvent; if Assigned(OpenFileEvent) then Client.MFiles.OpenFileEvent := OpenFileEvent; MInternet := TMInternet.Create(Client); if Assigned(OpenConnectionEvent) then MInternet.OpenConnectionEvent := Self.OpenConnectionEvent; SyncInfo:= TheSyncInfo; ExportedMethods:= GetExportedMethods; FreeOnTerminate := True; CompileOnly := false; OnTerminate := @OnThreadTerminate; OnError:= nil; Includes := TStringList.Create; Includes.CaseSensitive:= {$ifdef linux}true{$else}false{$endif}; Sett := nil; Prop := TScriptProperties.Create; end; destructor TMThread.Destroy; begin MInternet.Free; Client.Free; Includes.free; Prop.Free; if Sett <> nil then Sett.Free; inherited Destroy; end; procedure TMThread.SetOpenConnectionEvent(const AValue: TOpenConnectionEvent); begin FOpenConnectionEvent:= AValue; if Assigned(MInternet) then self.MInternet.OpenConnectionEvent := AValue; end; procedure TMThread.SetOpenFileEvent(const AValue: TOpenFileEvent); begin FOpenFileEvent:= AValue; if Assigned(Client) then self.Client.MFiles.OpenFileEvent := AValue; end; procedure TMThread.SetWriteFileEvent(const AValue: TWriteFileEvent); begin FWriteFileEvent:= AValue; if Assigned(Client) then self.Client.MFiles.WriteFileEvent := AValue;; end; procedure TMThread.FormCallBackEx(cmd: integer; var data: pointer); begin if (CallBackData = nil) or not Assigned(CallBackData^.FormCallBack) then exit; CallBackData^.cmd:= cmd; CallBackData^.data:= data; Synchronize(CallBackData^.FormCallBack); data := CallBackData^.data; end; procedure TMThread.FormCallBack(cmd: integer; data: pointer); begin if (CallBackData = nil) or (not Assigned(CallBackData^.FormCallBack)) then exit; CallBackData^.cmd:= cmd; CallBackData^.data:= data; Synchronize(CallBackData^.FormCallBack); end; procedure TMThread.mInputQuery; begin InputQueryData.Res:= InputQuery(InputQueryData.ACaption,InputQueryData.APrompt, InputQueryData.Value); end; procedure TMThread.HandleError(ErrorRow,ErrorCol, ErrorPosition: integer; ErrorStr: string; ErrorType: TErrorType; ErrorModule : string); begin if OnError = nil then exit; ErrorData^.Row:= ErrorRow - 1; ErrorData^.Col := ErrorCol; ErrorData^.Position:= ErrorPosition; ErrorData^.Error:= ErrorStr; ErrorData^.ErrType:= ErrorType; ErrorData^.Module:= ErrorModule; ErrorData^.IncludePath:= IncludePath; CurrThread.Synchronize(OnError); end; procedure TMThread.OnThreadTerminate(Sender: TObject); begin end; procedure TMThread.AddMethod(meth: TExpMethod); begin end; function TMThread.LoadFile(ParentFile : string; var filename, contents: string): boolean; var path: string; f: TFileStream; begin path := FindFile(filename,[includepath,ScriptPath,IncludeTrailingPathDelimiter(ExtractFileDir(parentfile))]); if path = '' then begin psWriteln(Path + ' doesn''t exist'); Result := false; Exit; end; filename := path;//Yeah! Includes.Add(path); try f:= TFileStream.Create(UTF8ToSys(Path), fmOpenRead); SetLength(contents, f.Size); f.Read(contents[1], Length(contents)); result:= true; f.free; except Result := false; psWriteln('ERROR in TMThread.LoadFile'); end; end; function TMThread.ProcessDirective(DirectiveName, DirectiveArgs: string): boolean; var plugin_idx, i: integer; path : string; begin Result := False; if CompareText(DirectiveName,'LOADLIB') = 0 then begin if DirectiveArgs <> '' then begin; plugin_idx:= PluginsGlob.LoadPlugin(DirectiveArgs); if plugin_idx < 0 then psWriteln(Format('Your DLL %s has not been found',[DirectiveArgs])) else begin LoadPlugin(plugin_idx); Result:= True; end; end else psWriteln('Your LoadLib directive has no params, thus cannot find the plugin'); end else if CompareText(DirectiveName,'INCLUDE_ONCE') = 0 then begin Result := True; //Lets to the actual file checking later on in the preprocessor ;-) if (DirectiveArgs <> '') then begin path := FindFile(DirectiveArgs,[ScriptPath,IncludePath]); if (path <> '') then if Includes.Find(path,i) then begin psWriteln('Include_Once file already included'); Result := False; end; end; end else Result := True; end; procedure TMThread.SetDebug(writelnProc: TWritelnProc); begin DebugTo := writelnProc; Client.WritelnProc:= writelnProc; end; procedure TMThread.SetSettings(S: TMMLSettings; SimbaSetFile: String); begin Self.SimbaSettingsFile := SimbaSetFile; Self.Settings := S; Self.Sett := TMMLSettingsSandbox.Create(Self.Settings); Self.Sett.prefix := 'Scripts/'; end; procedure TMThread.SetPaths(ScriptP, AppP,IncludeP,PluginP,FontP: string); begin AppPath:= AppP; ScriptPath:= ScriptP; IncludePath:= IncludeP; PluginPath:= PluginP; FontPath:= FontP; end; function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; extdecl; begin if GetCurrentThreadId = MainThreadID then begin with TPSThread(currthread).PSScript do Result := Exec.RunProcPVar(V,Exec.GetProc(Procname)); end else begin CurrThread.SyncInfo^.MethodName:= ProcName; CurrThread.SyncInfo^.V:= @V; CurrThread.SyncInfo^.OldThread := CurrThread; CurrThread.SyncInfo^.Res := @Result; CurrThread.Synchronize(CurrThread.SyncInfo^.SyncMethod); end; end; {$I PSInc/Wrappers/other.inc} {$I PSInc/Wrappers/settings.inc} {$I PSInc/Wrappers/bitmap.inc} {$I PSInc/Wrappers/window.inc} {$I PSInc/Wrappers/tpa.inc} {$I PSInc/Wrappers/strings.inc} {$I PSInc/Wrappers/colour.inc} {$I PSInc/Wrappers/colourconv.inc} {$I PSInc/Wrappers/math.inc} {$I PSInc/Wrappers/mouse.inc} {$I PSInc/Wrappers/file.inc} {$I PSInc/Wrappers/keyboard.inc} {$I PSInc/Wrappers/dtm.inc} {$I PSInc/Wrappers/ocr.inc} {$I PSInc/Wrappers/internets.inc} class function TMThread.GetExportedMethods: TExpMethodArr; var c : integer; CurrSection : string; procedure SetCurrSection(str : string); begin; CurrSection := Str; end; procedure AddFunction( Ptr : Pointer; DeclStr : String); begin; if c >= 400 then raise exception.create('PSThread.LoadMethods: Exported more than 400 functions'); Result[c].FuncDecl:= DeclStr; Result[c].FuncPtr:= Ptr; Result[c].Section:= CurrSection; inc(c); end; begin c := 0; CurrSection := 'Other'; SetLength(Result,400); {$i PSInc/psexportedmethods.inc} SetLength(Result,c); end; {***implementation TPSThread***} constructor TPSThread.Create(CreateSuspended : boolean; TheSyncInfo : PSyncInfo; plugin_dir: string); var I : integer; begin inherited Create(CreateSuspended, TheSyncInfo, plugin_dir); PSScript := TPSScript.Create(nil); PSScript.UsePreProcessor:= True; PSScript.CompilerOptions := PSScript.CompilerOptions + [icBooleanShortCircuit]; PSScript.OnNeedFile := @RequireFile; PSScript.OnProcessDirective:=@OnProcessDirective; PSScript.OnProcessUnknowDirective:=@PSScriptProcessUnknowDirective; PSScript.OnCompile:= @OnCompile; PSScript.OnCompImport:= @OnCompImport; PSScript.OnExecImport:= @OnExecImport; PSScript.OnFindUnknownFile:= @PSScriptFindUnknownFile; with PSScript do begin // Set some defines {$I PSInc/psdefines.inc} end; for i := 0 to high(ExportedMethods) do if pos('Writeln',exportedmethods[i].FuncDecl) > 0 then begin ExportedMethods[i].FuncPtr := nil; break; end; end; destructor TPSThread.Destroy; begin PSScript.Free; inherited; end; procedure TPSThread.OnProcessDirective(Sender: TPSPreProcessor; Parser: TPSPascalPreProcessorParser; const Active: Boolean; const DirectiveName, DirectiveParam: string; var Continue: Boolean); begin if CompareText(DirectiveName, 'LOADLIB') = 0 then Continue := not ProcessDirective(DirectiveName,DirectiveParam); end; function TPSThread.PSScriptFindUnknownFile(Sender: TObject; const OrginFileName: string; var FileName, Output: string): Boolean; begin mDebugLn(OrginFileName + '-' + Output + '-' + FileName); Result := false; end; procedure TPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; Parser: TPSPascalPreProcessorParser; const Active: Boolean; const DirectiveName, DirectiveParam: string; var Continue: Boolean); begin Continue:= not ProcessDirective(DirectiveName, DirectiveParam); end; function Muf_Conv_to_PS_Conv( conv : integer) : TDelphiCallingConvention; begin case conv of cv_StdCall : result := cdStdCall; cv_Register: result := cdRegister; else raise exception.createfmt('Unknown Calling Convention[%d]',[conv]); end; end; procedure TPSThread.LoadPlugin(plugidx: integer); var i: integer; begin for i := High(PluginsToLoad) downto 0 do if PluginsToLoad[i] = plugidx then Exit; SetLength(PluginsToLoad,Length(PluginsToLoad)+1); PluginsToLoad[High(PluginsToLoad)]:= plugidx; end; procedure TPSThread.OnCompile(Sender: TPSScript); var i,ii : integer; Fonts : TMFonts; begin Fonts := Client.MOCR.Fonts; for i := fonts.count - 1 downto 0 do Sender.Comp.AddConstantN(Fonts[i].Name,'string').SetString(Fonts[i].Name); for i := high(PluginsToLoad) downto 0 do for ii := 0 to PluginsGlob.MPlugins[PluginsToLoad[i]].MethodLen - 1 do Sender.AddFunctionEx(PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[ii].FuncPtr, PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[ii].FuncStr, Muf_Conv_to_PS_Conv(PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[ii].FuncConv)); for i := 0 to high(VirtualKeys) do Sender.Comp.AddConstantN(Format('VK_%S',[VirtualKeys[i].Str]),'Byte').SetInt(VirtualKeys[i].Key); // Here we add all the Consts/Types to the engine. //Export all the methods for i := 0 to high(ExportedMethods) do if ExportedMethods[i].FuncPtr <> nil then Sender.AddFunctionEx(ExportedMethods[i].FuncPtr,ExportedMethods[i].FuncDecl, {$ifdef PS_SafeCall}cdSafeCall{$else}cdRegister{$endif}); end; function TPSThread.RequireFile(Sender: TObject; const OriginFileName: String; var FileName, OutPut: string): Boolean; begin Result := LoadFile(OriginFileName,FileName,OutPut); if Result then Output := '{$IFNDEF IS_INCLUDE}{$DEFINE IS_INCLUDE}{$DEFINE __REMOVE_IS_INCLUDE}{$ENDIF}' + LineEnding + Output + LineEnding + '{$IFDEF __REMOVE_IS_INCLUDE}{$UNDEF IS_INCLUDE}{$ENDIF}'; end; procedure SIRegister_Mufasa(cl: TPSPascalCompiler); begin SIRegister_MML(cl); end; procedure TPSThread.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); SIRegister_Menus(x); SIRegister_ComCtrls(x); SIRegister_Dialogs(x); if self.settings <> nil then begin if lowercase(self.settings.GetKeyValueDefLoad('Settings/Interpreter/AllowSysCalls', 'False', Self.SimbaSettingsFile)) = 'true' then begin { Can remove later } psWriteln('Allowing API/SysCalls.'); RegisterDll_Compiletime(x); end; end; with x do begin {$I PSInc/pscompile.inc} end; SIRegister_Mufasa(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; function TMufasaBitmapCreate : TMufasaBitmap; begin; result := TMufasaBitmap.Create; CurrThread.Client.MBitmaps.AddBMP(result); end; procedure TMufasaBitmapFree(Self : TMufasaBitmap);begin; CurrThread.Client.MBitmaps.FreeBMP(Self.Index); end; function TMufasaBitmapCopy(Self : TMufasaBitmap;const xs,ys,xe,ye : integer) : TMufasaBitmap; begin result := Self.Copy(xs,ys,xe,ye); CurrThread.Client.MBitmaps.AddBMP(result); end; function TMDTMCreate : TMDTM; begin result := TMDTM.Create; CurrThread.Client.MDTMs.AddDTM(result); end; procedure TMDTMFree(Self : TMDTM); begin CurrThread.Client.MDTMs.FreeDTM(self.Index); end; procedure RIRegister_Mufasa(CL: TPSRuntimeClassImporter); begin RIRegister_MML(cl); //Overwrites the default stuff with cl.FindClass('TMufasaBitmap') do begin RegisterConstructor(@TMufasaBitmapCreate,'Create'); RegisterMethod(@TMufasaBitmapFree,'Free'); RegisterMethod(@TMufasaBitmapCopy,'Copy'); end; With cl.FindClass('TMDTM') do begin RegisterConstructor(@TMDTMCreate,'Create'); RegisterMethod(@TMDTMFree,'Free'); end; end; procedure TPSThread.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); RIRegister_Menus(x); RIRegister_Mufasa(x); RIRegister_ComCtrls(x); RIRegister_Dialogs(x); RegisterDLLRuntime(se); se.RegisterFunctionName('WRITELN',@Writeln_,nil,nil); se.RegisterFunctionName('TOSTR',@ToStr_,nil,nil); se.RegisterFunctionName('SWAP',@swap_,nil,nil); end; procedure TPSThread.OutputMessages; var l: Longint; b: Boolean; begin b := False; for l := 0 to PSScript.CompilerMessageCount - 1 do begin if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then begin b := True; if OnError <> nil then with PSScript.CompilerMessages[l] do HandleError(Row, Col, Pos, MessageToString,errCompile, ModuleName) else psWriteln(PSScript.CompilerErrorToStr(l) + ' at line ' + inttostr(PSScript.CompilerMessages[l].Row - 1)); end else psWriteln(PSScript.CompilerErrorToStr(l) + ' at line ' + inttostr(PSScript.CompilerMessages[l].Row - 1)); end; end; procedure TPSThread.HandleScriptTerminates; var I : integer; begin if (PSScript.Exec.ExceptionCode =ErNoError) and (SP_OnTerminate in Prop.Properties) then begin; for i := 0 to Prop.OnTerminateProcs.Count - 1 do begin try PSScript.ExecuteFunction([],Prop.OnTerminateProcs[i]); finally end; end; end; end; procedure TPSThread.Execute; begin CurrThread := Self; Starttime := lclintf.GetTickCount; try if PSScript.Compile then begin OutputMessages; psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - Starttime) + ' ms.'); if CompileOnly then exit; // if not (ScriptState = SCompiling) then if not PSScript.Execute then HandleError(PSScript.ExecErrorRow,PSScript.ExecErrorCol,PSScript.ExecErrorPosition,PSScript.ExecErrorToString, errRuntime, PSScript.ExecErrorFileName) else begin HandleScriptTerminates; psWriteln('Successfully executed.'); end; end else begin OutputMessages; psWriteln('Compiling failed.'); end; except on E : Exception do psWriteln('Exception in Script: ' + e.message); end; end; procedure TPSThread.Terminate; begin PSScript.Stop; end; procedure TPSThread.SetScript(script: string); begin PSScript.Script.Text:= LineEnding+Script; //A LineEnding to create space for future extra's in first line (defines?) end; {***implementation TCPThread***} procedure LoadCPascal(plugin_dir: string); begin libcpascal:= LoadLibrary(PChar(plugin_dir + 'libcpascal' + {$ifdef LINUX} '.so' {$else} '.dll' {$endif})); if libcpascal = 0 then raise Exception.Create('CPascal library not found'); Pointer(interp_init):= GetProcAddress(libcpascal, PChar('interp_init')); Pointer(interp_meth):= GetProcAddress(libcpascal, PChar('interp_meth')); Pointer(interp_type):= GetProcAddress(libcpascal, PChar('interp_type')); Pointer(interp_set):= GetProcAddress(libcpascal, PChar('interp_set')); Pointer(interp_comp):= GetProcAddress(libcpascal, PChar('interp_comp')); Pointer(interp_run):= GetProcAddress(libcpascal, PChar('interp_run')); Pointer(interp_free):= GetProcAddress(libcpascal, PChar('interp_free')); end; function Interpreter_Precompiler(name, args: PChar): boolean; stdcall; begin result:= CurrThread.ProcessDirective(name, args); end; procedure Interpreter_ErrorHandler(line, pos: integer; err: PChar; runtime: boolean); stdcall; begin if runtime then CurrThread.HandleError(line,-1,pos,err,errRuntime,'') else CurrThread.HandleError(line,-1,pos,err,errCompile,'') end; constructor TCPThread.Create(CreateSuspended: Boolean; TheSyncInfo : PSyncInfo; plugin_dir: string); var plugin_idx: integer; begin inherited Create(CreateSuspended, TheSyncInfo, plugin_dir); if libcpascal = 0 then LoadCPascal(plugin_dir); instance:= interp_init(@Interpreter_Precompiler, @Interpreter_ErrorHandler); end; destructor TCPThread.Destroy; begin interp_free(instance); inherited Destroy; end; procedure TCPThread.SetScript(script: string); begin interp_set(instance,PChar(script)); end; procedure TCPThread.AddMethod(meth: TExpMethod); begin interp_meth(instance,meth.FuncPtr,PChar(meth.FuncDecl)); end; procedure TCPThread.LoadPlugin(plugidx: integer); var i: integer; begin with PluginsGlob.MPlugins[plugidx] do for i := 0 to MethodLen - 1 do with Methods[i] do begin pswriteln(FuncStr); interp_meth(self.instance,FuncPtr,PChar(FuncStr)); end; pswriteln('done') end; procedure TCPThread.Execute; var i: integer; begin CurrThread := Self; Starttime := GetTickCount; psWriteln('Invoking CPascal Interpreter'); interp_type(self.instance,'type longword = integer;'); interp_type(self.instance,'type word = integer;'); interp_type(self.instance,'type longint = integer;'); interp_type(self.instance,'type pointer = integer;'); interp_type(self.instance,'type byte = integer;'); interp_type(self.instance,'type extended = real;'); interp_type(self.instance,'type tcolor = integer;'); interp_type(self.instance,'type TExtendedArray = array of extended;'); interp_type(self.instance,'type T2DExtendedArray = array of array of extended;'); interp_type(self.instance,'type TIntegerArray = array of integer;'); interp_type(self.instance,'type TBox = record X1,Y1,X2,Y2: integer; end;'); interp_type(self.instance,'type TPoint = record x,y: integer; end;'); interp_type(self.instance,'type TPointArray = array of TPoint;'); ; interp_type(self.instance,'type T2DPointArray = array of array of TPoint;'); ; interp_type(self.instance,'type TPointArrayArray = T2DPointArray;'); interp_type(self.instance,'type TTarget_Exported = record int1,int2,int3,int4,int5,int6,int7,int8,int9,int10,int11,int12,int13,int14, int15:integer; end;'); interp_type(self.instance,'type TMask = record White, Black : TPointArray; WhiteHi,BlackHi : integer; W,H : integer;end;'); interp_type(self.instance,'type TDTMPointDef = record x, y, Color, Tolerance, AreaSize, AreaShape: integer; end;'); interp_type(self.instance,'type TDTMPointDefArray = Array Of TDTMPointDef;'); interp_type(self.instance,'type TDTM = record MainPoint: TDTMPointDef; SubPoints: TDTMPointDefArray; end;'); interp_type(self.instance,'type pDTM = record l: Integer;p: TPointArray;c, t, asz, ash: TIntegerArray; bp: Array Of Boolean; n: String; end;'); for i := 0 to high(ExportedMethods) do if ExportedMethods[i].FuncPtr <> nil then with ExportedMethods[i] do interp_meth(self.instance,FuncPtr,PChar(FuncDecl)); if interp_comp(instance) then begin psWriteln('Compiled Successfully in ' + IntToStr(GetTickCount - Starttime) + 'ms'); if CompileOnly then exit; if interp_run(instance) then psWriteln('Executed Successfully') else psWriteln('Execution Failed'); end else psWriteln('Compile Failed'); end; procedure TCPThread.Terminate; begin raise Exception.Create('Stopping Interpreter not yet implemented'); end; { TRTThread } procedure TRTThread.RTOnWrite(s: String); begin psWriteln(s); end; procedure TRTThread.RTOnError(s: String; ErrorType: TRutisErrorType); begin psWriteln(s); end; constructor TRTThread.Create(CreateSuspended: Boolean; TheSyncInfo: PSyncInfo; plugin_dir: string); begin inherited Create(CreateSuspended, TheSyncInfo, plugin_dir); RUTIS := TRutisEngine.Create; RUTIS.OnWrite:= @RTOnWrite; RUTIS.OnError:= @RTOnError; RUTIS.OptProcessTimer:= false; end; destructor TRTThread.Destroy; begin RUTIS.Free; inherited Destroy; end; procedure TRTThread.SetScript(script: string); begin RUTIS.ScriptCode.Text:= Script; end; procedure TRTThread.Execute; begin CurrThread := self; Starttime := lclintf.GetTickCount; try RUTIS.Compile; if not RUTIS.CompilerError then begin psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - Starttime) + ' ms.'); if CompileOnly then exit; RUTIS.Run; end else begin CurrThread.HandleError(RUTIS.Error.ELine+1,RUTIS.Error.EChrPos,-1,RUTIS.Error.Message,errCompile,''); psWriteln('Compiling failed.'); end; except on E : Exception do psWriteln('Exception in Script: ' + e.message); end; end; procedure TRTThread.Terminate; begin RUTIS.Stop; end; initialization PluginsGlob := TMPlugins.Create; libcpascal:= 0; finalization //PluginsGlob.Free; //Its a nice idea, but it will segfault... the program is closing anyway. end.