Skip to content

Instantly share code, notes, and snippets.

@frostney
Created May 4, 2011 03:23
Show Gist options
  • Save frostney/954706 to your computer and use it in GitHub Desktop.
Save frostney/954706 to your computer and use it in GitHub Desktop.
This is a code snippet which shows how to embed JavaScript (using BESEN, http://besen.sourceforge.net) in FreePascal/Delphi applications. I used FPC 2.5.1, compiled using "fpc -Mdelphi FPCScript.dpr" and tested under Ubuntu Linux 10.10 (32-bit).
//importScript("Test.js"); // Imports & executes Test.js
// Wohooo, JavaScript inside of JavaScript. That's meta.
execute("(function() { print('Hello world') })();");
print("--- Let's have a cake ---");
var myCake = new Cake();
myCake.Info();
print("--- I'm hungry ---");
myCake.Eat();
myCake.Info();
print("--- Then GlaDOS came along ---");
myCake.IsALie();
myCake.Info();
print("--- All right, still hungry, let's have a cookie ---");
var myCookie = new Cookie();
myCookie.Info();
myCookie.Get();
unit BakingNative;
interface
uses
Classes, SysUtils, BESEN, BESENValue, BESENObject, BESENErrors, BESENNativeObject;
type
TScriptSystem = class
public
// Imports & excute script file
procedure ImportScript(const ThisArgument:TBESENValue;Arguments:PPBESENValues;CountArguments:integer;var AResult:TBESENValue);
// Executes command
procedure Execute(const ThisArgument:TBESENValue;Arguments:PPBESENValues;CountArguments:integer;var AResult:TBESENValue);
// Prints text in command line
procedure Print(const ThisArgument:TBESENValue;Arguments:PPBESENValues;CountArguments:integer;var AResult:TBESENValue);
end;
TBakedGoods = class(TBESENNativeObject)
private
fWeight: Integer;
fName: String;
protected
procedure ConstructObject(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer); Override;
public
constructor Create(AInstance: TObject; APrototype: TBESENObject=nil; AHasPrototypeProperty: longbool=false); Overload; Override;
published
property Name: String read fName;
property Weight: Integer read fWeight write fWeight;
end;
TCake = class(TBakedGoods)
protected
procedure ConstructObject(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer); Override;
public
constructor Create(AInstance: TObject; APrototype: TBESENObject=nil; AHasPrototypeProperty: longbool=false); Overload; Override;
published
procedure Eat(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
procedure IsALie(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
procedure Info(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
end;
TCookie = class(TBakedGoods)
protected
procedure ConstructObject(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer); Override;
public
constructor Create(AInstance: TObject; APrototype: TBESENObject=nil; AHasPrototypeProperty: longbool=false); Overload; Override;
published
procedure Get(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
procedure Info(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
end;
procedure RunScript(const Filename: String);
procedure ExecuteCommand(const Command: String);
var
BesenInst: TBesen;
implementation
procedure TScriptSystem.ImportScript(const ThisArgument:TBESENValue;Arguments:PPBESENValues;CountArguments:integer;var AResult:TBESENValue);
begin
RunScript(TBESEN(BesenInst).ToStr(Arguments^[0]^));
end;
procedure TScriptSystem.Execute(const ThisArgument:TBESENValue;Arguments:PPBESENValues;CountArguments:integer;var AResult:TBESENValue);
begin
ExecuteCommand(TBESEN(BesenInst).ToStr(Arguments^[0]^));
end;
procedure TScriptSystem.Print(const ThisArgument:TBESENValue;Arguments:PPBESENValues;CountArguments:integer;var AResult:TBESENValue);
begin
WriteLn(TBESEN(BesenInst).ToStr(Arguments^[0]^));
end;
constructor TBakedGoods.Create(AInstance: TObject; APrototype: TBESENObject=nil; AHasPrototypeProperty: longbool=false);
begin
inherited Create(AInstance, APrototype, AHasPrototypeProperty);
fName := 'Not baked yet.';
Self.Weight := 0;
end;
procedure TBakedGoods.ConstructObject(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
begin
inherited ConstructObject(ThisArgument, Arguments, CountArguments);
end;
constructor TCake.Create(AInstance: TObject; APrototype: TBESENObject=nil; AHasPrototypeProperty: longbool=false);
begin
inherited Create(AInstance, APrototype, AHasPrototypeProperty);
fName := 'Cake';
Self.Weight := 1250;
end;
procedure TCake.ConstructObject(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
begin
inherited ConstructObject(ThisArgument, Arguments, CountArguments);
end;
procedure TCake.Eat(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
begin
Self.Weight := Self.Weight - 250;
if Self.Weight < 0 then Self.Weight := 0;
end;
procedure TCake.Info(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
begin
WriteLn(Format('Name: %s; Weight: %d g', [Self.Name, Self.Weight]));
end;
procedure TCake.IsALie(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
begin
Self.Weight := 0;
fName := '(Imaginary) Cake';
end;
constructor TCookie.Create(AInstance: TObject; APrototype: TBESENObject=nil; AHasPrototypeProperty: longbool=false);
begin
inherited Create(AInstance, APrototype, AHasPrototypeProperty);
fName := 'Cookie';
Self.Weight := 200;
end;
procedure TCookie.ConstructObject(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
begin
inherited ConstructObject(ThisArgument, Arguments, CountArguments);
end;
procedure TCookie.Get(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
begin
WriteLn('You got a cookie');
end;
procedure TCookie.Info(const ThisArgument: TBESENValue; Arguments: PPBESENValues; CountArguments: integer);
begin
WriteLn(Format('Name: %s; Weight: %d g', [Self.Name, Self.Weight]));
end;
procedure RunScript(const Filename: String);
var f: TStream;
s: TStringStream;
cmd: String;
begin
if Trim(Filename) = '' then
begin
WriteLn('No valid script file specified.');
Exit;
end;
if not FileExists(Filename) then
begin
WriteLn('File does not exist: ' + Filename);
Exit;
end;
if ExtractFileExt(Filename) <> '.js' then
WriteLn('Warning: ' + Filename + ' may not be a valid JavaScript file');
f := TFileStream.Create(Filename, fmOpenRead);
try
s := TStringStream.Create('');
try
s.CopyFrom(f,f.Size);
cmd := s.DataString;
finally
s.Free;
end;
finally
f.Free;
end;
try
BesenInst.Execute(cmd);
except
on e: EBESENError do
WriteLn(Format('%s ( %s | Line %d ): %s', [e.Name, Filename, TBESEN(BesenInst).LineNumber, e.Message]));
on e: exception do
WriteLn(Format('%s ( %s | Line %d ): %s', ['Exception', Filename, TBESEN(BesenInst).LineNumber, e.Message]));
end;
end;
// Execute JavaScript command(s)
procedure ExecuteCommand(const Command: String);
begin
try
BesenInst.Execute(Command);
except
on e: EBESENError do
WriteLn(e.Name + ': ' + BesenInst.ToStr(e.Value));
end;
end;
end.
program FPCScript;
uses
BakingNative, BESEN, BESENConstants, BESENObjectGlobal, BESENValue, BESENObject, BESENNativeObject;
var
ScriptSystem: TScriptSystem;
begin
// Create BESEN instance
BesenInst := TBesen.Create(COMPAT_JS); //< We want JavaScript compability at all costs
BesenInst.RecursionLimit := 128;
ScriptSystem := TScriptSystem.Create;
// Register global functions
TBESEN(BesenInst).ObjectGlobal.RegisterNativeFunction('importScript', ScriptSystem.ImportScript, 1, []);
TBESEN(BesenInst).ObjectGlobal.RegisterNativeFunction('execute', ScriptSystem.Execute, 1, []);
TBESEN(BesenInst).ObjectGlobal.RegisterNativeFunction('print', ScriptSystem.Print, 1, []);
// Register our baking goodness
BesenInst.RegisterNativeObject('BakedGoods', TBakedGoods);
BesenInst.RegisterNativeObject('Cake', TCake);
BesenInst.RegisterNativeObject('Cookie', TCookie);
// Embed Javascript file: Baking.js
RunScript('Baking.js');
// Free BESEN instance
BesenInst.Free;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment