Home Explore Help
Sign In
pascal
/
pas2js
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git
2
0
Fork 0
Files Issues 0 Wiki
Browse Source

* WorkerCommands

Michael Van Canneyt 3 months ago
parent
225f7d5de6
commit
ee68ba70b9
7 changed files with 588 additions and 0 deletions
Unified View Show Diff Stats
  1. 35 0
      demo/workercommands/hello.pas
  2. 16 0
      demo/workercommands/index.html
  3. 95 0
      demo/workercommands/main.lpi
  4. 32 0
      demo/workercommands/main.lpr
  5. 77 0
      demo/workercommands/worker.lpi
  6. 23 0
      demo/workercommands/worker.lpr
  7. 310 0
      packages/rtl/src/Rtl.WorkerCommands.pas

+ 35 - 0
demo/workercommands/hello.pas
View File 

@@ -0,0 +1,35 @@
 
+unit hello;
 
+
 
+{$mode ObjFPC}
 
+{$modeswitch externalclass}
 
+
 
+interface
 
+
 
+uses
 
+  Rtl.WorkerCommands;
 
+
 
+Type
 
+  TJSHelloCommand = class external name 'Object' (TCustomWorkerCommand)
 
+    msg : string;
 
+  end;
 
+
 
+  { TJSHelloCommandHelper }
 
+
 
+  TJSHelloCommandHelper = class helper (TCustomWorkerCommandHelper) for TJSHelloCommand
 
+    class function create(aMessage : String) : TJSHelloCommand; static;
 
+  end;
 
+
 
+
 
+
 
+implementation
 
+
 
+{ TJSHelloCommandHelper }
 
+
 
+class function TJSHelloCommandHelper.create(aMessage: String): TJSHelloCommand;
 
+begin
 
+  Result:=TJSHelloCommand(createCommand('hello'));
 
+  Result.msg:=aMessage;
 
+end;
 
+
 
+end.
 
+

+ 16 - 0
demo/workercommands/index.html
View File 

@@ -0,0 +1,16 @@
 
+<!doctype html>
 
+<html lang="en">
 
+<head>
 
+  <meta http-equiv="Content-type" content="text/html; charset=utf-8">
 
+  <title>Project1</title>
 
+  <meta name="viewport" content="width=device-width, initial-scale=1">
 
+  <script src="main.js"></script>
 
+</head>
 
+<body>
 
+  <script>
 
+    rtl.showUncaughtExceptions=true;
 
+    window.addEventListener("load", rtl.run);
 
+  </script>
 
+  <div id="pasjsconsole"></div>
 
+</body>
 
+</html>

+ 95 - 0
demo/workercommands/main.lpi
View File 

@@ -0,0 +1,95 @@
 
+<?xml version="1.0" encoding="UTF-8"?>
 
+<CONFIG>
 
+  <ProjectOptions>
 
+    <Version Value="12"/>
 
+    <General>
 
+      <Flags>
 
+        <MainUnitHasCreateFormStatements Value="False"/>
 
+        <MainUnitHasTitleStatement Value="False"/>
 
+        <MainUnitHasScaledStatement Value="False"/>
 
+      </Flags>
 
+      <SessionStorage Value="InProjectDir"/>
 
+      <Title Value="main"/>
 
+      <UseAppBundle Value="False"/>
 
+      <ResourceType Value="res"/>
 
+    </General>
 
+    <CustomData Count="6">
 
+      <Item0 Name="BrowserConsole" Value="1"/>
 
+      <Item1 Name="MaintainHTML" Value="1"/>
 
+      <Item2 Name="Pas2JSProject" Value="1"/>
 
+      <Item3 Name="PasJSLocation" Value="$NameOnly($(ProjFile))"/>
 
+      <Item4 Name="PasJSWebBrowserProject" Value="1"/>
 
+      <Item5 Name="RunAtReady" Value="1"/>
 
+    </CustomData>
 
+    <BuildModes>
 
+      <Item Name="Default" Default="True"/>
 
+    </BuildModes>
 
+    <PublishOptions>
 
+      <Version Value="2"/>
 
+      <UseFileFilters Value="True"/>
 
+    </PublishOptions>
 
+    <RunParams>
 
+      <FormatVersion Value="2"/>
 
+    </RunParams>
 
+    <Units>
 
+      <Unit>
 
+        <Filename Value="main.lpr"/>
 
+        <IsPartOfProject Value="True"/>
 
+      </Unit>
 
+      <Unit>
 
+        <Filename Value="index.html"/>
 
+        <IsPartOfProject Value="True"/>
 
+        <CustomData Count="1">
 
+          <Item0 Name="PasJSIsProjectHTMLFile" Value="1"/>
 
+        </CustomData>
 
+      </Unit>
 
+      <Unit>
 
+        <Filename Value="hello.pas"/>
 
+        <IsPartOfProject Value="True"/>
 
+      </Unit>
 
+    </Units>
 
+  </ProjectOptions>
 
+  <CompilerOptions>
 
+    <Version Value="11"/>
 
+    <Target FileExt=".js">
 
+      <Filename Value="main"/>
 
+    </Target>
 
+    <SearchPaths>
 
+      <IncludeFiles Value="$(ProjOutDir)"/>
 
+      <UnitOutputDirectory Value="js"/>
 
+    </SearchPaths>
 
+    <Parsing>
 
+      <SyntaxOptions>
 
+        <AllowLabel Value="False"/>
 
+        <UseAnsiStrings Value="False"/>
 
+        <CPPInline Value="False"/>
 
+      </SyntaxOptions>
 
+    </Parsing>
 
+    <CodeGeneration>
 
+      <TargetOS Value="browser"/>
 
+    </CodeGeneration>
 
+    <Linking>
 
+      <Debugging>
 
+        <GenerateDebugInfo Value="False"/>
 
+        <UseLineInfoUnit Value="False"/>
 
+      </Debugging>
 
+    </Linking>
 
+    <Other>
 
+      <CustomOptions Value="-Jeutf-8 -Jirtl.js -Jc -Jminclude"/>
 
+      <CompilerPath Value="$(pas2js)"/>
 
+    </Other>
 
+  </CompilerOptions>
 
+  <Debugging>
 
+    <Exceptions>
 
+      <Item>
 
+        <Name Value="EAbort"/>
 
+      </Item>
 
+      <Item>
 
+        <Name Value="ECodetoolError"/>
 
+      </Item>
 
+      <Item>
 
+        <Name Value="EFOpenError"/>
 
+      </Item>
 
+    </Exceptions>
 
+  </Debugging>
 
+</CONFIG>

+ 32 - 0
demo/workercommands/main.lpr
View File 

@@ -0,0 +1,32 @@
 
+program main;
 
+
 
+{$mode objfpc}
 
+{$modeswitch externalclass}
 
+
 
+uses
 
+  BrowserConsole, JS, Classes, SysUtils, Web, Rtl.WorkerCommands, hello;
 
+
 
+
 
+var
 
+  Worker1 : TJSWorker;
 
+  Worker2 : TJSWorker;
 
+  Cmd : TJSHelloCommand;
 
+
 
+begin
 
+  Worker1:=TJSWorker.new('worker.js?name=worker1');
 
+  CommandDispatcher.RegisterWorker(Worker1,'Worker 1');
 
+  Worker2:=TJSWorker.new('worker.js?name=worker2');
 
+  CommandDispatcher.RegisterWorker(Worker2,'Worker 2');
 
+  CommandDispatcher.RegisterCommandHandler('hello',procedure (cmd : TCustomWorkerCommand)
 
+    var
 
+      lCmd : TJSHelloCommand absolute cmd;
 
+    begin
 
+      Writeln('Received hello: ',lCmd.Msg);
 
+    end);
 
+  Cmd:=TJSHelloCommand.Create('Hello, workers!');
 
+  CommandDispatcher.BroadcastCommand(Cmd);
 
+  Cmd:=TJSHelloCommand.Create('Hello, worker 1!');
 
+  CommandDispatcher.SendCommand('Worker 1',Cmd);
 
+  Cmd:=TJSHelloCommand.Create('Hello again, worker 1!');
 
+  CommandDispatcher.SendCommand(Worker1,Cmd);
 
+end.

+ 77 - 0
demo/workercommands/worker.lpi
View File 

@@ -0,0 +1,77 @@
 
+<?xml version="1.0" encoding="UTF-8"?>
 
+<CONFIG>
 
+  <ProjectOptions>
 
+    <Version Value="12"/>
 
+    <General>
 
+      <Flags>
 
+        <MainUnitHasCreateFormStatements Value="False"/>
 
+        <MainUnitHasTitleStatement Value="False"/>
 
+        <MainUnitHasScaledStatement Value="False"/>
 
+        <Runnable Value="False"/>
 
+      </Flags>
 
+      <SessionStorage Value="InProjectDir"/>
 
+      <Title Value="worker"/>
 
+      <UseAppBundle Value="False"/>
 
+      <ResourceType Value="res"/>
 
+    </General>
 
+    <BuildModes>
 
+      <Item Name="Default" Default="True"/>
 
+    </BuildModes>
 
+    <PublishOptions>
 
+      <Version Value="2"/>
 
+      <UseFileFilters Value="True"/>
 
+    </PublishOptions>
 
+    <RunParams>
 
+      <FormatVersion Value="2"/>
 
+    </RunParams>
 
+    <Units>
 
+      <Unit>
 
+        <Filename Value="worker.lpr"/>
 
+        <IsPartOfProject Value="True"/>
 
+      </Unit>
 
+    </Units>
 
+  </ProjectOptions>
 
+  <CompilerOptions>
 
+    <Version Value="11"/>
 
+    <Target FileExt=".js">
 
+      <Filename Value="worker"/>
 
+    </Target>
 
+    <SearchPaths>
 
+      <IncludeFiles Value="$(ProjOutDir)"/>
 
+      <UnitOutputDirectory Value="js"/>
 
+    </SearchPaths>
 
+    <Parsing>
 
+      <SyntaxOptions>
 
+        <AllowLabel Value="False"/>
 
+        <UseAnsiStrings Value="False"/>
 
+        <CPPInline Value="False"/>
 
+      </SyntaxOptions>
 
+    </Parsing>
 
+    <CodeGeneration>
 
+      <TargetOS Value="nodejs"/>
 
+    </CodeGeneration>
 
+    <Linking>
 
+      <Debugging>
 
+        <GenerateDebugInfo Value="False"/>
 
+        <UseLineInfoUnit Value="False"/>
 
+      </Debugging>
 
+    </Linking>
 
+    <Other>
 
+      <CustomOptions Value="-Jeutf-8 -Jminclude -Jirtl.js"/>
 
+      <CompilerPath Value="$(pas2js)"/>
 
+    </Other>
 
+  </CompilerOptions>
 
+  <Debugging>
 
+    <Exceptions>
 
+      <Item>
 
+        <Name Value="EAbort"/>
 
+      </Item>
 
+      <Item>
 
+        <Name Value="ECodetoolError"/>
 
+      </Item>
 
+      <Item>
 
+        <Name Value="EFOpenError"/>
 
+      </Item>
 
+    </Exceptions>
 
+  </Debugging>
 
+</CONFIG>

+ 23 - 0
demo/workercommands/worker.lpr
View File 

@@ -0,0 +1,23 @@
 
+program worker;
 
+
 
+{$mode objfpc}
 
+
 
+uses
 
+  Rtl.WorkerCommands, hello;
 
+
 
+procedure echo (cmd : TCustomWorkerCommand);
 
+
 
+var
 
+  lCmd : TJSHelloCommand absolute cmd;
 
+  lResponse : TJSHelloCommand;
 
+
 
+begin
 
+  Writeln('Worker got command ',lCmd.msg);
 
+  Writeln('Sending reply');
 
+  lResponse:=TJSHelloCommand.Create('Reply to : '+lCmd.Msg);
 
+  CommandDispatcher.SendCommand(lResponse);
 
+end;
 
+
 
+begin
 
+  CommandDispatcher.RegisterCommandHandler('hello',@Echo);
 
+end.

+ 310 - 0
packages/rtl/src/Rtl.WorkerCommands.pas
View File 

@@ -0,0 +1,310 @@
 
+unit Rtl.WorkerCommands;
 
+
 
+{$mode ObjFPC}
 
+{$modeswitch externalclass}
 
+
 
+interface
 
+
 
+uses
 
+  SysUtils, JS, WebOrWorker;
 
+
 
+Type
 
+  EWorkerCommand = Class(Exception);
 
+  TCustomWorkerCommand = class external name 'Object' (TJSObject)
 
+  private
 
+    FCanceled : Boolean; external name 'canceled';
 
+    FCommand : string; external name 'command';
 
+  Public
 
+    property Command : string read FCommand;
 
+    property Canceled : Boolean read FCanceled;
 
+  end;
 
+
 
+  { TCustomWorkerCommandHelper }
 
+
 
+  TCustomWorkerCommandHelper = class helper for TCustomWorkerCommand
 
+    Procedure Cancel;
 
+    class function createCommand(aCommand : string) : TCustomWorkerCommand; static;
 
+  end;
 
+
 
+  TForwardCommand = class external name 'Object' (TCustomWorkerCommand)
 
+    DestinationWorker : string;
 
+    Payload : TCustomWorkerCommand;
 
+  end;
 
+
 
+  { TWorwardCommandHelper }
 
+
 
+  TWorwardCommandHelper = class helper (TCustomWorkerCommandHelper) for TForwardCommand
 
+    class function create(const aDestinationWorker : string; aCommand :TCustomWorkerCommand) : TForwardCommand; static;
 
+  end;
 
+
 
+
 
+  TCommandDispatcher = class;
 
+  TCommandDispatcherClass = class of TCommandDispatcher;
 
+
 
+  TCommandHandler = Reference to procedure(aCommand : TCustomWorkerCommand);
 
+  TCommandHandlerArray = array of TCommandHandler;
 
+
 
+  { TCommandDispatcher }
 
+
 
+  TCommandDispatcher = class(TObject)
 
+  private
 
+    Type
 
+       TJSWorkerReg = record
 
+         Worker : TJSWorker;
 
+         Name : string;
 
+       end;
 
+    class var _Instance : TCommandDispatcher;
 
+    class var _DispatcherClass : TCommandDispatcherClass;
 
+    class function GetInstance: TCommandDispatcher; static;
 
+  private
 
+    FMap : TJSMap; // Key is command. Value is TCommandHandlerArray.
 
+    FWorkers : Array of TJSWorkerReg;
 
+  protected
 
+    class function IsCommandEvent(aEvent: TJSEvent): Boolean;
 
+    function IndexOfWorker(aWorker: TJSWorker): Integer;
 
+    function IndexOfWorker(const aName: String): Integer;
 
+    Procedure HandleIncomingMessage(aEvent : TJSEvent);
 
+    procedure HandleCommand(aCommand: TCustomWorkerCommand); virtual;
 
+  Public
 
+    constructor create; virtual;
 
+    // Send command to worker
 
+    procedure SendCommand(aWorker : TJSWorker; aCommand : TCustomWorkerCommand); virtual;
 
+    // Send command to worker
 
+    procedure SendCommand(const aName : string; aCommand : TCustomWorkerCommand);
 
+    // Send command to thread that started this worker. Cannot be used in main thread
 
+    procedure SendCommand(aCommand : TCustomWorkerCommand); virtual;
 
+    // Send command to all registered workers
 
+    procedure BroadcastCommand(aCommand : TCustomWorkerCommand);
 
+    // Register a command handler for command aCommand
 
+    Procedure RegisterCommandHandler(const aCommand : string; aHandler : TCommandHandler);
 
+    // Remove the given command handler for command aCommand
 
+    Procedure UnRegisterCommandHandler(const aCommand : string; aHandler : TCommandHandler);
 
+    // Register a worker for broadcast
 
+    Procedure RegisterWorker(aWorker : TJSWorker; const aName : string);
 
+    // Remove a worker from broadcast list
 
+    Procedure UnRegisterWorker(aWorker : TJSWorker);
 
+    Procedure UnRegisterWorker(const aName : string);
 
+    Class function SetDispatcherClass(aClass : TCommandDispatcherClass) : TCommandDispatcherClass;
 
+    Class property instance : TCommandDispatcher read GetInstance;
 
+  end;
 
+
 
+function CommandDispatcher : TCommandDispatcher;
 
+
 
+implementation
 
+
 
+function CommandDispatcher : TCommandDispatcher;
 
+begin
 
+  Result:=TCommandDispatcher.Instance;
 
+end;
 
+
 
+{ TCustomWorkerCommandHelper }
 
+
 
+procedure TCustomWorkerCommandHelper.Cancel;
 
+begin
 
+  FCanceled:=True;
 
+end;
 
+
 
+class function TCustomWorkerCommandHelper.createCommand(aCommand: string): TCustomWorkerCommand;
 
+begin
 
+  Result:=TCustomWorkerCommand.New;
 
+  Result.FCanceled:=False;
 
+  Result.FCommand:=aCommand;
 
+end;
 
+
 
+{ TWorwardCommandHelper }
 
+
 
+class function TWorwardCommandHelper.create(const aDestinationWorker: string; aCommand: TCustomWorkerCommand
 
+  ): TForwardCommand;
 
+begin
 
+  Result:=TForwardCommand(CreateCommand('_forward'));
 
+  Result.DestinationWorker:=aDestinationWorker;
 
+  Result.Payload:=aCommand;
 
+end;
 
+
 
+{ TCommandDispatcher }
 
+
 
+class function TCommandDispatcher.GetInstance: TCommandDispatcher; static;
 
+var
 
+  C : TCommandDispatcherClass;
 
+begin
 
+  if Not Assigned(_Instance) then
 
+    begin
 
+    C:=_DispatcherClass;
 
+    if (C=Nil) then
 
+      C:=TCommandDispatcher;
 
+    _Instance:=C.Create;
 
+    end;
 
+  Result:=_Instance;
 
+
 
+end;
 
+
 
+class function TCommandDispatcher.IsCommandEvent(aEvent: TJSEvent): Boolean;
 
+var
 
+  lMessageEvent : TJSMessageEvent absolute aEvent;
 
+  Obj : TJSObject;
 
+begin
 
+  Result:=assigned(aEvent) and isObject(lMessageEvent.Data);
 
+  if Result then
 
+    begin
 
+    Obj:=TJSObject(lMessageEvent.Data);
 
+    Result:=Obj.hasOwnProperty('command') and isString(Obj['command']);
 
+    end;
 
+end;
 
+
 
+procedure TCommandDispatcher.HandleCommand(aCommand : TCustomWorkerCommand);
 
+var
 
+  lCmd : String;
 
+  lValue : JSValue;
 
+  lHandlers : TCommandHandlerArray absolute lValue;
 
+  lHandler : TCommandHandler;
 
+
 
+begin
 
+  lCmd:=aCommand.Command;
 
+  lValue:=FMap.get(lCmd);
 
+  if assigned(lValue) then
 
+    For lHandler in lHandlers do
 
+      begin
 
+      LHandler(aCommand);
 
+      if aCommand.Canceled then
 
+        break;
 
+      end;
 
+end;
 
+
 
+procedure TCommandDispatcher.HandleIncomingMessage(aEvent: TJSEvent);
 
+var
 
+  lMessageEvent : TJSMessageEvent absolute aEvent;
 
+begin
 
+  if IsCommandEvent(aEvent) then
 
+    HandleCommand(TCustomWorkerCommand(lMessageEvent.data))
 
+end;
 
+
 
+constructor TCommandDispatcher.create;
 
+begin
 
+  FMap:=TJSMap.new();
 
+  if not isMainBrowserThread then
 
+    Self_.addEventListener('message',@HandleIncomingMessage);
 
+end;
 
+
 
+procedure TCommandDispatcher.SendCommand(aWorker: TJSWorker; aCommand: TCustomWorkerCommand);
 
+begin
 
+  aWorker.postMessage(aCommand);
 
+end;
 
+
 
+procedure TCommandDispatcher.SendCommand(const aName: string; aCommand: TCustomWorkerCommand);
 
+var
 
+  Idx : integer;
 
+begin
 
+  Idx:=IndexOfWorker(aName);
 
+  if Idx<0 then
 
+    begin
 
+    // let the main dispatcher forward it.
 
+    if (isWebWorker or IsServiceWorker) then
 
+      SendCommand(TForwardCommand.create(aName,aCommand))
 
+    else
 
+      Raise EWorkerCommand.CreateFmt('Unknown worker: %s',[aName]);
 
+    end;
 
+  SendCommand(FWorkers[Idx].Worker,aCommand);
 
+end;
 
+
 
+procedure TCommandDispatcher.SendCommand(aCommand: TCustomWorkerCommand);
 
+begin
 
+  if not (isWebWorker or IsServiceWorker) then
 
+    Raise EWorkerCommand.Create('Cannot send to starting thread from main page');
 
+  asm
 
+  self.postMessage(aCommand);
 
+  end;
 
+end;
 
+
 
+procedure TCommandDispatcher.BroadcastCommand(aCommand: TCustomWorkerCommand);
 
+var
 
+  lWorker : TJSWorkerReg;
 
+begin
 
+  For lWorker in FWorkers do
 
+    SendCommand(lWorker.Worker,aCommand);
 
+end;
 
+
 
+procedure TCommandDispatcher.RegisterCommandHandler(const aCommand: string; aHandler: TCommandHandler);
 
+var
 
+  lValue : JSValue;
 
+  lHandlers : TCommandHandlerArray absolute lValue;
 
+begin
 
+  lValue:=FMap.get(aCommand);
 
+  if Assigned(lValue) then
 
+    TJSArray(LHandlers).push(aHandler)
 
+  else
 
+    begin
 
+    LHandlers:=[aHandler];
 
+    FMap.&set(aCommand,LHandlers);
 
+    end;
 
+end;
 
+
 
+procedure TCommandDispatcher.UnRegisterCommandHandler(const aCommand: string; aHandler: TCommandHandler);
 
+var
 
+  lValue : JSValue;
 
+  lHandlers : TCommandHandlerArray absolute lValue;
 
+  Idx : integer;
 
+begin
 
+  lValue:=FMap.get(aCommand);
 
+  if Assigned(lValue) then
 
+    begin
 
+    Idx:=TJSArray(LHandlers).IndexOf(aHandler);
 
+    if Idx>=0 then
 
+      Delete(LHandlers,Idx,1);
 
+    end;
 
+end;
 
+
 
+procedure TCommandDispatcher.RegisterWorker(aWorker: TJSWorker; const aName: string);
 
+var
 
+  lReg : TJSWorkerReg;
 
+begin
 
+  if IndexOfWorker(aName)>=0 then
 
+    Raise EWorkerCommand.CreateFmt('Duplicate worker name: %s',[aName]);
 
+  if IndexOfWorker(aWorker)>=0 then
 
+    Raise EWorkerCommand.Create('Duplicate worker instance');
 
+  lReg.Worker:=aWorker;
 
+  lReg.Name:=aName;
 
+  FWorkers:=Concat(FWorkers,[lReg]);
 
+  aWorker.addEventListener('message',@HandleIncomingMessage);
 
+end;
 
+
 
+function TCommandDispatcher.IndexOfWorker(aWorker: TJSWorker) : Integer;
 
+
 
+begin
 
+  Result:=Length(FWorkers)-1;
 
+  While (Result>=0) and (FWorkers[Result].Worker<>aWorker) do
 
+    Dec(Result);
 
+end;
 
+function TCommandDispatcher.IndexOfWorker(const aName : String) : Integer;
 
+
 
+begin
 
+  Result:=Length(FWorkers)-1;
 
+  While (Result>=0) and (FWorkers[Result].Name<>aName) do
 
+    Dec(Result);
 
+end;
 
+
 
+procedure TCommandDispatcher.UnRegisterWorker(aWorker: TJSWorker);
 
+var
 
+  Idx : Integer;
 
+begin
 
+  Idx:=IndexOfWorker(aWorker);
 
+  if Idx>=0 then
 
+    Delete(FWorkers,Idx,1);
 
+end;
 
+
 
+procedure TCommandDispatcher.UnRegisterWorker(const aName: string);
 
+var
 
+  Idx : Integer;
 
+begin
 
+  Idx:=IndexOfWorker(aName);
 
+  if Idx>=0 then
 
+    Delete(FWorkers,Idx,1);
 
+end;
 
+
 
+class function TCommandDispatcher.SetDispatcherClass(aClass: TCommandDispatcherClass): TCommandDispatcherClass;
 
+begin
 
+  Result:=_DispatcherClass;
 
+  _DispatcherClass:=aClass;
 
+end;
 
+
 
+end.
 
+