1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-08-13 16:53:59 -04:00

RUTIS to the source

This commit is contained in:
Raymond 2010-08-20 17:21:43 +02:00
parent 1eba2fdb8f
commit 9d162c1bfb
21 changed files with 16279 additions and 0 deletions

View File

@ -0,0 +1,86 @@
{$IFDEF FPC}
{$DEFINE DELPHI_2006}
{$DEFINE DELPHI_2006_UP}
{$DEFINE DELPHI_2005_UP}
{$DEFINE DELPHI_8_UP}
{$DEFINE DELPHI_7_UP}
{$DEFINE DELPHI_6_UP}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_3_UP}
{$ENDIF}
{$IFDEF VER180}
{$DEFINE DELPHI_2006}
{$DEFINE DELPHI_2006_UP}
{$DEFINE DELPHI_2005_UP}
{$DEFINE DELPHI_8_UP}
{$DEFINE DELPHI_7_UP}
{$DEFINE DELPHI_6_UP}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_3_UP}
{$ENDIF}
{$IFDEF VER170}
{$DEFINE DELPHI_2005}
{$DEFINE DELPHI_2005_UP}
{$DEFINE DELPHI_8_UP}
{$DEFINE DELPHI_7_UP}
{$DEFINE DELPHI_6_UP}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_3_UP}
{$ENDIF}
{$IFDEF VER160}
{$DEFINE DELPHI_8}
{$DEFINE DELPHI_8_UP}
{$DEFINE DELPHI_7_UP}
{$DEFINE DELPHI_6_UP}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_3_UP}
{$ENDIF}
{$IFDEF VER150}
{$DEFINE DELPHI_7}
{$DEFINE DELPHI_7_UP}
{$DEFINE DELPHI_6_UP}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_3_UP}
{$ENDIF}
{$IFDEF VER140}
{$DEFINE DELPHI_6}
{$DEFINE DELPHI_6_UP}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_3_UP}
{$ENDIF}
{$IFDEF VER130}
{$DEFINE DELPHI_5}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_3_UP}
{$ENDIF}
{$IFDEF VER120}
{$DEFINE DELPHI_4}
{$DEFINE DELPHI_4_UP}
{$DEFINE DELPHI_3_UP}
{$ENDIF}
{$IFDEF VER110}
{$DEFINE DELPHI_3}
{$DEFINE DELPHI_3_UP}
{$ENDIF}
{$IFDEF VER100}
{$DEFINE DELPHI_3}
{$DEFINE DELPHI_3_UP}
{$ENDIF}

View File

@ -0,0 +1,204 @@
unit File_Manager;
interface
uses SysUtils;
Type
TFileItem = Record
Item : Pointer;
Name : String;
FName: String;
End;
TFileLoadFunc = Function(FileName: String; var Item: Pointer): Boolean;
TFreeDataFunc = procedure(Item: Pointer);
TObjFileLoadFunc = Function(FileName: String; var Item: Pointer): Boolean of Object;
TObjFreeDataFunc = procedure(Item: Pointer) of Object;
TFileManager = class
constructor Create;
Destructor Destroy; override;
private
Function SearchFileInPath(Name, Path: String): String;
Function GetItem(Name: String): Pointer;
Function IsFail(Name: String): Boolean;
public
fItems : Array Of TFileItem;
Paths : Array Of String;
FileExts : Array Of String;
NotFoundFiles : Array Of String;
LoadFunc : TFileLoadFunc;
FreeFunc : TFreeDataFunc;
ObjLoadFunc : TObjFileLoadFunc;
ObjFreeFunc : TObjFreeDataFunc;
property Items[Name: string]: Pointer read GetItem;
Procedure Clear;
Procedure AddExtension(Ext: String);
Procedure AddPath(Path: String);
Function AddItem(Name: String): Boolean;
Function SearchFile(Name: String): String;
Function IndexOf(Name: String): Integer;
end;
Implementation
//==============================================================================
//==================== File Procedures =========================================
//==============================================================================
constructor TFileManager.Create;
begin
//AddPath(ExtractFileDir(ParamStr(0)));
end;
Destructor TFileManager.Destroy;
begin
Clear;
end;
Procedure TFileManager.Clear;
var i: Integer;
begin
If Assigned(FreeFunc) then
for i := 0 to high(fItems) do
FreeFunc(fItems[i].Item);
If Assigned(ObjFreeFunc) then
for i := 0 to high(fItems) do
ObjFreeFunc(fItems[i].Item);
SetLength(fItems, 0);
SetLength(NotFoundFiles, 0);
end;
Function TFileManager.SearchFileInPath(Name, Path: String): String;
Var SR: TSearchRec;
i: Integer;
Begin
If FindFirst(Path + Name + '.*', faAnyFile, SR) = 0 Then
Begin
Repeat
If (SR.Name <> '.') And (SR.Name <> '..') And Not ((sr.Attr And faDirectory) <> 0) Then
Begin
Result := lowerCase(ExtractFileExt(SR.Name));
For i := 0 To high(FileExts) Do
If Result = FileExts[i] Then
Begin
Result := Path + SR.Name;
exit;
End;
End;
Until FindNext(SR) <> 0;
FindClose(SR);
End;
Result := '';
End;
Function TFileManager.SearchFile(Name: String): String;
Var i: Integer;
Begin
For i := 0 To high(Paths) Do
Begin
If length(Paths[i]) = 0 then Continue;
If Paths[i][length(Paths[i])] <> '\' Then Paths[i] := Paths[i] + '\';
Result := SearchFileInPath(Name, Paths[i]);
If Result <> '' Then exit;
End;
End;
Procedure TFileManager.AddPath(Path: String);
Begin
setLength(Paths, length(Paths) + 1);
Paths[high(Paths)] := Path;
End;
Procedure TFileManager.AddExtension(Ext: string);
begin
If Ext[1] <> '.' then
Ext := '.' + Ext;
SetLength(FileExts,Length(FileExts)+1);
FileExts[high(FileExts)] := LowerCase(Ext);
end;
Function TFileManager.IndexOf(Name: String): Integer;
Var i: Integer;
Begin
Name := LowerCase(Name);
Result := -1;
For i := 0 To high(fItems) Do
If fItems[i].Name = Name Then
Begin
Result := i;
exit;
End;
End;
Function TFileManager.IsFail(Name: String): Boolean;
Var i: Integer;
Begin
Result := true;
For i := 0 To length(NotFoundFiles) - 1 Do
If NotFoundFiles[i] = Name Then exit;
Result := false;
End;
Function TFileManager.AddItem(Name: String): Boolean;
Var fn: String;
Begin
Name := LowerCase(Name);
Result := false;
If (Assigned(LoadFunc) or Assigned(ObjLoadFunc)) and not
(Assigned(FreeFunc) or Assigned(ObjFreeFunc)) then exit;
If IsFail(Name) Then exit;
fn := SearchFile(Name);
If fn = '' Then
Begin
setLength(NotFoundFiles, length(NotFoundFiles) + 1);
NotFoundFiles[high(NotFoundFiles)] := Name;
exit;
End;
setLength(fItems, length(fItems) + 1);
fItems[high(fItems)].Name := Name;
fItems[high(fItems)].FName := FN;
If Assigned(LoadFunc) then
begin
If Not LoadFunc(fn, fItems[high(fItems)].Item) Then
Begin
setLength(fItems, length(fItems)-1);
setLength(NotFoundFiles, length(NotFoundFiles) + 1);
NotFoundFiles[high(NotFoundFiles)] := Name;
exit;
End;
end
else
If Assigned(ObjLoadFunc) then
If Not ObjLoadFunc(fn, fItems[high(fItems)].Item) Then
Begin
setLength(fItems, length(fItems)-1);
setLength(NotFoundFiles, length(NotFoundFiles) + 1);
NotFoundFiles[high(NotFoundFiles)] := Name;
exit;
End;
Result := true;
End;
Function TFileManager.GetItem(Name: String): Pointer;
Var index: Integer;
Begin
Result := nil;
If (Assigned(LoadFunc) or Assigned(ObjLoadFunc)) and not
(Assigned(FreeFunc) or Assigned(ObjFreeFunc)) then exit;
Name := LowerCase(Name);
index := IndexOf(Name);
If Index>=0 then
begin
Result := fItems[index].Item;
exit;
end;
If not AddItem(Name) Then exit;
index := high(fItems);
Result := fItems[index].Item;
End;
End.

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,50 @@
Unit RUTIS_Errors;
Interface
Resourcestring
ERR_UNEXPECTED_ERROR = 'E000: Unexpected error occurred. Please contect the support!';
ERR_SCANNER_UNEXPECTED_CHAR = 'E010: Unexpected char found in code';
ERR_UNIT_NOT_FOUND = 'E011: Unit ''%s'' not found';
ERR_FILENAME_NOT_UNITNAME = 'E012: Name of the unit is not the same as the filename';
ERR_NOT_IMPLEMENTED_YET = 'E013: This function is not implemented in RUTIS at this time - Please wait for me to implement it';
ERR_NOT_AVAILABLE = 'E014: This function is not available in this Version of RUTIS';
ERR_NOT_AVAILABLE_C_TYPE = 'E015: This type of const is not available in RUTIS at this time';
ERR_UNKNOWN_IDENT = 'E020: Unknown Identifier ''%s''';
ERR_INDENT_REDEFINED = 'E021: Identifier redefined ''%s''';
ERR_UNKNOWN_TYPE = 'E022: Unknown type ''%s''';
ERR_UNALLOWED_STATEMENT = 'E023: Unallowed Statement';
ERR_EXPECTED_FOUND = 'E030: ''%s'' expected, ''%s'' found instead';
ERR_NEEDED_FOUND = 'E031: ''%s'' needed, ''%s'' found instead';
ERR_OP_OR_SEMI_EXPECTED = 'E032: Operator or semicolon expected';
ERR_VAR_CONSTANT_EXPECTED = 'E033: Variable or Constant expected';
ERR_VAR_EXPECTED = 'E034: Variable expected';
ERR_REC_EXPECTED = 'E035: Record expected';
ERR_ARRAY_EXPECTED = 'E036: Array expected';
ERR_PROCEDURE_EXPECTED = 'E037: Procedure expected';
ERR_STRING_EXPECTED = 'E038: String expected';
ERR_TYPE_EXPECTED = 'E039: Type expected';
ERR_EXPECTED = 'E040: ''%s'' expected';
ERR_NOT_ENOUGH_PARAMETERS = 'E070: Not enough actual parameters';
ERR_TOO_MANY_PARAMETERS = 'E071: Too many parameters';
ERR_ONLY_PARAMLESS_PROCS = 'E072: Only parameterless procedures are allowed';
ERR_NO_CONST_ALLOWED = 'E073: No constant allowed here';
ERR_NO_OVERLOADED_FUNC = 'E073: There is no overloaded function with these parameters';
ERR_UNALLOWED_STRING_ACTION = 'E080: Unallowed String action';
ERR_POINTER_ONLY_FOR_VAR = 'E081: Pointers can only be created for vars';
ERR_INCOMPATIBLE_TYPES = 'E090: Incompatible types ''%s'' and ''%s''';
ERR_UNALLOWED_DATATYPE = 'E091: Unallowed type';
ERR_CODE_AFTER_PROGRAM_END = 'W001: Code after Program END. is ignored';
ERR_CODE_AFTER_UNIT_END = 'W002: Code after Unit END. is ignored';
Implementation
End.

View File

@ -0,0 +1,82 @@
# hash value = 257594117
rutis_errors.err_scanner_unexpected_char='E000: Unexpected char found in '+
'code'
# hash value = 23719812
rutis_errors.err_unallowed_statement='E002: Unallowed Statement'
# hash value = 248294455
rutis_errors.err_unknown_ident='E003: Unknown Identifier '#39'%s'#39
# hash value = 195210244
rutis_errors.err_expected_found='E010: '#39'%s'#39' expected, '#39'%s'#39+
' found instead'
# hash value = 2386388
rutis_errors.err_op_or_semi_expected='E011: Operator or semicolon expecte'+
'd'
# hash value = 184443412
rutis_errors.err_var_constant_expected='E012: Variable or Constant expect'+
'ed'
# hash value = 80568548
rutis_errors.err_var_expected='E013: Variable expected'
# hash value = 25156852
rutis_errors.err_rec_expected='E014: Record expected'
# hash value = 95149172
rutis_errors.err_array_expected='E015: Array expected'
# hash value = 90164228
rutis_errors.err_procedure_expected='E016: Procedure expected'
# hash value = 50540276
rutis_errors.err_string_expected='E017: String expected'
# hash value = 51366068
rutis_errors.err_expected='E019: %s expected'
# hash value = 159220885
rutis_errors.err_no_const_allowed='E020: No Constant allowed here'
# hash value = 3854691
rutis_errors.err_not_enough_parameters='E030: Not enough actual parameter'+
's'
# hash value = 50133859
rutis_errors.err_too_many_parameters='E031: Too many parameters'
# hash value = 62647742
rutis_errors.err_unallowed_string_action='E040: Unallowed String action'
# hash value = 255120181
rutis_errors.err_unallowed_datatype='E041: Unallowed Datatype'
# hash value = 91098180
rutis_errors.err_code_after_program_end='W001: Code after Program END. is'+
' ignored'
# hash value = 102976020
rutis_errors.err_code_after_unit_end='W002: Code after Unit END. is ignor'+
'ed'

1482
Units/RUTIS/Rutis_Defs.pas Normal file

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,429 @@
Unit Rutis_EXT_Canvas;
Interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, ComCtrls, ExtCtrls,
Rutis_Stack, Rutis_Engine, Rutis_Defs;
Type
TUniversalCanvas = Class(TControlCanvas)
Protected
fDCHandle : HWND;
Public
Destructor Destroy; Override;
Procedure ReleaseTarget;
Procedure SetTargetDC(DC : HDC);
Procedure SetTargetHandle(AHandle : HWND);
Procedure SetTargetControl(AControl : TControl);
End;
Var
RC_Buffer : TBitmap;
RC_DrawCanvas : TCanvas;
RC_TargetCanvas : TCanvas;
RC_DoubleBuffered : Boolean;
RC_Width,
RC_Height : Integer;
RC_BGColor : TColor;
Procedure RC_SetTargetDC(DC : HDC);
Procedure RC_SetTargetHandle(Handle : HWND);
Procedure RC_SetTargetCanvas(Canvas : TCanvas);
Procedure RC_SetTargetControl(Control : TControl);
Procedure RC_Repaint;
Procedure RegisterEXTMethods(Engine : TRutisEngine);
Implementation
Var
RC_DCCanvas : TUniversalCanvas;
Type
PControl = ^TControl;
//==============================================================================
//==============================================================================
{ TUniversalCanvas }
Destructor TUniversalCanvas.Destroy;
Begin
ReleaseTarget;
Inherited;
End;
Procedure TUniversalCanvas.ReleaseTarget;
Begin
If HandleAllocated Then
Begin
If (fDCHandle <> 0) Then
ReleaseDC(Handle, fDCHandle);
Handle := 0;
fDCHandle := 0;
End;
End;
Procedure TUniversalCanvas.SetTargetDC(DC : HDC);
Begin
ReleaseTarget;
If DC = 0 Then exit;
Handle := DC;
End;
Procedure TUniversalCanvas.SetTargetHandle(AHandle : HWND);
Begin
ReleaseTarget;
//If AHandle = 0 then exit;
fDCHandle := AHandle;
Try
Handle := GetDC(fDCHandle);
Except
Handle := 0;
fDCHandle := 0;
End;
End;
Procedure TUniversalCanvas.SetTargetControl(AControl : TControl);
Begin
ReleaseTarget;
If AControl <> nil Then
Control := AControl;
End;
//==============================================================================
//==============================================================================
Procedure RC_SetTargetDC(DC : HDC);
Begin
RC_DCCanvas.SetTargetDC(DC);
RC_TargetCanvas := RC_DCCanvas;
If RC_DoubleBuffered Then
RC_DrawCanvas := RC_Buffer.Canvas
Else
RC_DrawCanvas := RC_TargetCanvas;
End;
Procedure RC_SetTargetHandle(Handle : HWND);
Begin
RC_DCCanvas.SetTargetHandle(Handle);
RC_TargetCanvas := RC_DCCanvas;
If RC_DoubleBuffered Then
RC_DrawCanvas := RC_Buffer.Canvas
Else
RC_DrawCanvas := RC_TargetCanvas;
End;
Procedure RC_SetTargetControl(Control : TControl);
Begin
If (Control is TImage) Then
Begin
RC_TargetCanvas := TImage(Control).Canvas;
RC_DCCanvas.ReleaseTarget;
End
Else
Begin
RC_DCCanvas.SetTargetControl(Control);
RC_TargetCanvas := RC_DCCanvas;
End;
If RC_DoubleBuffered Then
RC_DrawCanvas := RC_Buffer.Canvas
Else
RC_DrawCanvas := RC_TargetCanvas;
End;
Procedure RC_SetTargetCanvas(Canvas : TCanvas);
Begin
RC_DCCanvas.ReleaseTarget;
RC_TargetCanvas := Canvas;
If RC_DoubleBuffered Then
RC_DrawCanvas := RC_Buffer.Canvas
Else
RC_DrawCanvas := RC_TargetCanvas;
End;
Procedure RC_Repaint;
Begin
If RC_DoubleBuffered Then
RC_TargetCanvas.Draw(0, 0, RC_Buffer);
End;
//==============================================================================
//==============================================================================
Procedure _CanvasDC(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_SetTargetDC(PCardinal(Params^[0].Data)^);
End;
Procedure _CanvasHandle(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_SetTargetHandle(PCardinal(Params^[0].Data)^);
End;
Procedure _CanvasControl(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_SetTargetControl(PControl(Params^[0].Data)^);
End;
Procedure _CanvasDoubleBuffered(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DoubleBuffered := PBoolean(Params^[0].Data)^;
If RC_DoubleBuffered Then
RC_DrawCanvas := RC_Buffer.Canvas
Else
RC_DrawCanvas := RC_TargetCanvas;
End;
Procedure _CanvasClear(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
rect : TRect;
TmpColor : TColor;
Begin
// RC_BGColor := RC_DrawCanvas.Brush.Color;
// If RC_DoubleBuffered Then
// Begin
// //RC_Buffer.Width := 0;
// //RC_Buffer.Width := RC_Width;
// rect := RC_Buffer.Canvas.ClipRect;
// inc(rect.Right);
// inc(rect.Bottom);
// TmpColor := RC_Buffer.Canvas.Pen.Color;
// RC_Buffer.Canvas.Pen.Color := RC_BGColor;
// RC_Buffer.Canvas.FillRect(rect);
// RC_Buffer.Canvas.Pen.Color := TmpColor;
// End
// Else
// Begin
// rect := RC_TargetCanvas.ClipRect;
// inc(rect.Right);
// inc(rect.Bottom);
// RC_TargetCanvas.Brush.Color := RC_BGColor;
// RC_TargetCanvas.Pen.Color := RC_BGColor;
// RC_TargetCanvas.FillRect(rect);
// End;
RC_BGColor := RC_DrawCanvas.Brush.Color;
TmpColor := RC_DrawCanvas.Pen.Color;
rect := RC_DrawCanvas.ClipRect;
Inc(rect.Right);
Inc(rect.Bottom);
RC_DrawCanvas.Pen.Color := RC_BGColor;
RC_DrawCanvas.FillRect(rect);
RC_DrawCanvas.Pen.Color := TmpColor;
End;
Procedure _CanvasSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
AColor : TColor;
Begin
RC_Width := PInteger(Params^[0].Data)^;
RC_Height := PInteger(Params^[1].Data)^;
//CorrectBufferSize(RC_Width, RC_Height);
If RC_DoubleBuffered Then
With RC_Buffer Do
Begin
AColor := Canvas.Brush.Color;
Canvas.Brush.Color := RC_BGColor;
If (RC_Width <> Width) Then Width := RC_Width;
If (RC_Height <> Height) Then Height := RC_Height;
Canvas.Brush.Color := AColor;
End;
End;
Procedure _CanvasDisplay(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
If RC_DoubleBuffered Then
RC_TargetCanvas.Draw(0, 0, RC_Buffer);
End;
//==============================================================================
Procedure _BrushSolid(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DrawCanvas.Brush.Style := bsSolid;
End;
Procedure _BrushClear(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DrawCanvas.Brush.Style := bsClear;
End;
Procedure _PenColor(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DrawCanvas.Pen.Color := PColor(Params^[0].Data)^;
End;
Procedure _BrushColor(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DrawCanvas.Brush.Color := PColor(Params^[0].Data)^;
End;
Procedure _PenColorRGB(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DrawCanvas.Pen.Color := rgb(PByte(Params^[0].Data)^, PByte(Params^[1].Data)^, PByte(Params^[2].Data)^);
End;
Procedure _BrushColorRGB(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DrawCanvas.Brush.Color := rgb(PByte(Params^[0].Data)^, PByte(Params^[1].Data)^, PByte(Params^[2].Data)^);
End;
Procedure _PenWidth(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DrawCanvas.Pen.Width := PInteger(Params^[0].Data)^;
End;
Procedure _Rectangle(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var x1, y1, x2, y2 : Integer;
Begin
x1 := PInteger(Params^[0].Data)^;
y1 := PInteger(Params^[1].Data)^;
x2 := PInteger(Params^[2].Data)^;
y2 := PInteger(Params^[3].Data)^;
//CorrectBufferSize(Max(x1, x2), Max(y1, y2));
RC_DrawCanvas.Rectangle(x1, y1, x2, y2);
End;
Procedure _Ellipse(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var x1, y1, x2, y2 : Integer;
Begin
x1 := PInteger(Params^[0].Data)^;
y1 := PInteger(Params^[1].Data)^;
x2 := PInteger(Params^[2].Data)^;
y2 := PInteger(Params^[3].Data)^;
//CorrectBufferSize(Max(x1, x2), Max(y1, y2));
RC_DrawCanvas.Ellipse(x1, y1, x2, y2);
End;
Procedure _MoveTo(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var x1, y1 : Integer;
Begin
x1 := PInteger(Params^[0].Data)^;
y1 := PInteger(Params^[1].Data)^;
//CorrectBufferSize(x1,y1);
RC_DrawCanvas.MoveTo(x1, y1);
End;
Procedure _LineTo(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var x1, y1 : Integer;
Begin
x1 := PInteger(Params^[0].Data)^;
y1 := PInteger(Params^[1].Data)^;
//CorrectBufferSize(x1,y1);
RC_DrawCanvas.LineTo(x1, y1);
End;
Procedure _TextOut(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var x1, y1 : Integer;
Begin
x1 := PInteger(Params^[0].Data)^;
y1 := PInteger(Params^[1].Data)^;
With RC_DrawCanvas Do
Begin
//CorrectBufferSize(x1 + TextHeight(Params^[2]), y1 + TextWidth(Params^[2]));
RC_DrawCanvas.Font.Color := RC_DrawCanvas.Pen.Color;
TextOut(x1, y1, PAnsiString(Params^[2].Data)^);
End;
End;
Procedure _TextSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DrawCanvas.Font.Size := GetPInteger(Params^[0].Data);
End;
Procedure _GetPixel(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PCardinal(Result^.Data)^ := Cardinal(RC_DrawCanvas.Pixels[PInteger(Params^[0].Data)^,
PInteger(Params^[1].Data)^]);
End;
Procedure _SetPixel(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
RC_DrawCanvas.Pixels[PInteger(Params^[0].Data)^,
PInteger(Params^[1].Data)^] := TColor(PCardinal(Params^[2].Data)^);
End;
//==============================================================================
//==============================================================================
Procedure RegisterEXTMethods(Engine : TRutisEngine);
Begin
OutputDebugString(PChar('Rutis_EXT_Canvas.RegisterEXTMethods - Registering RUTIS Canvas Support'));
//==============================================================================
//====================== CANVAS ================================================
//==============================================================================
Engine.RegExtMethod('CanvasControl',{$IfDef FPC}@{$EndIf}_CanvasControl, ['TControl'], '',
'Set the Control for the Canvas');
Engine.RegExtMethod('CanvasHandle',{$IfDef FPC}@{$EndIf}_CanvasHandle, ['HWND'], '',
'Set the Handle for the Canvas' + sLineBreak +
'The needed Device Context will be retrived automatically');
Engine.RegExtMethod('CanvasDC',{$IfDef FPC}@{$EndIf}_CanvasDC, ['HDC'], '',
'Set the DeviceContext for the Canvas' + sLineBreak +
'You need to get the DC with GetDC first' + sLineBreak +
'CanvasDC should normally not be used - use CanvasHandle instead');
Engine.RegExtMethod('CanvasSize',{$IfDef FPC}@{$EndIf}_CanvasSize, ['Integer', 'Integer'], '',
'Set up the Buffer-Size' + sLineBreak +
'Only needed when using DoubleBuffered-ON');
Engine.RegExtMethod('CanvasDisplay',{$IfDef FPC}@{$EndIf}_CanvasDisplay, [], '',
'Displays the Buffer' + sLineBreak +
'Only needed when using DoubleBuffered-ON');
Engine.RegExtMethod('CanvasClear',{$IfDef FPC}@{$EndIf}_CanvasClear, [], '',
'Clears the painted content');
Engine.RegExtMethod('CanvasDoubleBuffered',{$IfDef FPC}@{$EndIf}_CanvasDoubleBuffered, ['Boolean'], '',
'If set, all content will be painted into a separate Buffer' + sLineBreak +
'You will need to set up the Buffer with CanvasSize and CanvasClear first and' + sLineBreak +
'you have to call CanvasDisplay to show the painted content');
Engine.RegExtMethod('MoveTo',{$IfDef FPC}@{$EndIf}_Moveto, ['Integer', 'Integer'], '');
Engine.RegExtMethod('LineTo',{$IfDef FPC}@{$EndIf}_Lineto, ['Integer', 'Integer'], '');
Engine.RegExtMethod('Rectangle',{$IfDef FPC}@{$EndIf}_Rectangle, ['Integer', 'Integer', 'Integer', 'Integer'], '');
Engine.RegExtMethod('Ellipse',{$IfDef FPC}@{$EndIf}_Ellipse, ['Integer', 'Integer', 'Integer', 'Integer'], '');
Engine.RegExtMethod('TextOut',{$IfDef FPC}@{$EndIf}_TextOut, ['Integer', 'Integer', 'String'], '');
Engine.RegExtMethod('TextSize',{$IfDef FPC}@{$EndIf}_TextSize, ['Integer'], '');
Engine.RegExtMethod('PenColorRGB',{$IfDef FPC}@{$EndIf}_PenColorRGB, ['Byte', 'Byte', 'Byte'], '');
Engine.RegExtMethod('BrushColorRGB',{$IfDef FPC}@{$EndIf}_BrushColorRGB, ['Byte', 'Byte', 'Byte'], '');
Engine.RegExtMethod('PenColor',{$IfDef FPC}@{$EndIf}_PenColor, ['Integer'], '');
Engine.RegExtMethod('BrushColor',{$IfDef FPC}@{$EndIf}_BrushColor, ['Integer'], '');
Engine.RegExtMethod('BrushSolid',{$IfDef FPC}@{$EndIf}_BrushSolid, [], '');
Engine.RegExtMethod('BrushClear',{$IfDef FPC}@{$EndIf}_BrushClear, [], '');
Engine.RegExtMethod('PenWidth',{$IfDef FPC}@{$EndIf}_PenWidth, ['Integer'], '');
Engine.RegExtMethod('GetPixel',{$IfDef FPC}@{$EndIf}_GetPixel, ['Integer', 'Integer'], 'Integer');
Engine.RegExtMethod('SetPixel',{$IfDef FPC}@{$EndIf}_SetPixel, ['Integer', 'Integer', 'Integer'], '');
OutputDebugString(PChar('Rutis_EXT_Canvas.RegisterEXTMethods - Successfully registered RUTIS Canvas Support'));
End;
//==============================================================================
//==============================================================================
Initialization
RC_Buffer := TBitmap.Create;
RC_DCCanvas := TUniversalCanvas.Create;
RC_DoubleBuffered := True;
RC_TargetCanvas := RC_Buffer.Canvas;
Finalization
RC_DCCanvas.Free;
RC_Buffer.Free;
End.

View File

@ -0,0 +1,603 @@
Unit Rutis_EXT_Common;
Interface
{$i Delphi_Versions.inc}
{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF}
Uses
Windows, Forms, Math, Dialogs, SysUtils,
Rutis_Stack, Rutis_Defs, Rutis_Classes, TypInfo;
Type
PObject = ^TObject;
PSearchRec = ^TSearchRec;
PClass = ^TClass;
Procedure RegisterEXTMethods(Engine : TRutisEngineBase);
Implementation
//==============================================================================
//======== Strings
//==============================================================================
{$REGION 'Strings'}
Procedure _ToStr(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
Case Params^[0].IntType Of
// intCardinal : PAnsiString(Result^.Data)^ := IntToStr(GetPCardinal(Params^[0].Data));
// intInteger : PAnsiString(Result^.Data)^ := IntToStr(GetPInteger(Params^[0].Data));
// intExtended : PAnsiString(Result^.Data)^ := FloatToStr(GetPExtended(Params^[0].Data));
intCardinal : SetPAnsiString(Result^.Data, IntToStr(GetPCardinal(Params^[0].Data)));
intInteger : SetPAnsiString(Result^.Data, IntToStr(GetPInteger(Params^[0].Data)));
intExtended : SetPAnsiString(Result^.Data, FloatToStr(GetPExtended(Params^[0].Data)));
// intCardinal : PAnsiString(Result^.Data)^ := IntToStr(PCardinal(Params^[0].Data)^);
// intInteger : PAnsiString(Result^.Data)^ := IntToStr(PInteger(Params^[0].Data)^);
// intExtended : PAnsiString(Result^.Data)^ := FloatToStr(PExtended(Params^[0].Data)^);
End;
End;
Procedure _ToInt(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
Try
SetPInteger(Result^.Data, StrToInt(AnsiString(GetPPointer(Params^[0].Data))));
Except
SetPInteger(Result^.Data, 0);
End;
End;
Procedure _ToFloat(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
Try
SetPExtended(Result^.Data, StrToFloat(AnsiString(GetPPointer(Params^[0].Data))));
Except
SetPExtended(Result^.Data, 0);
End;
End;
Procedure _SetDecimalSeparator(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
DecimalSeparator := PAnsiChar(Params^[0].Data)^;
End;
Procedure _GetDecimalSeparator(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PAnsiChar(Result^.Data)^ := DecimalSeparator;
End;
Procedure _Chr(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PAnsiChar(Result^.Data)^ := Chr(PByte(Params^[0].Data)^);
End;
Procedure _Ord(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PByte(Result^.Data)^ := Ord(PAnsiChar(Params^[0].Data)^);
End;
Procedure _UpperCase(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPAnsiString(Result^.Data, UpperCase(AnsiString(GetPPointer(Params^[0].Data))));
End;
Procedure _LowerCase(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPAnsiString(Result^.Data, LowerCase(AnsiString(GetPPointer(Params^[0].Data))));
End;
Procedure _StringReplace(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Type PReplaceFlags = ^TReplaceFlags;
Begin
PAnsiString(Result^.Data)^ := StringReplace(
AnsiString(GetPPointer(Params^[0].Data)),
AnsiString(GetPPointer(Params^[1].Data)),
AnsiString(GetPPointer(Params^[2].Data)),
{$ifdef WinCe}unaligned({$endif}PReplaceFlags(Params^[3].Data)^{$ifdef WinCe}){$endif});
End;
Procedure _ExtractFilePath(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPAnsiString(Result^.Data, ExtractFilePath(AnsiString(GetPPointer(Params^[0].Data))));
End;
Procedure _ExtractFileName(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPAnsiString(Result^.Data, ExtractFileName(AnsiString(GetPPointer(Params^[0].Data))));
End;
Procedure _ExtractFileExt(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPAnsiString(Result^.Data, ExtractFileExt(AnsiString(GetPPointer(Params^[0].Data))));
End;
Procedure _ExpandFileName(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPAnsiString(Result^.Data, ExpandFileName(AnsiString(GetPPointer(Params^[0].Data))));
End;
{$ENDREGION}
//======== Internal ========
{$REGION 'Internal'}
Procedure _InheritsClass(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
var
AObject : TObject;
AClass : TClass;
Begin
AObject := TObject(GetPPointer(Params^[0].Data));
If AObject = nil then exit;
AClass := TClass(GetPPointer(Params^[1].Data));
If AClass = nil then exit;
PBoolean(Result^.Data)^ := AObject is AClass;
End;
{$ENDREGION}
//======== Files ========
{$REGION 'Files'}
Procedure _FileExists(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := FileExists(AnsiString(GetPPointer(Params^[0].Data)));
End;
Procedure _FindFirst(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPInteger(Result^.Data, FindFirst(
AnsiString(GetPPointer(Params^[0].Data)),
GetPInteger(Params^[1].Data),
PSearchRec(Params^[2].Data)^));
End;
Procedure _FindNext(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPInteger(Result^.Data, FindNext(PSearchRec(Params^[0].Data)^));
End;
Procedure _FindClose(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
FindClose(PSearchRec(Params^[0].Data)^);
End;
{$ENDREGION}
//==============================================================================
//======== Windows
//==============================================================================
{$REGION 'Windows'}
Procedure _Sleep(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
Sleep(GetPInteger(Params^[0].Data));
End;
Procedure _Delay(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
GTC : Cardinal;
Begin
GTC := GetTickCount + GetPInteger(Params^[0].Data);
While GTC >= GetTickCount Do
Begin
//Application.ProcessMessages;
sleep(1);
End;
End;
Procedure _RVal(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PByte(Result^.Data)^ := GetRValue(GetPCardinal(Params^[0].Data));
End;
Procedure _GVal(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PByte(Result^.Data)^ := GetRValue(GetPCardinal(Params^[0].Data));
End;
Procedure _BVal(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PByte(Result^.Data)^ := GetRValue(GetPCardinal(Params^[0].Data));
End;
Procedure _RGB(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPCardinal(Result^.Data, Cardinal(rgb(PByte(Params^[0].Data)^, PByte(Params^[1].Data)^, PByte(Params^[2].Data)^)));
End;
{$ifndef FPC}
Procedure _DynCallDLLProc(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Type
TPointerArray = Array Of Pointer;
PPointerArray = ^TPointerArray;
Var
DLLName : PAnsiString;
ProcName : PAnsiString;
ProcParams : TPointerArray;
HasResult : Boolean;
ProcResult : Cardinal;
Begin
DLLName := PAnsiString(Params^[0].Data);
ProcName := PAnsiString(Params^[1].Data);
HasResult := PBoolean(Params^[2].Data)^;
ProcParams := PPointerArray(PPointer(Params^[3].Data))^;
If length(ProcParams) > 100 Then exit;
If not DynamicDllCall(DLLName^, ProcName^, HasResult, ProcResult, ProcParams) Then
Begin
//ShowMessage('Function could not be found!');
PCardinal(Result^.Data)^ := 0;
End
Else
Begin
PCardinal(Result^.Data)^ := ProcResult;
End;
End;
{$endif}
Procedure _GetTickCount(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPCardinal(Result^.Data, GetTickCount);
End;
Procedure _GetAsyncKeyState(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := Boolean(GetAsyncKeyState(GetPWord(Params^[0].Data)) <> 0);
End;
{$ifndef WINCE}
Procedure _Beep(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
Windows.Beep(GetPCardinal(Params^[0].Data), GetPCardinal(Params^[1].Data));
End;
{$endif WINCE}
Procedure _InputDlg(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
str : AnsiString;
StrOut : Pointer;
Begin
str := AnsiString(GetPPointer(Params^[1].Data));
If not InputQuery('Input', AnsiString(GetPPointer(Params^[0].Data)), str) Then
SetPAnsiString(Result^.Data, '')
else
SetPAnsiString(Result^.Data, Str);
End;
{$ENDREGION}
//==============================================================================
//======== Properties
//==============================================================================
{$REGION 'Properties'}
Procedure _SetIntProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Obj : TObject;
PropInfo : PPropInfo;
PropName : AnsiString;
Begin
Obj := TObject(GetPPointer(Params^[0].Data));
PropName := AnsiString(GetPPointer(Params^[1].Data));
Try
PropInfo := GetPropInfo(Obj, PropName);
If PropInfo <> nil Then
SetOrdProp(Obj, PropInfo, GetPInteger(Params^[2].Data));
Except
End;
End;
Procedure _GetIntProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Obj : TObject;
PropInfo : PPropInfo;
PropName : AnsiString;
Begin
Obj := TObject(GetPPointer(Params^[0].Data));
PropName := AnsiString(GetPPointer(Params^[1].Data));
Try
PropInfo := GetPropInfo(Obj, PropName);
If PropInfo <> nil Then
SetPInteger(Result^.Data, GetOrdProp(Obj, PropInfo));
Except
End;
End;
Procedure _SetBoolProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Obj : TObject;
PropInfo : PPropInfo;
PropName : AnsiString;
Begin
Obj := TObject(GetPPointer(Params^[0].Data));
PropName := AnsiString(GetPPointer(Params^[1].Data));
Try
PropInfo := GetPropInfo(Obj, PropName);
If PropInfo <> nil Then
SetOrdProp(Obj, PropInfo, PByte(Params^[2].Data)^);
Except
End;
End;
Procedure _GetBoolProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Obj : TObject;
PropInfo : PPropInfo;
PropName : AnsiString;
Begin
Obj := TObject(GetPPointer(Params^[0].Data));
PropName := AnsiString(GetPPointer(Params^[1].Data));
Try
PropInfo := GetPropInfo(Obj, PropName);
If PropInfo <> nil Then
PByte(Result^.Data)^ := GetOrdProp(Obj, PropInfo);
Except
End;
End;
Procedure _SetStrProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Obj : TObject;
PropInfo : PPropInfo;
PropName : AnsiString;
Begin
Obj := TObject(GetPPointer(Params^[0].Data));
PropName := AnsiString(GetPPointer(Params^[1].Data));
Try
PropInfo := GetPropInfo(Obj, PropName);
If PropInfo <> nil Then
SetStrProp(Obj, PropInfo, AnsiString(GetPPointer(Params^[2].Data)));
Except
End;
End;
Procedure _GetStrProperty(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Obj : TObject;
PropInfo : PPropInfo;
PropName : AnsiString;
Begin
Obj := TObject(GetPPointer(Params^[0].Data));
PropName := AnsiString(GetPPointer(Params^[1].Data));
Try
PropInfo := GetPropInfo(Obj, PropName);
If PropInfo <> nil Then
SetPAnsiString(Result^.Data, GetStrProp(Obj, PropInfo));
Except
End;
End;
{$ENDREGION}
//==============================================================================
//======== Math
//==============================================================================
{$REGION 'Maths'}
Procedure _Round(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPInteger(Result^.Data, round(GetPSingle(Params^[0].Data)));
End;
Procedure _abs(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
Case Params^[0].IntType Of
intInteger : SetPInteger(Result^.Data, abs(GetPInteger(Params^[0].Data)));
intSingle : SetPSingle(Result^.Data, abs(GetPSingle(Params^[0].Data)));
intDouble : SetPDouble(Result^.Data, abs(GetPDouble(Params^[0].Data)));
End;
End;
Procedure _RandomF(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPDouble(Result^.Data, random);
End;
Procedure _Random(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPInteger(Result^.Data, random(GetPInteger(Params^[0].Data)));
End;
Procedure _sqr(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var d : Single;
Begin
d := GetPSingle(Params^[0].Data);
SetPSingle(Result^.Data, d * d);
End;
Procedure _sqrt(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPSingle(Result^.Data, sqrt(GetPSingle(Params^[0].Data)));
End;
Procedure _sqrtvari(Params : PVariantArray; Result : PVariant);
Begin
Result^ := sqrt(Params^[0]);
End;
Procedure _Sin(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPSingle(Result^.Data, Sin(GetPSingle(Params^[0].Data)));
End;
Procedure _Cos(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPSingle(Result^.Data, Cos(GetPSingle(Params^[0].Data)));
End;
Procedure _ArcSin(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPSingle(Result^.Data, ArcSin(GetPSingle(Params^[0].Data)));
End;
Procedure _ArcCos(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPSingle(Result^.Data, ArcCos(GetPSingle(Params^[0].Data)));
End;
Procedure _Arctan2(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
SetPSingle(Result^.Data, Arctan2(GetPSingle(Params^[0].Data), GetPSingle(Params^[1].Data)));
End;
{$ENDREGION}
//==============================================================================
//==============================================================================
Procedure RegisterEXTMethods(Engine : TRutisEngineBase);
Begin
//======== Strings ========
{$REGION 'Strings'}
Engine.RegExtMethod('IntToStr',{$IfDef FPC}@{$EndIf}_ToStr, ['Integer'], 'String');
Engine.RegExtMethod('FloatToStr',{$IfDef FPC}@{$EndIf}_ToStr, ['Extended'], 'String');
Engine.RegExtMethod('StrToInt',{$IfDef FPC}@{$EndIf}_ToInt, ['String'], 'Integer');
Engine.RegExtMethod('StrToFloat',{$IfDef FPC}@{$EndIf}_ToFloat, ['String'], 'Extended');
Engine.RegExtMethod('DecimalSeparator',{$IfDef FPC}@{$EndIf}_GetDecimalSeparator, [], 'Char');
Engine.RegExtMethod('DecimalSeparator',{$IfDef FPC}@{$EndIf}_SetDecimalSeparator, ['Char'], '');
Engine.RegExtMethod('Chr',{$IfDef FPC}@{$EndIf}_Chr, ['Byte'], 'AnsiChar');
Engine.RegExtMethod('Ord',{$IfDef FPC}@{$EndIf}_Ord, ['AnsiChar'], 'Byte');
Engine.RegExtMethod('UpperCase',{$IfDef FPC}@{$EndIf}_UpperCase, ['AnsiString'], 'AnsiString');
Engine.RegExtMethod('LowerCase',{$IfDef FPC}@{$EndIf}_LowerCase, ['AnsiString'], 'AnsiString');
Engine.RegExtMethod('StringReplace',{$IfDef FPC}@{$EndIf}_LowerCase, ['AnsiString', 'AnsiString', 'AnsiString', 'Cardinal'], 'AnsiString');
Engine.RegExtMethod('ExtractFilePath',{$IfDef FPC}@{$EndIf}_ExtractFilePath, ['AnsiString'], 'AnsiString');
Engine.RegExtMethod('ExtractFileName',{$IfDef FPC}@{$EndIf}_ExtractFileName, ['AnsiString'], 'AnsiString');
Engine.RegExtMethod('ExtractFileExt',{$IfDef FPC}@{$EndIf}_ExtractFileExt, ['AnsiString'], 'AnsiString');
Engine.RegExtMethod('ExpandFileName',{$IfDef FPC}@{$EndIf}_ExpandFileName, ['AnsiString'], 'AnsiString');
{$ENDREGION}
//======== Internal ========
{$REGION 'Internal'}
Engine.RegExtMethod('InheritsClass',{$IfDef FPC}@{$EndIf}_InheritsClass, ['TObject', 'TClass'], 'Boolean');
{$ENDREGION}
//======== MATHS ========
{$REGION 'Maths'}
Engine.RegExtMethod('Round',{$IfDef FPC}@{$EndIf}_Round, ['Single'], 'Integer');
Engine.RegExtMethod('abs_int',{$IfDef FPC}@{$EndIf}_abs, ['Integer'], 'Integer',
'Makes an integer value positive');
Engine.RegExtMethod('abs',{$IfDef FPC}@{$EndIf}_abs, ['Double'], 'Double',
'Makes a float value positive');
Engine.RegExtMethod('RandomF',{$IfDef FPC}@{$EndIf}_RandomF, [], 'Double',
'Returns a random float value in the Intervall [0..1]');
Engine.RegExtMethod('Random',{$IfDef FPC}@{$EndIf}_Random, ['Integer'], 'Integer',
'Returns a random Integer number in the Intervall [0..a-1]');
Engine.RegExtMethod('sin',{$IfDef FPC}@{$EndIf}_sin, ['Single'], 'Single');
Engine.RegExtMethod('cos',{$IfDef FPC}@{$EndIf}_cos, ['Single'], 'Single');
Engine.RegExtMethod('Arcsin',{$IfDef FPC}@{$EndIf}_Arcsin, ['Single'], 'Single');
Engine.RegExtMethod('Arccos',{$IfDef FPC}@{$EndIf}_Arccos, ['Single'], 'Single');
Engine.RegExtMethod('Arctan2',{$IfDef FPC}@{$EndIf}_Arctan2, ['Single', 'Single'], 'Single',
'Returns the Angle of an triangle with the two given sides');
Engine.RegExtMethod('sqr',{$IfDef FPC}@{$EndIf}_sqr, ['Single'], 'Single');
Engine.RegExtMethod('sqrt',{$IfDef FPC}@{$EndIf}_sqrt, ['Single'], 'Single',
'Returns the squareroot of the value');
Engine.RegExtMethodV('sqrtvari',{$IfDef FPC}@{$EndIf}_sqrtvari, ['Single'], 'Single',
'for testing only');
{$ENDREGION}
//======== Properties ========
{$REGION 'Properties'}
Engine.RegExtMethod('SetIntProperty',{$IfDef FPC}@{$EndIf}_SetIntProperty, ['TObject', 'String', 'Integer'], '',
'Sets the (Integer) property value for an Object' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Property-Name' + sLineBreak +
'#3 : New Value for Property');
Engine.RegExtMethod('GetIntProperty',{$IfDef FPC}@{$EndIf}_GetIntProperty, ['TObject', 'String'], 'Integer',
'Returns the (Integer) property value for an Object' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Property-Name' + sLineBreak +
'Returns : Value of Property');
Engine.RegExtMethod('SetStrProperty',{$IfDef FPC}@{$EndIf}_SetStrProperty, ['TObject', 'String', 'String'], '',
'Sets the (String) property value for an Object' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Property-Name' + sLineBreak +
'#3 : New Value for Property');
Engine.RegExtMethod('GetStrProperty',{$IfDef FPC}@{$EndIf}_GetStrProperty, ['TObject', 'String'], 'String',
'Returns the (String) property value for an Object' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Property-Name' + sLineBreak +
'Returns : Value of Property');
Engine.RegExtMethod('SetBoolProperty',{$IfDef FPC}@{$EndIf}_SetBoolProperty, ['TObject', 'String', 'Boolean'], '',
'Sets the (Boolean) property value for an Object' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Property-Name' + sLineBreak +
'#3 : New Value for Property');
Engine.RegExtMethod('GetBoolProperty',{$IfDef FPC}@{$EndIf}_GetBoolProperty, ['TObject', 'String'], 'Boolean',
'Returns the (Boolean) property value for an Object' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Property-Name' + sLineBreak +
'Returns : Value of Property');
{$ENDREGION}
//======== Files ========
{$REGION 'Files'}
Engine.RegExtMethod('FileExists',{$IfDef FPC}@{$EndIf}_FileExists, ['AnsiString'], 'Boolean');
Engine.RegExtMethod('FindFirst',{$IfDef FPC}@{$EndIf}_FindFirst, ['AnsiString', 'Integer', 'PSearchRec'], 'Integer');
Engine.RegExtMethod('FindNext',{$IfDef FPC}@{$EndIf}_FindNext, ['PSearchRec'], 'Integer');
Engine.RegExtMethod('FindClose',{$IfDef FPC}@{$EndIf}_FindClose, ['PSearchRec'], '');
{$ENDREGION}
//======== Windows ========
{$REGION 'Windows'}
{$ifndef FPC}
Engine.RegExtMethod('CallDLLProc',{$IfDef FPC}@{$EndIf}_DynCallDLLProc, ['String', 'String', 'Boolean', 'Pointer'], 'Cardinal',
'Executes a DLL Method');
{$endif}
Engine.RegExtMethod('GetAsyncKeyState',{$IfDef FPC}@{$EndIf}_GetAsyncKeyState, ['Word'], 'Boolean',
'Checks whether a certain key is pressed' + sLineBreak + 'Returns true, if the key was pressed since the last call of GetAsyncKeyState for this key');
Engine.RegExtMethod('GetTickCount',{$IfDef FPC}@{$EndIf}_GetTickCount, [], 'Cardinal',
'Returns the current System-Time in milli-seconds');
{$ifndef WINCE}
Engine.RegExtMethod('Beep',{$IfDef FPC}@{$EndIf}_Beep, ['Cardinal', 'Cardinal'], '');
{$endif WINCE}
Engine.RegExtMethod('Sleep',{$IfDef FPC}@{$EndIf}_Sleep, ['Integer'], '');
Engine.RegExtMethod('Delay',{$IfDef FPC}@{$EndIf}_Delay, ['Integer'], '',
'Delays the execution of the script for a certain time');
Engine.RegExtMethod('InputDlg',{$IfDef FPC}@{$EndIf}_InputDlg, ['String', 'String'], 'String',
'Shows an Input-Dialog for the user' + sLineBreak +
'#1: Question' + sLineBreak +
'#2: Default value' + sLineBreak +
'Returns the string the user has entered or '' if the' + sLineBreak + 'user has pressed the Cancel-Button');
Engine.RegExtMethod('RVal',{$IfDef FPC}@{$EndIf}_RVal, ['Cardinal'], 'Byte',
'Extracts the Red-Component of a TColor value');
Engine.RegExtMethod('GVal',{$IfDef FPC}@{$EndIf}_GVal, ['Cardinal'], 'Byte',
'Extracts the Green-Component of a TColor value');
Engine.RegExtMethod('BVal',{$IfDef FPC}@{$EndIf}_BVal, ['Cardinal'], 'Byte',
'Extracts the Blue-Component of a TColor value');
Engine.RegExtMethod('RGB',{$IfDef FPC}@{$EndIf}_RGB, ['Byte', 'Byte', 'Byte'], 'Cardinal',
'Creates a TColor Value out of the red, green and blue components');
{$ENDREGION}
End;
Initialization
randomize;
End.

View File

@ -0,0 +1,126 @@
Unit Rutis_EXT_Dialogs;
{$mode objfpc}{$H+}
Interface
Uses
Classes, SysUtils,
Rutis_Defs,
{$IfDef WinCE}WinCE_FileDialog,{$EndIf WinCE}
Dialogs;
Procedure RegisterEXTMethods(MethodList : PExtMethodList);
Implementation
Procedure _OpenFileDialog(Stack : PRutisStack; Param0 : Integer; Result : PRutisStackItem);
Var
{$IfDef WinCE}
dlg : TFFileDialog;
{$Else WinCE}
dlg : TOpenDialog;
{$EndIf WinCE}
Begin
MakeVType(@Stack^[Param0], VString);
MakeVType(@Stack^[Param0 + 1], VString);
Result^.VTyp := VString;
New(Result^.VString);
{$IfDef WinCE}
dlg := TFFileDialog.Create(nil);
try
dlg.FileName := Stack^[Param0].VString^;
dlg.ACaption := 'Open File';
dlg.Filter := Stack^[Param0+1].VString^;
If dlg.Filter = '' then
dlg.Filter := 'All Files (*.*)|*.*';
If dlg.Execute then
Result^.VString^ := dlg.FileName
else
Result^.VString^ := '';
finally
dlg.Free;
end;
{$Else WinCE}
dlg := TOpenDialog.Create(nil);
Try
dlg.FileName := Stack^[Param0].VString^;
dlg.Filter := Stack^[Param0 + 1].VString^;
If dlg.Filter = '' Then
dlg.Filter := 'All Files (*.*)|*.*';
If dlg.Execute Then
Result^.VString^ := dlg.FileName
Else
Result^.VString^ := '';
Finally
dlg.Free;
End;
{$EndIf WinCE}
End;
Procedure _SaveFileDialog(Stack : PRutisStack; Param0 : Integer; Result : PRutisStackItem);
Var
{$IfDef WinCE}
dlg: TFFileDialog;
{$Else WinCE}
dlg : TSaveDialog;
{$EndIf WinCE}
Begin
MakeVType(@Stack^[Param0], VString);
MakeVType(@Stack^[Param0 + 1], VString);
Result^.VTyp := VString;
New(Result^.VString);
{$IfDef WinCE}
dlg := TFFileDialog.Create(nil);
try
dlg.FileName := Stack^[Param0].VString^;
dlg.ACaption := 'Open File';
dlg.Filter := Stack^[Param0+1].VString^;
If dlg.Filter = '' then
dlg.Filter := 'All Files (*.*)|*.*';
If dlg.Execute then
Result^.VString^ := dlg.FileName
else
Result^.VString^ := '';
finally
dlg.Free;
end;
{$Else WinCE}
dlg := TOpenDialog.Create(nil);
Try
dlg.FileName := Stack^[Param0].VString^;
dlg.Filter := Stack^[Param0 + 1].VString^;
If dlg.Filter = '' Then
dlg.Filter := 'All Files (*.*)|*.*';
If dlg.Execute Then
Result^.VString^ := dlg.FileName
Else
Result^.VString^ := '';
Finally
dlg.Free;
End;
{$EndIf WinCE}
End;
//==============================================================================
//==============================================================================
Procedure RegisterEXTMethods(MethodList : PExtMethodList);
Begin
RegExtMethod('OpenFileDialog',{$IfDef FPC}@{$EndIf}_OpenFileDialog,
[VString, VString], VString, MethodList);
RegExtMethod('SaveFileDialog',{$IfDef FPC}@{$EndIf}_SaveFileDialog,
[VString, VString], VString, MethodList);
End;
End.

View File

@ -0,0 +1,253 @@
Unit Rutis_EXT_Files;
{$ifdef FPC}
{$mode objfpc}
{$H+}
{$endif}
Interface
Uses
Windows, Classes, SysUtils,
Rutis_Defs, Rutis_Classes, Rutis_Engine;
Procedure REFiles_CloseFiles;
Procedure RegisterEXTMethods(Engine : TRutisEngine);
//==============================================================================
Implementation
//==============================================================================
Type
PObject = ^TObject;
PFileStream = ^TFileStream;
Var
REFiles_Streams : Array Of TFileStream;
//==============================================================================
Procedure REFiles_CloseFiles;
Var i : Integer;
Begin
For i := 0 To high(REFiles_Streams) Do
REFiles_Streams[i].Free;
SetLength(REFiles_Streams, 0);
End;
//==============================================================================
//==============================================================================
Procedure _StreamCreate(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PPointer(Result^.Data)^ := nil;
SetLength(REFiles_Streams, length(REFiles_Streams) + 1);
Try
REFiles_Streams[high(REFiles_Streams)] := TFileStream.Create(PAnsiString(Params^[0].Data)^, PWord(Params^[1].Data)^); //fmCreate or fmShareDenyWrite
Except
REFiles_Streams[high(REFiles_Streams)].Free;
SetLength(REFiles_Streams, length(REFiles_Streams) - 1);
exit;
End;
PPointer(Result^.Data)^ := REFiles_Streams[high(REFiles_Streams)];
End;
Procedure _StreamClose(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var i : Integer;
Begin
For i := 0 To high(REFiles_Streams) Do
If REFiles_Streams[i] = PPointer(Params^[0].Data)^ Then
Begin
REFiles_Streams[i].Free;
REFiles_Streams[i] := REFiles_Streams[high(REFiles_Streams)];
SetLength(REFiles_Streams, length(REFiles_Streams) - 1);
exit;
End;
End;
Procedure _StreamGetPosition(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PCardinal(Result^.Data)^ := 0;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PCardinal(Result^.Data)^ := PFileStream(Params^[0].Data)^.Position;
End;
Procedure _StreamSetPosition(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Position := PCardinal(Params^[1].Data)^;
End;
Procedure _StreamGetSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PCardinal(Result^.Data)^ := 0;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PCardinal(Result^.Data)^ := PFileStream(Params^[0].Data)^.Size;
End;
Procedure _StreamSetSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Size := PCardinal(Params^[1].Data)^;
End;
//==============================================================================
Procedure _StreamWriteByte(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := False;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Write(PByte(Params^[1].Data)^, 1);
PBoolean(Result^.Data)^ := True;
End;
Procedure _StreamWriteWord(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := False;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Write(PWord(Params^[1].Data)^, 2);
PBoolean(Result^.Data)^ := True;
End;
Procedure _StreamWriteDWord(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := False;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Write(PCardinal(Params^[1].Data)^, 4);
PBoolean(Result^.Data)^ := True;
End;
Procedure _StreamWriteSingle(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := False;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Write(PCardinal(Params^[1].Data)^, 4);
PBoolean(Result^.Data)^ := True;
End;
Procedure _StreamWriteString(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
str : Ansistring;
Begin
PBoolean(Result^.Data)^ := False;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
str := PAnsiString(Params^[1].Data)^;
StreamWriteString(str, PFileStream(Params^[0].Data)^);
PBoolean(Result^.Data)^ := True;
End;
Procedure _StreamWrite(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := False;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Write(PPChar(Params^[1].Data)^^, PInteger(Params^[2].Data)^);
PBoolean(Result^.Data)^ := True;
End;
//==============================================================================
Procedure _StreamReadByte(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PByte(Result^.Data)^ := 0;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Read(PByte(Result^.Data)^, 1);
End;
Procedure _StreamReadWord(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PWord(Result^.Data)^ := 0;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Read(PWord(Result^.Data)^, 2);
End;
Procedure _StreamReadDWord(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PInteger(Result^.Data)^ := 0;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Read(PInteger(Result^.Data)^, 4);
End;
Procedure _StreamReadString(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PAnsiString(Result^.Data)^ := '';
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PAnsiString(Result^.Data)^ := StreamReadString(PFileStream(Params^[0].Data)^);
End;
Procedure _StreamRead(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PByte(Result^.Data)^ := 0;
If PObject(Params^[0].Data)^ = nil Then exit;
If not (PObject(Params^[0].Data)^ is TFileStream) Then exit;
PFileStream(Params^[0].Data)^.Read(PPChar(Params^[1].Data)^^, PInteger(Params^[2].Data)^);
End;
//==============================================================================
//==============================================================================
Procedure RegisterEXTMethods(Engine : TRutisEngine);
Begin
Engine.RegExtMethod('StreamCreate',{$IfDef FPC}@{$EndIf}_StreamCreate, ['String', 'Word'], 'Pointer');
Engine.RegExtMethod('StreamClose',{$IfDef FPC}@{$EndIf}_StreamClose, ['Pointer'], 'Pointer');
Engine.RegExtMethod('StreamGetPosition',{$IfDef FPC}@{$EndIf}_StreamGetPosition, ['Pointer'], 'Cardinal');
Engine.RegExtMethod('StreamSetPosition',{$IfDef FPC}@{$EndIf}_StreamSetPosition, ['Pointer', 'Cardinal'], '');
Engine.RegExtMethod('StreamGetSize',{$IfDef FPC}@{$EndIf}_StreamGetSize, ['Pointer'], 'Cardinal');
Engine.RegExtMethod('StreamSetSize',{$IfDef FPC}@{$EndIf}_StreamSetSize, ['Pointer', 'Cardinal'], '');
Engine.RegExtMethod('StreamWriteByte',{$IfDef FPC}@{$EndIf}_StreamWriteByte, ['Pointer', 'Byte'], 'Boolean');
Engine.RegExtMethod('StreamWriteWord',{$IfDef FPC}@{$EndIf}_StreamWriteWord, ['Pointer', 'Word'], 'Boolean');
Engine.RegExtMethod('StreamWriteInteger',{$IfDef FPC}@{$EndIf}_StreamWriteDWord, ['Pointer', 'Integer'], 'Boolean');
Engine.RegExtMethod('StreamWriteCardinal',{$IfDef FPC}@{$EndIf}_StreamWriteDWord, ['Pointer', 'Cardinal'], 'Boolean');
Engine.RegExtMethod('StreamWriteSingle',{$IfDef FPC}@{$EndIf}_StreamWriteDWord, ['Pointer', 'Single'], 'Boolean');
Engine.RegExtMethod('StreamWriteString',{$IfDef FPC}@{$EndIf}_StreamWriteString, ['Pointer', 'String'], 'Boolean');
Engine.RegExtMethod('StreamWrite',{$IfDef FPC}@{$EndIf}_StreamWrite, ['Pointer', 'Pointer', 'Integer'], 'Boolean');
Engine.RegExtMethod('StreamReadByte',{$IfDef FPC}@{$EndIf}_StreamReadByte, ['Pointer'], 'Byte');
Engine.RegExtMethod('StreamReadWord',{$IfDef FPC}@{$EndIf}_StreamReadWord, ['Pointer'], 'Word');
Engine.RegExtMethod('StreamReadInteger',{$IfDef FPC}@{$EndIf}_StreamReadDWord, ['Pointer'], 'Integer');
Engine.RegExtMethod('StreamReadCardinal',{$IfDef FPC}@{$EndIf}_StreamReadDWord, ['Pointer'], 'Cardinal');
Engine.RegExtMethod('StreamReadSingle',{$IfDef FPC}@{$EndIf}_StreamReadDWord, ['Pointer'], 'Single');
Engine.RegExtMethod('StreamReadString',{$IfDef FPC}@{$EndIf}_StreamReadString, ['Pointer'], 'String');
Engine.RegExtMethod('StreamRead',{$IfDef FPC}@{$EndIf}_StreamRead, ['Pointer', 'Pointer', 'Integer'], 'Boolean');
End;
Initialization
Finalization
REFiles_CloseFiles;
End.

View File

@ -0,0 +1,753 @@
Unit Rutis_EXT_Forms;
Interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, ComCtrls, ExtCtrls, TypInfo,
Rutis_Engine, Rutis_Defs;
Type
TUnownedForm = Class(TForm)
Protected
Procedure CreateWnd; Override;
End;
TEXTF_EventType = (
etClick, etChange, etResize, etTimer,
etMouseDown, etMouseUp, etMouseMove,
etKeyPress, etKeyDown, etKeyUp,
etNone);
Const
EventNames : Array [TEXTF_EventType] Of String[64] = (
'OnClick', 'OnChange', 'OnResize', 'OnTimer',
'OnMouseDown', 'OnMouseUp', 'OnMouseMove',
'OnKeyPress', 'OnKeyDown', 'OnKeyUp',
'');
Type
TEXTF_EventLink = Record
EventType : TEXTF_EventType;
Control : TControl;
Address : Cardinal;
DoCall : Boolean;
End;
PControl = ^TControl;
PComponent = ^TComponent;
TEventContentHolder = Class
Public
ASender : TObject;
AButton : TMouseButton;
AShift : TShiftState;
AX, AY : Integer;
AKey : Word;
Procedure OnClick(Sender : TObject);
Procedure OnTimer(Sender : TObject);
Procedure OnChange(Sender : TObject);
Procedure OnResize(Sender : TObject);
Procedure OnMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
Procedure OnMouseUp(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
Procedure OnMouseMove(Sender : TObject; Shift : TShiftState; X, Y : Integer);
Procedure OnKeyPress(Sender : TObject; Var Key : Char);
Procedure OnKeyDown(Sender : TObject; Var Key : Word; Shift : TShiftState);
Procedure OnKeyUp(Sender : TObject; Var Key : Word; Shift : TShiftState);
End;
Var
EXTF_Forms : Array Of TForm;
EXTF_EventLinks : Array Of TEXTF_EventLink;
EXTF_Engine : TRutisEngine;
Const
ControlClasses : Array [1..11] Of TControlClass = (
TButton, TLabel, TEdit, TPanel, TMemo, TImage,
TListBox, TCheckBox, TRadioButton, TComboBox, TScrollBar
);
ComponentClasses : Array [1..1] Of TComponentClass = (
TTimer
);
Procedure RegisterEXTMethods(Engine : TRutisEngine);
Procedure EXTF_DestroyRutisForms;
Function EXTF_GetEventID(EventType : TEXTF_EventType; Control : TControl) : Integer;
//==============================================================================
//==============================================================================
Implementation
Var
EventContentHolder : TEventContentHolder;
EXTF_CurrentForm : TForm;
EXTF_CurrentControl : TControl;
//==============================================================================
//==============================================================================
{ TUnownedForm }
Procedure TUnownedForm.CreateWnd;
Var
Params : TCreateParams;
TempClass : TWndClass;
ClassRegistered : Boolean;
Begin
CreateParams(Params);
With Params Do
Begin
WndParent := 0;
DefWndProc := WindowClass.lpfnWndProc;
ClassRegistered := GetClassInfo(WindowClass.hInstance, WinClassName, TempClass);
If not ClassRegistered or (TempClass.lpfnWndProc <> @InitWndProc) Then
Begin
If ClassRegistered Then Windows.UnregisterClass(WinClassName,
WindowClass.hInstance);
WindowClass.lpfnWndProc := @InitWndProc;
WindowClass.lpszClassName := WinClassName;
If Windows.RegisterClass(WindowClass) = 0 Then RaiseLastOSError;
End;
CreationControl := Self;
CreateWindowHandle(Params);
If WindowHandle = 0 Then
RaiseLastOSError;
If (GetWindowLong(WindowHandle, GWL_STYLE) and WS_CHILD <> 0) and
(GetWindowLong(WindowHandle, GWL_ID) = 0) Then
SetWindowLong(WindowHandle, GWL_ID, WindowHandle);
End;
StrDispose(WindowText);
WindowText := nil;
UpdateBounds;
Perform(WM_SETFONT, Font.Handle, 1);
If AutoSize Then AdjustSize;
End;
//==============================================================================
//==============================================================================
Procedure EXTF_DestroyRutisForms;
Var i : Integer;
Begin
For I := 0 To high(EXTF_Forms) Do
EXTF_Forms[i].Free;
SetLength(EXTF_Forms, 0);
SetLength(EXTF_EventLinks, 0);
End;
Function EXTF_GetEventID(EventType : TEXTF_EventType; Control : TControl) : Integer;
Begin
For Result := 0 To high(EXTF_EventLinks) Do
If (EXTF_EventLinks[Result].EventType = EventType) and
(EXTF_EventLinks[Result].Control = Control) Then
exit;
Result := -1;
End;
Function EXTF_CallEvents : Boolean;
Var
i : Integer;
CMD : TRutisScriptCmd;
Begin
Result := False;
For i := 0 To high(EXTF_EventLinks) Do
If EXTF_EventLinks[i].DoCall Then
Begin
Result := True;
EXTF_EventLinks[i].DoCall := False;
{CMD.Cmd := _Gen4;
CMD.P1 := EXTF_EventLinks[i].Address;
CMD.P2 := 0;
CMD.P3 := 0;
EXTF_Engine.ExecuteCMD(CMD);}
CMD.Cmd := _Call;
CMD.P1 := EXTF_EventLinks[i].Address;
CMD.P2 := 1;
CMD.P3 := 0;
EXTF_Engine.ExecuteCMD(CMD);
End;
End;
Procedure RegisterObjectEvent(Obj : TObject; EventName : String; Adr : Pointer);
Var
PropInfo : PPropInfo;
AMethod : TMethod;
Begin
AMethod.Code := Adr;
AMethod.Data := EventContentHolder;
Try
PropInfo := GetPropInfo(Obj, EventName);
If PropInfo <> nil Then
SetMethodProp(Obj, PropInfo, AMethod);
Except
End;
End;
//==============================================================================
//==============================================================================
//TEXTF_EventType = (etClick, etMouseDown, etMouseUp, etChange, etKeyPress, etKeyDown, etKeyUp);
Procedure TEventContentHolder.OnChange(Sender : TObject);
Var id : Integer;
Begin
ASender := Sender;
id := EXTF_GetEventID(etChange, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
End;
procedure TEventContentHolder.OnTimer(Sender: TObject);
Var id : Integer;
Begin
ASender := Sender;
id := EXTF_GetEventID(etTimer, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
end;
Procedure TEventContentHolder.OnClick(Sender : TObject);
Var id : Integer;
Begin
ASender := Sender;
id := EXTF_GetEventID(etClick, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
End;
Procedure TEventContentHolder.OnResize(Sender : TObject);
Var id : Integer;
Begin
ASender := Sender;
id := EXTF_GetEventID(etResize, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
End;
Procedure TEventContentHolder.OnMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
Var id : Integer;
Begin
ASender := Sender;
AButton := Button;
AShift := Shift;
AX := X;
AY := Y;
id := EXTF_GetEventID(etMouseDown, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
End;
Procedure TEventContentHolder.OnMouseUp(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
Var id : Integer;
Begin
ASender := Sender;
AButton := Button;
AShift := Shift;
AX := X;
AY := Y;
id := EXTF_GetEventID(etMouseUp, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
End;
Procedure TEventContentHolder.OnMouseMove(Sender : TObject; Shift : TShiftState; X, Y : Integer);
Var id : Integer;
Begin
ASender := Sender;
AShift := Shift;
AX := X;
AY := Y;
id := EXTF_GetEventID(etMouseMove, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
End;
Procedure TEventContentHolder.OnKeyPress(Sender : TObject; Var Key : Char);
Var id : Integer;
Begin
ASender := Sender;
AKey := Word(Key);
id := EXTF_GetEventID(etKeyPress, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
End;
Procedure TEventContentHolder.OnKeyDown(Sender : TObject; Var Key : Word; Shift : TShiftState);
Var id : Integer;
Begin
ASender := Sender;
AKey := Key;
AShift := Shift;
id := EXTF_GetEventID(etKeyDown, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
End;
Procedure TEventContentHolder.OnKeyUp(Sender : TObject; Var Key : Word; Shift : TShiftState);
Var id : Integer;
Begin
ASender := Sender;
AKey := Key;
AShift := Shift;
id := EXTF_GetEventID(etKeyUp, TControl(Sender));
If id > -1 Then
EXTF_EventLinks[id].DoCall := True;
End;
//==============================================================================
//==============================================================================
Procedure _CreateForm(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Form : TForm;
Begin
Form := TUnownedForm.CreateNew(nil);
Form.Hide;
Form.Caption := 'RUTIS Formular';
Form.BorderStyle := bsSizeable;
Form.Position := poScreenCenter;
If PBoolean(Params^[0].Data)^ Then
Form.Show;
EXTF_CurrentForm := Form;
EXTF_CurrentControl := EXTF_CurrentForm;
SetLength(EXTF_Forms, length(EXTF_Forms) + 1);
EXTF_Forms[high(EXTF_Forms)] := Form;
PPointer(Result^.Data)^ := Form;
End;
Procedure _CreateControl(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
ClassName : String;
Control : TControl;
ControlParent : TControl;
i : Integer;
Begin
Control := nil;
PControl(Result^.Data)^ := Control;
ClassName := LowerCase(PAnsiString(Params^[1].Data)^);
ControlParent := PControl(Params^[0].Data)^;
If ControlParent = nil Then ControlParent := EXTF_CurrentControl;
For I := Low(ControlClasses) To high(ControlClasses) Do
If ClassName = LowerCase(ControlClasses[i].ClassName) Then
Control := ControlClasses[i].Create(ControlParent);
If Control = nil Then exit;
While not (ControlParent is TWinControl) Do
ControlParent := ControlParent.Parent;
Control.Parent := TWinControl(ControlParent);
PControl(Result^.Data)^ := Control;
End;
Procedure _CreateComponent(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
ClassName : String;
Component : TComponent;
ComponentParent : TControl;
i : Integer;
Begin
Component := nil;
PComponent(Result^.Data)^ := nil;
ClassName := LowerCase(PAnsiString(Params^[1].Data)^);
ComponentParent := PControl(Params^[0].Data)^;
If ComponentParent = nil Then ComponentParent := EXTF_CurrentControl;
For I := Low(ComponentClasses) To high(ComponentClasses) Do
If ClassName = LowerCase(ComponentClasses[i].ClassName) Then
Component := ComponentClasses[i].Create(ComponentParent);
If Component = nil Then exit;
PComponent(Result^.Data)^ := Component;
End;
Procedure _DestroyControl(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
i : Integer;
Control : TControl;
Begin
Control := TControl(PPointer(Params^[0].Data)^);
For I := 0 To high(EXTF_Forms) Do
If EXTF_Forms[i] = Control Then
Begin
EXTF_Forms[i] := EXTF_Forms[high(EXTF_Forms)];
SetLength(EXTF_Forms, length(EXTF_Forms) - 1);
break;
End;
Control.Free;
End;
Procedure _RegisterEvent(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
EName : String;
EType : TEXTF_EventType;
Crtl : TControl;
I : Integer;
Begin
Crtl := PControl(Params^[0].Data)^;
EName := LowerCase(PAnsiString(Params^[1].Data)^);
For EType := TEXTF_EventType(0) To etNone Do
If LowerCase(EventNames[EType]) = EName Then
break;
If EType = etNone Then exit;
RegisterObjectEvent(Crtl, 'Onclick', @TEventCOntentHolder.Onclick);
RegisterObjectEvent(Crtl, 'OnChange', @TEventCOntentHolder.OnChange);
RegisterObjectEvent(Crtl, 'OnResize', @TEventCOntentHolder.OnResize);
RegisterObjectEvent(Crtl, 'OnTimer', @TEventCOntentHolder.OnTimer);
RegisterObjectEvent(Crtl, 'OnMousedown', @TEventCOntentHolder.OnMousedown);
RegisterObjectEvent(Crtl, 'OnMouseup', @TEventCOntentHolder.OnMouseup);
RegisterObjectEvent(Crtl, 'OnMouseMove', @TEventCOntentHolder.OnMouseMove);
RegisterObjectEvent(Crtl, 'OnKeypress', @TEventCOntentHolder.OnKeypress);
RegisterObjectEvent(Crtl, 'OnKeydown', @TEventCOntentHolder.OnKeydown);
RegisterObjectEvent(Crtl, 'OnKeyup', @TEventCOntentHolder.OnKeyup);
For I := 0 To high(EXTF_EventLinks) Do
If (EXTF_EventLinks[i].Control = Crtl) and
(EXTF_EventLinks[i].EventType = EType) Then
Begin
If PCardinal(Params^[2].Data)^ = 0 Then
Begin
EXTF_EventLinks[i] := EXTF_EventLinks[high(EXTF_EventLinks)];
SetLength(EXTF_EventLinks, length(EXTF_EventLinks) - 1);
exit;
End;
EXTF_EventLinks[i].Address := PCardinal(Params^[2].Data)^;
exit;
End;
SetLength(EXTF_EventLinks, length(EXTF_EventLinks) + 1);
With EXTF_EventLinks[high(EXTF_EventLinks)] Do
Begin
Control := Crtl;
Address := PCardinal(Params^[2].Data)^;
EventType := EType;
DoCall := False;
End;
End;
Procedure _CallEvents(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
EXTF_CallEvents;
End;
Procedure _WaitForEvent(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
While not EXTF_CallEvents Do
Begin
Application.ProcessMessages;
sleep(10);
End;
End;
Procedure _EventParamX(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PInteger(Result^.Data)^ := EventContentHolder.Ax;
End;
Procedure _EventParamY(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PInteger(Result^.Data)^ := EventContentHolder.Ay;
End;
Procedure _EventParamSender(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
TObject(PPointer(Result^.Data)^) := EventContentHolder.ASender;
End;
Procedure _EventKey(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PWord(Result^.Data)^ := EventContentHolder.AKey;
End;
Procedure _EventParamShiftState(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Type
PShiftState = ^TShiftState;
Begin
PShiftState(Result^.Data)^ := EventContentHolder.AShift;
End;
Procedure _EventParamIsControl(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := ssCtrl in EventContentHolder.AShift;
End;
Procedure _EventParamIsAlt(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := ssAlt in EventContentHolder.AShift;
End;
Procedure _EventParamIsShift(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := ssShift in EventContentHolder.AShift;
End;
Procedure _EventParamIsLeft(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := ssLeft in EventContentHolder.AShift;
End;
Procedure _EventParamIsRight(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := ssRight in EventContentHolder.AShift;
End;
Procedure _EventParamIsMiddle(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PBoolean(Result^.Data)^ := ssMiddle in EventContentHolder.AShift;
End;
//==============================================================================
//==============================================================================
Procedure _SetPos(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := PControl(Params^[0].Data)^;
If Control is TControl Then
Begin
Control.Left := PInteger(Params^[1].Data)^;
Control.Top := PInteger(Params^[2].Data)^;
End;
End;
Procedure _SetSize(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := PControl(Params^[0].Data)^;
If Control is TForm Then
Begin
TForm(Control).ClientWidth := PInteger(Params^[1].Data)^;
TForm(Control).ClientHeight := PInteger(Params^[2].Data)^;
exit;
End;
If Control is TControl Then
Begin
Control.Width := PInteger(Params^[1].Data)^;
Control.Height := PInteger(Params^[2].Data)^;
End;
End;
Procedure _SetVisibility(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := TControl(PPointer(Params^[0].Data)^);
Control.Visible := PBoolean(Params^[0].Data)^;
End;
Procedure _GetVisibility(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := TControl(PPointer(Params^[0].Data)^);
PBoolean(Result^.Data)^ := Control.Visible;
End;
Procedure _GetDC(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Begin
PCardinal(Result^.Data)^ := GetDC(PCardinal(Params^[0].Data)^);
End;
Procedure _GetHandle(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := PControl(Params^[0].Data)^;
If Control is TWinControl Then
PCardinal(Result^.Data)^ := TWinControl(Control).Handle
Else
If Control is TControl Then
PCardinal(Result^.Data)^ := Control.Parent.Handle;
End;
Procedure _AddLine(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := PControl(Params^[0].Data)^;
If Control is TCustomListBox Then
TCustomListBox(Control).Items.Add(PAnsiString(Params^[1].Data)^);
If Control is TCustomMemo Then
TCustomMemo(Control).Lines.Add(PAnsiString(Params^[1].Data)^);
End;
Procedure _InsertLine(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := PControl(Params^[0].Data)^;
If Control is TCustomListBox Then
TCustomListBox(Control).Items.Insert(PInteger(Params^[1].Data)^, PAnsiString(Params^[2].Data)^);
If Control is TCustomMemo Then
TCustomMemo(Control).Lines.Insert(PInteger(Params^[1].Data)^, PAnsiString(Params^[2].Data)^);
End;
Procedure _DeleteLine(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := PControl(Params^[0].Data)^;
If Control is TCustomListBox Then
TCustomListBox(Control).Items.Delete(PInteger(Params^[1].Data)^);
If Control is TCustomMemo Then
TCustomMemo(Control).Lines.Delete(PInteger(Params^[1].Data)^);
End;
Procedure _SetLine(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := PControl(Params^[0].Data)^;
If Control is TCustomListBox Then
TCustomListBox(Control).Items[PInteger(Params^[1].Data)^] := PAnsiString(Params^[2].Data)^;
If Control is TCustomMemo Then
TCustomMemo(Control).Lines[PInteger(Params^[1].Data)^] := PAnsiString(Params^[2].Data)^;
End;
Procedure _SetLineCount(Params : PRutisParamInfoArray; Result : PRutisParamInfo);
Var
Control : TControl;
Begin
Control := PControl(Params^[0].Data)^;
If Control is TCustomListBox Then
While TCustomListBox(Control).Items.Count > PInteger(Params^[1].Data)^ Do
TCustomListBox(Control).Items.Delete(TCustomListBox(Control).Items.Count - 1);
If Control is TCustomMemo Then
While TCustomMemo(Control).Lines.Count > PInteger(Params^[1].Data)^ Do
TCustomMemo(Control).Lines.Delete(TCustomMemo(Control).Lines.Count - 1);
End;
//==============================================================================
//==============================================================================
Procedure RegisterEXTMethods(Engine : TRutisEngine);
Var
Decl : TRutisVarType;
Begin
OutputDebugString(PChar('Rutis_EXT_Formulars.RegisterEXTMethods - Registering RUTIS Formular Support'));
Engine.RegExtMethod('CreateForm',{$IfDef FPC}@{$EndIf}_CreateForm, ['Boolean'], 'TControl',
'Creates a RUTIS-Form' + sLineBreak +
'#1: Visibility of form after creation' + sLineBreak +
'Returns: Created form');
Engine.RegExtMethod('CrtlCreate',{$IfDef FPC}@{$EndIf}_CreateControl, ['TControl', 'String'], 'TControl',
'Creates a new Control' + sLineBreak +
'#1 : Owner for the new Control' + sLineBreak +
'#2 : Class-Name of the new Control' + sLineBreak +
'Returns: Created object');
Engine.RegExtMethod('CrtlCreateComponent',{$IfDef FPC}@{$EndIf}_CreateComponent, ['TComponent', 'String'], 'TComponent',
'Creates a new Component' + sLineBreak +
'#1 : Owner for the new Component' + sLineBreak +
'#2 : Class-Name of the new Component' + sLineBreak +
'Returns: Created Component');
Engine.RegExtMethod('CrtlDestroy',{$IfDef FPC}@{$EndIf}_DestroyControl, [], 'TControl',
'Destroys a Control');
Engine.RegExtMethod('CrtlRegisterEvent',{$IfDef FPC}@{$EndIf}_RegisterEvent, ['TControl', 'String', 'Method'], '',
'Registers an Event' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Event Name' + sLineBreak +
'#3 : Event Handler' + sLineBreak +
'Possible Values for #2 are:' + sLineBreak +
'- OnClick, OnMouseDown, OnMouseUp, OnMouseMove,' + sLineBreak +
'- OnChange,' + sLineBreak +
'- OnKeyPress, OnKeyDown, OnKeyUp');
Engine.RegExtMethod('CallEvents',{$IfDef FPC}@{$EndIf}_CallEvents, [], '',
'Calls all activated events' + sLineBreak +
'You need to link events to actions with RegisterEvent first');
Engine.RegExtMethod('WaitForEvent',{$IfDef FPC}@{$EndIf}_WaitForEvent, [], '',
'Waits for any Event to happen' + sLineBreak +
'You need to link events to actions with RegisterEvent first');
Engine.RegExtMethod('EventParamX',{$IfDef FPC}@{$EndIf}_EventParamX, [], 'Integer',
'Returns the "X" parameter of an occurred event');
Engine.RegExtMethod('EventParamY',{$IfDef FPC}@{$EndIf}_EventParamY, [], 'Integer',
'Returns the "Y" parameter of an occurred event');
Engine.RegExtMethod('EventParamSender',{$IfDef FPC}@{$EndIf}_EventParamSender, [], 'TControl',
'Returns the "Sender" parameter of an occurred event');
Engine.RegExtMethod('EventParamKey',{$IfDef FPC}@{$EndIf}_EventKey, [], 'Word',
'Returns the "Key" parameter of an occurred event');
Engine.RegExtMethod('EventParamShiftState',{$IfDef FPC}@{$EndIf}_EventParamShiftState, [], 'Cardinal',
'Returns the "ShiftState" parameter of an occurred event');
Engine.RegExtMethod('EventParamIsControl',{$IfDef FPC}@{$EndIf}_EventParamIsControl, [], 'Boolean',
'Returns true, if "ssCrtl" is in he ShiftState parameter of an occurred event');
Engine.RegExtMethod('EventParamIsAlt',{$IfDef FPC}@{$EndIf}_EventParamIsAlt, [], 'Boolean',
'Returns true, if "ssAlt" is in he ShiftState parameter of an occurred event');
Engine.RegExtMethod('EventParamIsShift',{$IfDef FPC}@{$EndIf}_EventParamIsShift, [], 'Boolean',
'Returns true, if "ssShift" is in he ShiftState parameter of an occurred event');
Engine.RegExtMethod('EventParamIsLeft',{$IfDef FPC}@{$EndIf}_EventParamIsLeft, [], 'Boolean',
'Returns true, if "ssLeft" is in he ShiftState parameter of an occurred event');
Engine.RegExtMethod('EventParamIsRight',{$IfDef FPC}@{$EndIf}_EventParamIsRight, [], 'Boolean',
'Returns true, if "ssRight" is in he ShiftState parameter of an occurred event');
Engine.RegExtMethod('EventParamIsMiddle',{$IfDef FPC}@{$EndIf}_EventParamIsMiddle, [], 'Boolean',
'Returns true, if "ssMiddle" is in he ShiftState parameter of an occurred event');
Engine.RegExtMethod('CrtlSetVisibility',{$IfDef FPC}@{$EndIf}_SetVisibility, ['TControl', 'Boolean'], '',
'Sets the Visibility of an Control' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Visibility');
Engine.RegExtMethod('CrtlGetVisibility',{$IfDef FPC}@{$EndIf}_GetVisibility, ['TControl'], 'Boolean',
'Sets the Visibility of an Control' + sLineBreak +
'#1 : Control' + sLineBreak +
'Returns : Visibility of the Control');
Engine.RegExtMethod('CrtlSetPos',{$IfDef FPC}@{$EndIf}_SetPos, ['TControl', 'Integer', 'Integer'], '',
'Sets the Position of an Control' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Left' + sLineBreak +
'#3 : Top');
Engine.RegExtMethod('CrtlSetSize',{$IfDef FPC}@{$EndIf}_SetSize, ['TControl', 'Integer', 'Integer'], '',
'Sets the Position of an Control' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Width' + sLineBreak +
'#3 : Height');
Engine.RegExtMethod('GetDC',{$IfDef FPC}@{$EndIf}_GetDC, ['Cardinal'], 'Cardinal',
'Returns the DeviceContext for a specific Handle' + sLineBreak +
'#1 : Handle' + sLineBreak +
'Returns : DC');
Engine.RegExtMethod('GetHandle',{$IfDef FPC}@{$EndIf}_GetHandle, ['TControl'], 'Cardinal',
'Returns the Handle of a control (e.g. for GetDC)' + sLineBreak +
'#1 : Control' + sLineBreak +
'Returns : Handle');
Engine.RegExtMethod('CrtlAddLine',{$IfDef FPC}@{$EndIf}_AddLine, ['TControl', 'String'], '',
'Adds a new Line/Item in TMemo/TListBox/etc.' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Line to add');
Engine.RegExtMethod('CrtlInsertLine',{$IfDef FPC}@{$EndIf}_InsertLine, ['TControl', 'Integer', 'String'], '',
'Adds a new Line/Item in TMemo/TListBox/etc.' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Insert place' + sLineBreak +
'#3 : Line to add');
Engine.RegExtMethod('CrtlDeleteLine',{$IfDef FPC}@{$EndIf}_DeleteLine, ['TControl', 'Integer'], '',
'Deletes a Line/Item in TMemo/TListBox/etc.' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Line to delete');
Engine.RegExtMethod('CrtlSetLine',{$IfDef FPC}@{$EndIf}_SetLine, ['TControl', 'Integer', 'String'], '',
'Sets the text of a Line/Item in TMemo/TListBox/etc.' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Line' + sLineBreak +
'#2 : New text');
Engine.RegExtMethod('CrtlSetLineCount',{$IfDef FPC}@{$EndIf}_SetLineCount, ['TControl', 'Integer'], '',
'Sets the number of Lines/Items in TMemo/TListBox/etc.' + sLineBreak +
'#1 : Control' + sLineBreak +
'#2 : Line-count'); //CrtlSetLineCount
OutputDebugString(PChar('Rutis_EXT_Formulars.RegisterEXTMethods - Successfully registered RUTIS Formular Support'));
End;
//==============================================================================
//==============================================================================
Initialization
EventContentHolder := TEventContentHolder.Create;
Finalization
EventContentHolder.Free;
End.

File diff suppressed because it is too large Load Diff

2278
Units/RUTIS/Rutis_Engine.pas Normal file

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,85 @@
object FExtMethodListInfo: TFExtMethodListInfo
Left = 0
Top = 0
BorderIcons = [biSystemMenu, biMaximize]
Caption = 'EXT Methods Info'
ClientHeight = 305
ClientWidth = 526
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
FormStyle = fsStayOnTop
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
OnHide = FormHide
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object ExtList: TListBox
Left = 0
Top = 25
Width = 526
Height = 280
Align = alClient
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
Font.Style = []
ItemHeight = 14
ParentFont = False
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnDblClick = ExtListDblClick
OnMouseMove = ExtListMouseMove
end
object Panel1: TPanel
Left = 0
Top = 0
Width = 526
Height = 25
Align = alTop
BevelOuter = bvNone
TabOrder = 0
object BtnSortDefault: TButton
Left = 0
Top = 1
Width = 80
Height = 25
Caption = 'Default'
TabOrder = 1
OnClick = BtnSortDefaultClick
end
object BtnSortAlphabetical: TButton
Left = 80
Top = 1
Width = 80
Height = 25
Caption = 'Alphabetical'
TabOrder = 2
OnClick = BtnSortAlphabeticalClick
end
object EdSearch: TEdit
Left = 165
Top = 3
Width = 357
Height = 21
TabOrder = 0
OnChange = EdSearchChange
OnMouseDown = EdSearchMouseDown
end
end
object PopupMenu1: TPopupMenu
Left = 208
Top = 120
object Insertintocode1: TMenuItem
Caption = 'Insert into code'
OnClick = Insertintocode1Click
end
end
end

View File

@ -0,0 +1,28 @@
object FExtMethodListInfo: TFExtMethodListInfo
Left = 76
Height = 305
Top = 99
Width = 526
BorderIcons = [biSystemMenu, biMaximize]
Caption = 'EXT Methods Info'
ClientHeight = 305
ClientWidth = 526
Font.Height = -11
Font.Name = 'Tahoma'
FormStyle = fsStayOnTop
Position = poScreenCenter
LCLVersion = '0.9.28.2'
object ExtList: TListBox
Left = 0
Height = 305
Top = 0
Width = 526
Align = alClient
Font.CharSet = ANSI_CHARSET
Font.Height = -13
Font.Name = 'Courier New'
ItemHeight = 0
ParentFont = False
TabOrder = 0
end
end

View File

@ -0,0 +1,13 @@
{ Das ist eine automatisch erzeugte Lazarus-Ressourcendatei }
LazarusResources.Add('TFExtMethodListInfo','FORMDATA',[
'TPF0'#19'TFExtMethodListInfo'#18'FExtMethodListInfo'#4'Left'#2'L'#6'Height'#3
+'1'#1#3'Top'#2'c'#5'Width'#3#14#2#11'BorderIcons'#11#12'biSystemMenu'#10'biM'
+'aximize'#0#7'Caption'#6#16'EXT Methods Info'#12'ClientHeight'#3'1'#1#11'Cli'
+'entWidth'#3#14#2#11'Font.Height'#2#245#9'Font.Name'#6#6'Tahoma'#9'FormStyle'
+#7#11'fsStayOnTop'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#8'0.9.2'
+'8.2'#0#8'TListBox'#7'ExtList'#4'Left'#2#0#6'Height'#3'1'#1#3'Top'#2#0#5'Wid'
+'th'#3#14#2#5'Align'#7#8'alClient'#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'Fo'
+'nt.Height'#2#243#9'Font.Name'#6#11'Courier New'#10'ItemHeight'#2#0#10'Paren'
+'tFont'#8#8'TabOrder'#2#0#0#0#0
]);

View File

@ -0,0 +1,223 @@
Unit Rutis_ExtMethodInfoWin;
Interface
Uses
SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Menus, Math
{$IFDEF FPC},LResources{$ENDIF};
Type
TExtMethodInfo = Record
Name : String;
Category : String;
Description : String;
IsFunction : Boolean;
ExtMethodType : Pointer;
End;
TFExtMethodListInfo = Class(TForm)
ExtList : TListBox;
Panel1 : TPanel;
BtnSortDefault : TButton;
BtnSortAlphabetical : TButton;
EdSearch : TEdit;
PopupMenu1 : TPopupMenu;
Insertintocode1 : TMenuItem;
Procedure ExtListDblClick(Sender : TObject);
Procedure FormCreate(Sender : TObject);
Procedure ExtListMouseMove(Sender : TObject; Shift : TShiftState; X, Y : Integer);
Procedure FormHide(Sender : TObject);
Procedure FormShow(Sender : TObject);
Procedure BtnSortDefaultClick(Sender : TObject);
Procedure BtnSortAlphabeticalClick(Sender : TObject);
Procedure EdSearchChange(Sender : TObject);
Procedure EdSearchMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
Procedure Insertintocode1Click(Sender : TObject);
Private
LastHoveredRow : Integer;
Procedure ShowList;
{ Private-Deklarationen }
Public
ResultIndex : Integer;
ResultExtMethod : Pointer;
//Hints : TStringList;
Sorted : Array Of Integer;
ExtMethods : Array Of TExtMethodInfo;
{ Public-Deklarationen }
End;
Implementation
{$IFNDEF FPC}
{$R *.dfm}
{$ENDIF}
Function IsStr1LowerStr2(s1, s2 : String) : Boolean;
Var
i : Integer;
Begin
i := 1;
s1 := LowerCase(s1) + #255;
s2 := LowerCase(s2) + #254;
While s1[i] = s2[i] Do
Inc(i);
Result := s1[i] < s2[i];
End;
Procedure TFExtMethodListInfo.ShowList;
Var
i : Integer;
s : String;
Begin
ExtList.Clear;
For i := 0 To high(ExtMethods) Do
Begin
If Sorted[i] < 0 Then Continue;
s := ExtMethods[Sorted[i] - 1].Name;
// If ExtMethods[Sorted[i]].IsFunction then
// s := 'Function ' + ExtMethods[Sorted[i]].Name
// else
// s := 'Procedure ' + ExtMethods[Sorted[i]].Name;
// If ExtMethods[Sorted[i]].IsFunction then
// s := 'F ' + ExtMethods[Sorted[i]].Name
// else
// s := 'P ' + ExtMethods[Sorted[i]].Name;
ExtList.Items.Add(s);
End;
Canvas.Font := ExtList.Font;
{$ifndef FPC}
ExtList.ScrollWidth := 0;
For i := 0 To ExtList.Items.Count - 1 Do
ExtList.ScrollWidth := Max(ExtList.ScrollWidth, Canvas.TextWidth(ExtList.Items[i]));
{$endif}
End;
Procedure TFExtMethodListInfo.BtnSortAlphabeticalClick(Sender : TObject);
Var
i, j : Integer;
completed : Boolean;
Begin
SetLength(Sorted, length(ExtMethods));
For i := 0 To high(ExtMethods) Do
Sorted[i] := i + 1;
Repeat
completed := True;
For i := 0 To high(ExtMethods) - 1 Do
If not IsStr1LowerStr2(ExtMethods[Sorted[i] - 1].Name, ExtMethods[Sorted[i + 1] - 1].Name) Then
Begin
j := Sorted[i];
Sorted[i] := Sorted[i + 1];
Sorted[i + 1] := j;
completed := False;
End;
Until completed;
ShowList;
End;
Procedure TFExtMethodListInfo.BtnSortDefaultClick(Sender : TObject);
Var
i : Integer;
Begin
SetLength(Sorted, length(ExtMethods));
For i := 0 To high(ExtMethods) Do
Sorted[i] := i + 1;
ShowList;
End;
Procedure TFExtMethodListInfo.EdSearchChange(Sender : TObject);
Var
i : Integer;
Begin
For i := 0 To high(ExtMethods) Do
Begin
Sorted[i] := abs(Sorted[i]);
If length(EdSearch.Text) > 0 Then
If Pos(LowerCase(EdSearch.Text), LowerCase(ExtMethods[Sorted[i] - 1].Name)) = 0 Then
Sorted[i] := -Sorted[i];
End;
ShowList;
End;
Procedure TFExtMethodListInfo.EdSearchMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
Begin
// EdSearch.SelStart := 0;
// EdSearch.SelLength := Length(EdSearch.Text);
End;
Procedure TFExtMethodListInfo.ExtListDblClick(Sender : TObject);
Begin
Insertintocode1Click(nil);
End;
Procedure TFExtMethodListInfo.ExtListMouseMove(Sender : TObject; Shift : TShiftState; X, Y : Integer);
Var
HoveredRow : Integer;
I : Integer;
Begin
HoveredRow := ExtList.ItemAtPos(Point(X, Y), True);
If (HoveredRow > -1) and
(HoveredRow < length(ExtMethods)) and
(HoveredRow <> LastHoveredRow) Then
Begin
LastHoveredRow := HoveredRow;
i := -1;
Repeat
Inc(i);
If Sorted[I] > 0 Then
Dec(HoveredRow);
Until HoveredRow < 0;
ExtList.Hint := ExtMethods[abs(Sorted[i]) - 1].Description;
Application.Hint := ExtList.Hint;
Application.HintPause := 0;
Application.HintHidePause := 60000;
{$ifndef FPC}
Application.ActivateHint(Point(X, Y));
{$endif}
End;
End;
Procedure TFExtMethodListInfo.FormCreate(Sender : TObject);
Begin
ResultIndex := -1;
LastHoveredRow := -1;
ResultExtMethod := nil;
End;
Procedure TFExtMethodListInfo.FormHide(Sender : TObject);
Begin
Application.HintPause := 2500;
End;
Procedure TFExtMethodListInfo.FormShow(Sender : TObject);
Begin
BtnSortDefault.Click;
End;
Procedure TFExtMethodListInfo.Insertintocode1Click(Sender : TObject);
Var i, item : Integer;
Begin
item := ExtList.ItemIndex;
i := -1;
Repeat
Inc(i);
If Sorted[I] > 0 Then
Dec(item);
Until item < 0;
ResultIndex := abs(Sorted[i]) - 1;
ResultExtMethod := ExtMethods[ResultIndex].ExtMethodType;
Close;
End;
Initialization
{$IFDEF FPC}
{$I Rutis_ExtMethodInfoWin.lrs}
{$ENDIF}
End.

View File

@ -0,0 +1,93 @@
Unit Rutis_INI_Settings;
Interface
Uses
SysUtils, IniFiles, registry, Rutis_Engine;
Var
Rutis_INI : TCustomIniFile;
Procedure RINISettings_Open(AppPath, ScriptPath : String);
Function RINISettings_OpenReg : Boolean;
Procedure RINISettings_OpenIni(FileName : String);
Procedure RINISettings_ApplyMainSettings(Engine : TRutisEngine);
Implementation
Procedure RINISettings_Open(AppPath, ScriptPath : String);
Begin
If FileExists(ScriptPath + '\RutisSettings.ini') Then
Begin
RINISettings_OpenIni(ScriptPath + '\RutisSettings.ini');
exit;
End;
If RINISettings_OpenReg Then exit;
SetCurrentDir(AppPath);
If FileExists('.\Rutis_Settings.ini') Then
Begin
RINISettings_OpenIni('.\Rutis_Settings.ini');
exit;
End;
If FileExists('..\Rutis_Settings.ini') Then
Begin
RINISettings_OpenIni('..\Rutis_Settings.ini');
exit;
End;
RINISettings_OpenReg;
End;
Function RINISettings_OpenReg : Boolean;
Begin
Rutis_INI.Free;
Rutis_INI := TRegistryIniFile.Create('Software\RUTIS');
Result := Rutis_INI.SectionExists('');
End;
Procedure RINISettings_OpenIni(FileName : String);
Begin
Rutis_INI.Free;
Rutis_INI := TIniFile.Create(FileName);
End;
Procedure RINISettings_ApplyMainSettings(Engine : TRutisEngine);
Var
i : Integer;
Str : String;
Begin
If Rutis_INI = nil Then
Rutis_INI := TRegistryIniFile.Create('Software\RUTIS');
//Libary Paths
SetLength(Engine.UnitFileManager.Paths, 0);
i := 0;
While True Do
Begin
Str := Rutis_INI.ReadString('Compiler\Libary', 'Path' + IntToStr(i), '');
If Str = '' Then break;
Engine.UnitFileManager.AddPath(Str);
Inc(i);
End;
//Compiler Settings
Engine.Compiler.optArrangeFields := Rutis_INI.ReadBool('Compiler', 'ArrangeRecordFields', True);
Engine.Compiler.optArrangeSize := Rutis_INI.ReadInteger('Compiler', 'RecordArrangeSize', 8);
Engine.OptProcessTimerCount := Rutis_INI.ReadInteger('VM', 'ProcessTickCount', 100000);
//SAVE SETTINGS
Rutis_INI.WriteBool('Compiler', 'ArrangeRecordFields', Engine.Compiler.optArrangeFields);
Rutis_INI.WriteInteger('Compiler', 'RecordArrangeSize', Engine.Compiler.optArrangeSize);
Rutis_INI.WriteInteger('VM', 'ProcessTickCount', Engine.OptProcessTimerCount);
End;
Initialization
Finalization
Rutis_INI.Free;
End.

1131
Units/RUTIS/Rutis_Stack.pas Normal file

File diff suppressed because it is too large Load Diff