Created
May 4, 2011 03:23
-
-
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).
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
//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(); |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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. |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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