diff --git a/Projects/SAMufasaGUI/framescript.pas b/Projects/SAMufasaGUI/framescript.pas index fff6fc0..7f3b565 100644 --- a/Projects/SAMufasaGUI/framescript.pas +++ b/Projects/SAMufasaGUI/framescript.pas @@ -39,6 +39,7 @@ type ss_Paused: Means the script is currently in pause modus. ss_Stopping: Means we've asked PS-Script politely to stop the script (next time we press the stop button we won't be that nice). } + { TScriptFrame } TScriptFrame = class(TFrame) @@ -61,6 +62,7 @@ type OwnerPage : TPageControl; OwnerSheet : TTabSheet;//The owner TTabsheet -> For title setting public + ErrorData : TErrorData; //For threadsafestuff ScriptErrorLine : integer; //Highlight the error line! ScriptFile : string;//The path to the saved/opened file currently in the SynEdit StartText : string;//The text synedit holds upon start/open/save @@ -71,7 +73,7 @@ type FScriptState : TScriptState;//Stores the ScriptState, if you want the Run/Pause/Start buttons to change accordingly, acces through Form1 procedure undo; procedure redo; - procedure ErrorThread(ErrorAtLine,ErrorPosition : integer; ErrorStr : string; ErrorType : TErrorType); + procedure HandleErrorData; procedure MakeActiveScriptFrame; procedure ScriptThreadTerminate(Sender: TObject); constructor Create(TheOwner: TComponent); override; @@ -237,17 +239,43 @@ begin end; end; -procedure TScriptFrame.ErrorThread(ErrorAtLine, ErrorPosition: integer; - ErrorStr: string; ErrorType: TErrorType); +procedure TScriptFrame.HandleErrorData; +var + i : integer; begin + if ErrorData.Module <> '' then + begin; + if not FileExists(ErrorData.Module) then + ErrorData.Module := ErrorData.IncludePath + ErrorData.Module; + if not FileExists(ErrorData.Module) then + Writeln('ERROR comes from a non-existing file....') + else + begin + ErrorData.Module:= SetDirSeparators(ErrorData.Module);// Set it right ;-) + for i := 0 to Form1.Tabs.Count - 1 do + if lowercase(TMufasaTab(Form1.Tabs[i]).ScriptFrame.ScriptFile) = lowercase(ErrorData.Module) then + begin; + ErrorData.Module:= ''; + TMufasaTab(Form1.Tabs[i]).ScriptFrame.ErrorData := Self.ErrorData; + TMufasaTab(Form1.Tabs[i]).ScriptFrame.HandleErrorData; + Exit; + end; + Form1.AddTab; + Form1.LoadScriptFile(ErrorData.Module); + ErrorData.Module:= ''; + Form1.CurrScript.ErrorData := Self.ErrorData; + Form1.CurrScript.HandleErrorData; + exit; + end; + end; MakeActiveScriptFrame; - ScriptErrorLine:= ErrorAtLine; + ScriptErrorLine:= ErrorData.Line; SynEdit.Invalidate; - SynEdit.SelStart:= ErrorPosition; - if pos('error',lowercase(errorstr)) > 0 then - formWriteln(Format('%s at line %d',[errorstr,erroratline])) + SynEdit.SelStart:= ErrorData.Position; + if pos('error',lowercase(ErrorData.Error)) > 0 then + formWriteln(Format('%s at line %d',[ErrorData.Error,ErrorData.Line])) else - formWriteln(Format('Error: %s at line %d',[errorstr,erroratline])); + formWriteln(Format('Error: %s at line %d',[ErrorData.Error,ErrorData.Line])); end; procedure TScriptFrame.MakeActiveScriptFrame; diff --git a/Projects/SAMufasaGUI/testunit.pas b/Projects/SAMufasaGUI/testunit.pas index b64b889..3cff6e4 100644 --- a/Projects/SAMufasaGUI/testunit.pas +++ b/Projects/SAMufasaGUI/testunit.pas @@ -43,7 +43,7 @@ uses ocr, updateform, simbasettings; const - SimbaVersion = 413; + SimbaVersion = 423; type @@ -314,6 +314,7 @@ type property ScriptState : TScriptState read GetScriptState write SetScriptState; procedure SafeCallThread; function OpenScript : boolean; + function LoadScriptFile(filename : string) : boolean; function SaveCurrentScript : boolean; function SaveCurrentScriptAs : boolean; function CanExitOrOpen : boolean; @@ -540,7 +541,8 @@ begin DbgImgInfo.GetDebugBitmap:= @DebugImgForm.GetDbgBmp; DbgImgInfo.GetBitmap:= @DebugImgForm.GetDebugImage; ScriptThread.SetDbgImg(DbgImgInfo); - ScriptThread.OnError:=@ErrorThread; + ScriptThread.ErrorData:= @ErrorData; + ScriptThread.OnError:= @HandleErrorData; if ScriptFile <> '' then ScriptPath := ExtractFileDir(ScriptFile); @@ -1730,25 +1732,31 @@ begin; try Filter:= 'Mufasa Files|*.cogat;*.mufa;*.txt|Any files|*.*'; if Execute then - if FileExists(FileName) then - begin; - with CurrScript do - begin - SynEdit.Lines.LoadFromFile(FileName); - StartText := SynEdit.Lines.text; - ScriptName:= ExtractFileNameOnly(FileName); - WriteLn('Script name will be: ' + ScriptName); - ScriptFile:= FileName; - ScriptChanged := false; - RefreshTab(); - Result := True; - end; - end; + result := LoadScriptFile(filename); finally Free; end; end; +function TForm1.LoadScriptFile(FileName : string): boolean; +begin + if FileExists(FileName) then + begin; + with CurrScript do + begin + filename := SetDirSeparators(filename); + SynEdit.Lines.LoadFromFile(FileName); + StartText := SynEdit.Lines.text; + ScriptName:= ExtractFileNameOnly(filename); + WriteLn('Script name will be: ' + ScriptName); + ScriptFile:= FileName; + ScriptChanged := false; + RefreshTab(); + Result := True; + end; + end; +end; + function TForm1.SaveCurrentScript: boolean; begin with CurrScript do diff --git a/Units/MMLAddon/PSInc/Wrappers/other.inc b/Units/MMLAddon/PSInc/Wrappers/other.inc index 2cae9ee..2b5a5d7 100644 --- a/Units/MMLAddon/PSInc/Wrappers/other.inc +++ b/Units/MMLAddon/PSInc/Wrappers/other.inc @@ -84,6 +84,11 @@ begin; cap := true; end; +function psFormat(const fmt : string;const args : array of const) : string; +begin; + Result := Format(fmt,Args); +end; + function Distance(x1, y1, x2, y2: Integer): Integer; begin; Result := Round(Sqrt(Sqr(x2-x1) + Sqr(y2-y1))); diff --git a/Units/MMLAddon/PSInc/psexportedmethods.inc b/Units/MMLAddon/PSInc/psexportedmethods.inc index 64159c5..5a7cd15 100644 --- a/Units/MMLAddon/PSInc/psexportedmethods.inc +++ b/Units/MMLAddon/PSInc/psexportedmethods.inc @@ -22,7 +22,7 @@ } AddFunction(@ThreadSafeCall,'function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;'); -AddFunction(@psWriteln,'procedure writeln(s : string);'); +AddFunction(nil,'procedure writeln(s : string);'); //We use special function for this { DTM } SetCurrSection('DTM'); @@ -91,11 +91,13 @@ AddFunction(@DisplayDebugImgWindow,'procedure DisplayDebugImgWindow(w,h : intege AddFunction(@DrawBitmapDebugImg,'procedure DrawBitmapDebugImg(bmp : integer);'); AddFunction(@GetDebugBitmap,'function GetDebugBitmap : integer;'); AddFunction(@Random,'function Random(Int : integer): integer;'); +AddFunction(@NewThreadCall,'function NewThreadCall(procname : string) : cardinal'); {string} AddFunction(@Capitalize,'function Capitalize(str : string) : string;'); +AddFunction(@psFormat,'function Format(const fmt : string;const args : array of const) : string;'); {web} SetCurrSection('Web'); diff --git a/Units/MMLAddon/colourpicker.pas b/Units/MMLAddon/colourpicker.pas index 775eeb4..408b719 100644 --- a/Units/MMLAddon/colourpicker.pas +++ b/Units/MMLAddon/colourpicker.pas @@ -111,12 +111,14 @@ begin { Disable both of the color pick buttons } w := 0; h := 0; + { If the target window isn't valid (closed etc), make the destkop the new window} if not Self.Window.TargetValid then self.Window.SetDesktop; + Input := TMInput.Create(Self.Window);//For the correct x,y values + {Desktop is needed for the whole picture} Desktop := TMWindow.Create; Desktop.SetDesktop; - Input := TMInput.Create(Self.Window); Desktop.GetDimensions(w, h); Application.MainForm.Enabled := False; @@ -126,9 +128,6 @@ begin ScreenForm := TForm.Create(Application.MainForm); InfoForm := TForm.Create(ScreenForm); - - - { Initialize the form that will hold the client image } ScreenForm.Caption := 'SimbaColourPicker'; { Set the form's dimensions to match that of the screen } diff --git a/Units/MMLAddon/mmlpsthread.pas b/Units/MMLAddon/mmlpsthread.pas index e1f4427..d21bb75 100644 --- a/Units/MMLAddon/mmlpsthread.pas +++ b/Units/MMLAddon/mmlpsthread.pas @@ -23,6 +23,7 @@ unit mmlpsthread; +{$Define PS_USESSUPPORT} {$mode objfpc}{$H+} interface @@ -52,7 +53,15 @@ type end; PSyncInfo = ^TSyncInfo; TErrorType = (errRuntime,errCompile); - TOnError = procedure (ErrorAtLine,ErrorPosition : integer; ErrorStr : string; ErrorType : TErrorType) of object; + TOnError = procedure of object; + TErrorData = record + Line,Position : integer; + Error : string; + ErrType : TErrorType; + Module : string; + IncludePath : string; + end; + PErrorData = ^TErrorData; TExpMethod = record Section : string; FuncDecl : string; @@ -64,11 +73,15 @@ type 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); private ScriptPath, AppPath, IncludePath, PluginPath, FontPath: string; + procedure HandleError(ErrorAtLine,ErrorPosition : integer; ErrorStr : string; ErrorType : TErrorType; ErrorModule : string); protected //DebugTo : TMemo; DebugTo: TWritelnProc; @@ -89,6 +102,7 @@ type Client : TClient; StartTime : LongWord; SyncInfo : PSyncInfo; //We need this for callthreadsafe + ErrorData : PErrorData; //We need this for thread-safety etc property OnError : TOnError read FOnError write FOnError; procedure LoadMethods; class function GetExportedMethods : TExpMethodArr; @@ -107,7 +121,7 @@ uses {$ifdef mswindows}windows,{$endif} uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms, uPSC_extctrls, //Compile-libs - + uPSUtils, uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms, uPSR_extctrls, //Runtime-libs Graphics, //For Graphics types @@ -122,23 +136,31 @@ uses {Some General PS Functions here} procedure psWriteln(str : string); -//{$IFDEF WINDOWS} begin if Assigned(CurrThread.DebugTo) then CurrThread.DebugTo(str) else writeln(str); - {if CurrThread.DebugTo <> nil then - begin; - CurrThread.DebugTo.lines.add(str); - CurrThread.DebugTo.Refresh; - end; } end; -//{$ELSE} -//begin -//writeln(str); -//end; -//{$ENDIF} + +function writeln_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=true; + arr:=NewTPSVariantIFC(Stack[Stack.Count-1],false); + case arr.aType.BaseType of + btString,btChar : psWriteln(stack.GetString(-1)); + btU8, btS8, btU16, btS16, btU32, btS32: psWriteln(inttostr(stack.GetInt(-1))); + {$IFNDEF PS_NOINT64}btS64 : psWriteln(IntToStr(stack.GetInt64(-1))); {$ENDIF} + else Result:=false; + end; +end; + +function NewThreadCall(Procname : string) : Cardinal; +begin; + result := CurrThread.PSScript.Exec.GetVar(Procname); +end; function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; begin; @@ -188,6 +210,7 @@ begin PSScript.OnCompile:= @OnCompile; PSScript.OnCompImport:= @OnCompImport; PSScript.OnExecImport:= @OnExecImport; + PSScript.OnFindUnknownFile:=@PSScriptFindUnknownFile; OnError:= nil; // Set some defines {$I PSInc/psdefines.inc} @@ -234,6 +257,12 @@ procedure TMMLPSThread.OnProcessDirective(Sender: TPSPreProcessor; begin end; +function TMMLPSThread.PSScriptFindUnknownFile(Sender: TObject; + const OrginFileName: string; var FileName, Output: string): Boolean; +begin + Writeln(OrginFileName + '-' + Output + '-' + FileName); +end; + procedure TMMLPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor; Parser: TPSPascalPreProcessorParser; const Active: Boolean; const DirectiveName, DirectiveParam: string; var Continue: Boolean); @@ -259,6 +288,20 @@ begin Continue:= True; end; +procedure TMMLPSThread.HandleError(ErrorAtLine, ErrorPosition: integer; + ErrorStr: string; ErrorType: TErrorType; ErrorModule : string); +begin + if FOnError = nil then + exit; + ErrorData^.Line:= ErrorAtLine; + ErrorData^.Position:= ErrorPosition; + ErrorData^.Error:= ErrorStr; + ErrorData^.ErrType:= ErrorType; + ErrorData^.Module:= ErrorModule; + ErrorData^.IncludePath:= IncludePath; + CurrThread.Synchronize(FOnError); +end; + procedure TMMLPSThread.OnCompile(Sender: TPSScript); @@ -278,7 +321,8 @@ begin //Export all the methods for i := 0 to high(ExportedMethods) do - PSScript.AddFunction(ExportedMethods[i].FuncPtr,ExportedMethods[i].FuncDecl); + if ExportedMethods[i].FuncPtr <> nil then + PSScript.AddFunction(ExportedMethods[i].FuncPtr,ExportedMethods[i].FuncDecl); end; function TMMLPSThread.RequireFile(Sender: TObject; @@ -362,6 +406,12 @@ begin SIRegister_Forms(x); SIRegister_ExtCtrls(x); SIRegister_Mufasa(x); + with x.AddFunction('procedure writeln;').decl do + with AddParam do + begin + OrgName:= 'x'; + Mode:= pmIn; + end; end; procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec; @@ -375,6 +425,7 @@ begin RIRegister_Forms(x); RIRegister_ExtCtrls(x); RIRegister_Mufasa(x); + se.RegisterFunctionName('WRITELN',@Writeln_,nil,nil); end; procedure TMMLPSThread.OutputMessages; @@ -390,7 +441,7 @@ begin b := True; if OnError <> nil then with PSScript.CompilerMessages[l] do - OnError(Row, Pos, MessageToString,errCompile) + HandleError(Row, Pos, MessageToString,errCompile, ModuleName) else psWriteln(PSScript.CompilerErrorToStr(l) + ' at line ' + inttostr(PSScript.CompilerMessages[l].Row)); end else @@ -411,10 +462,10 @@ begin psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - Starttime) + ' ms.'); // if not (ScriptState = SCompiling) then if not PSScript.Execute then - begin - if OnError <> nil then - OnError(PSScript.ExecErrorRow,PSScript.ExecErrorPosition,PSScript.ExecErrorToString,errRuntime); - end else psWriteln('Succesfully executed'); + HandleError(PSScript.ExecErrorRow,PSScript.ExecErrorPosition,PSScript.ExecErrorToString, + errRuntime, PSScript.ExecErrorFileName) + else + psWriteln('Succesfully executed'); end else begin OutputMessages;