Writing a Delphi WebSocket server and Smart Mobile Client in 15 minutes

Websocket is all the rage these days. In essence its just an extra layer built on top of ordinary HTTP (available as a snap-in for IIS and “mod” for apache). But Delphi developers like to build their solutions from the ground up! So what could possibly be better than to roll your own?

Indy to the rescue

No I didnt see you playing with your sockets SIR!

Think of client-server programming and Delphi and chances are “indy” will be the first word to pop into your mind. It’s been there for ages, it’s rock solid, it supports every known RFC known to mankind – and it’s tried and tested by time. It may not provide the same speed as Microsoft Internet Explorer or Apache, but there are hundreds (if not thousands) of products out there built with the Indy library, so it’s pretty damn awesome!

But what about websocket? As far as standards go it’s the new kid on the block – invented more or less purely for secure HTML5/JavaScript development. Does Indy have that yet? Well, no. I’m sure it will be included at one point in a future update, but thankfully Indy is easy to extend and mold due to it’s purely object oriented nature.

A while back mr. Andre Mucche took the time to implement just that, extending an ordinary Indy HTTP server with the required plumbing – turning a bog standard, multi-threaded, multi-context HTTP server into a websocket nerdvana.

Why is this important?

If all you do is write old-school stuff in Delphi then you probably don’t need it, but if you want to keep up with the way technology is moving – then WebSockets is bound (pun intended) to cross your path sooner or later. If you havent already been asked by your customers, it’s only a matter of time before you are approached with the question “Can we poll data from our Delphi solution and use that on our website from JavaScript?”.

Well, there are many ways to deal with getting data from a Delphi centric solution (read: server) onto your website. You can spend weeks and months writing the JavaScript yourself, you can publish a few DataSnap API’s — or go for RemObjects SDK which IMHO is a much better alternative to DataSnap.

But Smart Mobile Studio offers an alternative route. The benefits should be fairly obvious:

• You write object pascal (Delphi / FreePascal)
• You don’t have to learn much JavaScript
• All the low-level stuff is already wrapped and ready
• Smart Mobile supports both RemObjects, DataSnap and Websocket (and a few more)

So how hard is it to create a Delphi websocket server and a Smart Mobile Studio client?

The Delphi side

Right, first start by creating a folder for your project. In my example I just named it “WebSocket”. Then create a fresh Delphi project (VCL) and save that into the folder as “SocketServer.dpr”.

Next, download Andre’s WebSocket extension units, these can be found here: https://github.com/andremussche/DelphiWebsockets. It’s Github so just download the zip archive. Once downloaded, unzip the files into your project folder. Your folder should look something like this by now:

Quick and dirty

With the files in place, add all the units to your project inside Delphi (including the superobject files). You dont really have to do this, you can unzip the files wherever you like — but for this quick demonstration I just stuff it all into the same project to avoid setting a path (it’s late, what can I say). Your Delphi project should now look like this:

Easy as apple-pie

With that in place, let’s add a TMemo component, a couple of buttons to control the server (start and stop) and isolate that in TActions. If you havent used actions before then please read up on that before you continue. It’s super simple and one of Delphi’s biggest strength’s over other RAD platforms out there. My form looks like this (just slap-dash 2 second stuff):

Not much to look at, but bling comes last

Now let’s write some code!

unit mainform;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,

  IdComponent,
  IdContext,
  IdCustomHTTPServer,
  IdServerWebsocketContext,
  IdServerSocketIOHandling,
  IdWebsocketServer, Vcl.StdCtrls, System.Actions, Vcl.ActnList;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    ActionList1: TActionList;
    acStart: TAction;
    acStop: TAction;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure acStartExecute(Sender: TObject);
    procedure acStopExecute(Sender: TObject);
    procedure acStartUpdate(Sender: TObject);
    procedure acStopUpdate(Sender: TObject);
  private
    { Private declarations }
    FServer:    TIdWebsocketServer;

    procedure   HandleServerStatus(ASender: TObject;
                const AStatus: TIdStatus;
                const AStatusText: string);

    procedure   HandleTextMessage(const AContext: TIdServerWSContext;
                const aText: string);

    procedure   HandleCommandGet(AContext: TIdContext;
                ARequestInfo: TIdHTTPRequestInfo;
                AResponseInfo: TIdHTTPResponseInfo);

  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.acStartExecute(Sender: TObject);
begin
  FServer.Active:=True;
end;

procedure TForm1.acStartUpdate(Sender: TObject);
begin
  TAction(sender).Enabled := not FServer.Active;
end;

procedure TForm1.acStopExecute(Sender: TObject);
begin
  FServer.Active := false;
end;

procedure TForm1.acStopUpdate(Sender: TObject);
begin
  TAction(sender).Enabled := FServer.Active;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FServer := TIdWebsocketServer.Create(NIL);
  FServer.OnStatus := HandleServerStatus;
  FServer.OnMessageText := HandleTextMessage;
  FServer.OnCommandGet := HandleCommandGet;
  FServer.KeepAlive := True;
  FServer.DefaultPort := 8080;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FServer.free;
end;

procedure TForm1.HandleCommandGet(AContext: TIdContext;
          ARequestInfo: TIdHTTPRequestInfo;
          AResponseInfo: TIdHTTPResponseInfo);
begin
  aResponseInfo.ContentText:='Hello world';
end;

procedure TForm1.HandleTextMessage(const AContext: TIdServerWSContext;
          const aText: string);
begin
  memo1.Lines.Add(aText);
end;

procedure TForm1.HandleServerStatus(ASender: TObject;
          const AStatus: TIdStatus;
          const AStatusText: string);
begin
  memo1.Lines.Add(aStatusText);
end;

end.

That’s basically it! The most bare-bone WebSocket server you will ever see. It just accepts a connection and dumps whatever text a client writes to the memo control on the form.
Right, now let’s look at the Smart Mobile Studio side of things.

The HTML5 Client

Fire up Smart Mobile Studio (im using the latest beta here) and create a new project. Remember to save the project before you start coding.
We will be adding a single button for connecting to the websocket server, and then a textbox for message input — and finally a “send” button to ship the next to the server.

This is what my slap-dash client looks like

With some components in place we move on to the WebSocket client code, which under the Smart Mobile RTL is a piece of cake:

unit Form1;

interface

uses 
  SmartCL.inet,
  SmartCL.System, SmartCL.Graphics, SmartCL.Components, SmartCL.Forms, 
  SmartCL.Fonts, SmartCL.Borders, SmartCL.Application, SmartCL.Controls.Button,
  SmartCL.Controls.Memo, SmartCL.Controls.EditBox;

type
  TForm1 = class(TW3Form)
    procedure W3Button2Click(Sender: TObject);
    procedure W3Button1Click(Sender: TObject);
  private
    {$I 'Form1:intf'}
    FSocket:  TW3WebSocket;
  protected
    procedure InitializeForm; override;
    procedure InitializeObject; override;
    procedure Resize; override;
  end;

implementation

{ TForm1 }

procedure TForm1.W3Button1Click(Sender: TObject);
begin
  try
    FSocket.Connect('ws://192.168.10.106:8080',[]);
  except
    on e: exception do
    showmessage(e.message);
  end;
end;

procedure TForm1.W3Button2Click(Sender: TObject);
var
  mText:String;
begin
  mText :=trim(w3Editbox1.text);

  if mtext.length > 0 then
    FSocket.Write(mText);

  w3Editbox1.text := '';
end;

procedure TForm1.InitializeForm;
begin
  inherited;
  // this is a good place to initialize components
  FSocket := TW3WebSocket.Create;
  FSocket.OnOpen := procedure (sender:TW3WebSocket)
    begin
      w3memo1.text := w3memo1.text + "WebSocket open" + #13;
    end;
end;

procedure TForm1.InitializeObject;
begin
  inherited;
  {$I 'Form1:impl'}
end;
 
procedure TForm1.Resize;
begin
  inherited;
end;
 
initialization
  Forms.RegisterForm({$I %FILE%}, TForm1);
end.

The final result

Now fire up your Delphi project, click the “start” button to initialize the server (note: the firewall may ask you to allow the server to use the port, remember to check “local networks” and just click “ok”). Your Delphi server should now run at port 8080 — use your favorite browser to check that it works. It should return “hello world” (see “HandleCommandGet” event handler in the Delphi code).

Next, fire up your Smart Mobile Studio project. Hit the “Connect” button, type something in the text-field and click “send” to ship it off to the server. Now watch the memo on the server and voila — you have just written your first websocket client/server system in less than 15 minutes!

Websocket has never been easier!

Note: Remember to use your local IP. The IP listed in the SMS example above is just a local address on my local network. If you are running Delphi and SMS on the same machine, just use 127.0.0.1 and bob’s your uncle.

Enjoy!

Structures, dealing with name-pairs

A small article on dealing with dynamically created, in-memory “records”. Head over to www.smartmobilestudio.com and have a peek 🙂

Smart Mobile Studio, datasets and websockets

It’s all about the bytes

If you have been playing with the beta you have probably noticed a few cool new units in the RTL. First there is system.memory, system.typecon, followed by system.streams. And last but not least: system.dataset.

What’s so special about these units? Well, they give you the same level of low-level (read: byte) access as you enjoy under Delphi. If you know your way around JavaScript you must have noticed that this is a sensitive subject, a really sensitive subject (!). JavaScript is hopeless when it comes to binary data, and there is no such thing as a “stream” in the browser.

You wont believe some of the solutions out there which pass for “top notch” JavaScript. Most of them involving cheap hacks like stuffing bin-hex’ed data into strings. This means you need a separate layer of encoding before you push the data to a server (or de-serialize it to JSON). Well we dont have that problem 🙂

So, with all these units firmly in place we can now enjoy the same level of power, simplicity and elegance as under native Delphi or freepascal. And this is where TW3Dataset comes in. Because it’s actually a fully OOP dataset which saves to a very simple binary format (!)

TW3Dataset

Fast, binary, pure object pascal

Let’s say you have a mobile solution which needs to store uniform data. It can be a phone-book, a list of high-scores for a game, time samples or your latest RSS feed poll. Traditionally you would sculpt it all using arrays and then serialize the whole shabam to JSON; or even worse: make use of WebSQL, PouchDB, TaffyDB or other JavaScript dependencies.

Well that is now a thing of the past. For simple in-memory dataset chores, TW3Dataset covers your basic needs more than adequate. It also saves to TStream, meaning that saving and loading from the new storage system (more about that later) is reduced to a “one liner”.

Is it hard to use?

Nope. In fact it’s even simpler to use than TClientDataset under Delphi (or more or less identical, except with no indexing just yet). Here is a short example of how to create a dataset, populate it and save it to a stream:

var
  mDataset: TW3Dataset;
  mData:  TStream;
  x:  Integer;
begin
  mDataset := TW3Dataset.create;
  try

    mDataset.FieldDefs.Add('id',ftAutoInc);
    mDataset.FieldDefs.add('name',ftString);
    mDataset.CreateDataset;

    for x:=1 to 1000 do
    begin
      mDataset.append;
      mDataset.Fields.FieldByName('name').AsString := 'Name #' + x.toString;
      mDataset.Post;
    end;

    mData := TMemoryStream.create;
    try
      mDataset.SaveToStream(mData);

      writeln('Dataset bytesize = ' + mData.size.toString);

    finally
      mData.free;
    end;

  finally
    mDataset.free;
  end;

As you can see from the code above some calculated field types are supported (Autoinc), and TW3Dataset is going to see some heavy expansion as it’s merged with my universal DB framework. Think FireDac but for the browser.

Other cool stuff

If TW3Dataset is to limited and you want SQL support, Smart Mobile Studio now ships with SQLite compiled for JavaScript. Yes you read right, SQlite has been compiled for JavaScript and reads, writes and generates identical files to the native SQLite versions. That’s pretty darn cool (although it does add 1 megabyte to your apps).

So in fact, you can now create and populate a full SQLite DB and just ship it to your server “as is”. Add encryption and you have a pretty good syncronization layer to play with.

W3C, WC3 or just WC

SQLite used to be built into modern browsers, then dubbed “WebSQL”; but in their infinite wisdom the W3C decided to deprecate that and go for a key-value pair storage system reminicient of MongoDB on wellfare. The good news is that our RTL is now so powerful that we dont need to care about the whims of the W3C any more. Just like Delphi revolutionized database driven desktop application development in the 90’s — we will revolutionize DB driven JavaScript applications for the modern age.

True binary streams? You got it! Compression routines ported directly from Delphi? No problem. In-memory databases? Yup!

Websockets made human

Websocket, oh what a magical buzzword! With all the hype you should think it was black magic. Well our SmartCL.Inet unit has now been expanded with a very cool WebSocket client. This means that if you want to talk directly with a nodeJS installation, or perhaps even better — write your own websocket server and get into Amazon cloud services for next to nothing, the RTL now makes that possible.

Writing a websocket client is now reduced to:

  FSocket.Connect("wss://echo.websocket.org",[]);
  FSocket.OnOpen:=Procedure (Sender:TW3WebSocket)
    begin
      writeln("Socket connected");
      Sender.Write("Rock it with HTML5 WebSocket");
    end;
  FSocket.OnClosed:=procedure (Sender:TW3WebSocket)
    begin
      Writeln("Socket disconnected");
    end;
  FSocket.OnMessage:=Procedure (Sender:TW3WebSocket;Data:String)
    begin
      Writeln("Data received:" + Data);
    end;
  FSocket.OnError:=Procedure (Sender:TW3WebSocket)
    begin
      writeln("Socket has errors");
    end;

File storage for the rest of us

Sandboxed files and JavaScript is a complete mess. JavaScript is utterly event driven, wich means that everything requires callback handlers. From accessing a medium, to being allowed said access to creating a writer and finally do the actual writing (phew!). And each event handler must denote the calling context just for the hell of it.

To make this usable by human beings, the RTL introduces a concept called “file-actions”. They work more or less like TAction under Delphi, but are especially tailored for loading and saving data in a uniform way.

Here is an example of saving and then loading back a small file:

procedure TForm1.W3Button4Click(Sender: TObject);
var
  mAction:  TFileActivitySave;
begin
  mAction:=TFileActivitySave.Create;
  mAction.FileName:="document.txt";
  mAction.FileMode:=fmPermanent;
  mAction.OnExecute:=procedure (sender:Tobject)
    begin
      writeln("Saving done");
      var mLoader:=TFileActivityLoad.Create;
      mLoader.FileData:=TMemoryStream.Create;
      mLoader.FileName:='document.txt';
      mLoader.FileMode:=fmPermanent;
      mLoader.OnExecute:=Procedure (sender:TObject)
        begin
          writeln("Loading done!");
          writeln("Bytes ready = " + mLoader.FileData.Size.tostring);
          try
            var mReader:=TReader.Create(mLoader.FileData);
            writeln(mReader.ReadString);
          except
            on e: exception do
            writeln(e.message);
          end;
        end;
      mLoader.Execute;
    end;
  mAction.FileData:=TMemoryStream.Create;
  var mTemp:=TWriter.Create(mAction.FileData);
  mTemp.WriteString("This is some data");
  mAction.Execute;
end;

As you begin to explore the additions to the RTL in the next release, you will find that a lot of time and effort has gone into this. So I hope everyone get’s excited when they what they can now do — and that object pascal is the perfect language for HTML5 and mobile application development!

Smart Mobile Studio, update right around the corner

So I havent been able to write much about Smart Mobile Studio the past six months. For those of you that read my blog you will notice that I made it quite clear that at least six months would pass before I could start to allocate time for blogging again. Between then and now I have moved house, got a new job and we’ve also had a long national holiday.

Doing it properly

On the surface things may appear to be slow, but behind the scenes the team has been working like mad. Not just with fixing bugs and beta-testing the new features, but also with establishing a proper company with proper funding and real-life shares. These are things you dont just slap together because it has a 1:1 impact on every single task, from customer support to technical growth. We love our product so much and we know from experience that it has, can and will make a huge impact on modern software development. These administrative topics are being finalized right now, which can only be regarded as happy news for everyone.

As for progress we like to keep things tidy, meaning that we stick to our bug reports as reported by customers and beta-testers. I get a lot of messages on facebook, emails and even the odd text-message about a bug or missing feature — but please note that we stick to fixing bugs that come in via the proper channels. And we have taken every single bug our now extended beta program has produced and done something about it. As with all living products there are always things, but rest assured that we are not resting on our laurels. And we are not going anywhere.

Next there is support and legacy work. If you have downloaded the beta release you may have noticed that Smart Mobile now gives you methods like allocmem, freemem, move, fillchar, reallocmem, streams (proper stuff, not just slap dash string manipulation), buffer classes and all the “missing” bits and pieces which makes the product stand out.

Javascript doesnt have this out of the box. So bringing things like pointers (references) and memory management into the RTL has been quite a challenge. Not just from a programming point of view, but also with regards to legacy browsers. A lot of people are still using older phones and not all of them supports UInt8 and UInt8Clamped datatypes. This is a pickle no doubt about it.

One of the first things we noticed on releasing the new RTL sub-layer, was in fact that UInt8ClampedArray only works on modern browsers, the absolute latest stuff (which I must admit was my fault because I’m a tech junky and always have the latest to play with). Older versions of IE, and even some variations of webkit for android lack this particular extension. And while I’m tempted to say “get a proper phone”, thats not how it works in real life. Its our job to try and be as compatible as possible. Which means time and effort.

To solve this I had to backtrack and make due with UInt8Array which is just as fast as the clamped version, but with a few limitations here and there – depending on how you use it. Thankfully my initial architecture of the RTL saved my bacon, because I’ve isolated “intrinsic conversion routines” (and reverse) in it’s own class, so we dont have clamped arrays all over the place to deal with. All it took was a few adjustments and we should now support a more rich set of mobile devices.

Having said that, altering the RTL to use a new type is not without it’s challenges; you still have to test, test and test again to make sure it works as expected. I sure as hell wont submit to “gimmic” solutions deployed by our competitors – namely stuffing bin/hex bytes in strings. It may be clever and it may work – but the price is speed, memory bloating and .. well its just not what Smart Mobile Studio is about.

Whats so important about old-time allocmem anyways?

Up to this point Smart Mobile Studio has been strides beyond typescript and other competitors technically. They have more components and things like that, but they also have a language which sounds exactly like if you insert something into, or indeed, take something out – of a cat. All those stupid curley-wurley brackets, lack of structure — and working with “real” data, like raw binary files and binary file-formats requires you to use esoteric libraries with tons of code. It’s ridicules to watch how they manage to get away with it, but kids with no knowledge of object pascal lap it up like catnip. Well we want something better!

Being able to write object oriented, fully memory capable applications is what makes FreePascal and Delphi such a joy to use for the desktop, and we want the same for nodeJS and the browser. Take something simple, like generating a PDF document on your nodeJS server. Should it really takes thousands of lines of code just to produce a binary file correctly? No. It should be no different than working with Delphi or FreePascal. Things like streams, encoding and decoding intrinsic types, working with arrays of bytes (and so on) should just work. But all such features requires a standard way to deal with memory: from allocating to reading and writing bytes, longwords or even bits !

Being able to allocate memory, scale memory, move chunks of memory around and ultimately read and write to the memory — this is the foundation on which streams and buffers rest. Without it we are left with “hacks” like we see other vendors provide. And since the browser exposes said functionality (albeit in an alien form compared to WinAPI) it’s imperative that we make use of it.

To give you some sense of what’s being written, here is one of 4 units dealing exclusively with the memory issue:

 

unit System.Memory;

interface

uses
  System.Types,
  System.TypeCon,
  W3C.TypedArray,
  SmartCL.System;

type

  TAllocation = Class;
  TAllocationOptions  = Class;

  (* TAllocation represents a single, managed memory allocation
     segment. It exposes the bare-bone information about the
     memory segment, such as length, buffer reference
     and handle. It also includes the most basic, simple low-level
     functions for scaling the memory, re-allocating the
     memory (with data persistence) and releasing the allocation *)
  EAllocation = Class(EW3Exception);
  TAllocation = Class(TObject,IDataTransport)
  private
    FHandle:    TMemoryHandle;
    FSize:      Integer;
    FOptions:   TAllocationOptions;

    (* IMPLEMENTS:: IDataTransport *)
    function    dataGetSize:Integer;
    function    dataRead(const Offset:Integer;
                const ByteCount:Integer):TByteArray;
    procedure   dataWrite(const Offset:Integer;
                const Bytes:TByteArray);
    function    dataOffset:Integer;
  protected
    Procedure   HandleAllocated;virtual;
    Procedure   HandleReleased;virtual;
    function    getTotalSize:Integer;virtual;
    function    getSize:Integer;virtual;
    function    getBufferHandle:TBufferHandle;virtual;
    function    getHandle:TMemoryHandle;virtual;
  public
    Property    Options:TAllocationOptions read FOptions;
    Property    Empty:Boolean read (not (FHandle));
    property    Allocated:Boolean read ( (FHandle) );
    property    Handle:TMemoryHandle read getHandle;
    Property    Buffer:TBufferHandle read getBufferHandle;
    Property    Size:Integer read getSize;
    Property    TotalSize:Integer read getTotalSize;

    Procedure   Transport(const Target:IDataTransport);

    procedure   Allocate(Bytes:Integer);
    procedure   Release;
    procedure   Grow(const Bytes:Integer);
    procedure   Shrink(const Bytes:Integer);
    procedure   ReAllocate(Const NewSize:Integer);
    Constructor Create;virtual;
    Destructor  Destroy;Override;
  end;

  (*  TAllocationOptions defined caching options for TAllocation.
      Caching means that TAllocation will always allocate extra data which
      it uses for faster growth. So if you allocate 45 bytes and have a
      cache-size of 1024, the number of actual bytes allocated will be 1069.
      Once allocated, growth will take memory from the cache rather than
      re-allocate memory directly, which is much faster.
      After the initial allocation, only when the cache is exhausted will
      another allocation be performed *)
  TAllocationOptions = Class(TW3OwnedObject)
  private
    FUseCache:  Boolean;
    FCacheSize: Integer;
  protected
    Procedure setUseCache(const Value:Boolean);
    procedure setCacheSize(value:Integer);
    function  getCacheUsed:Integer;
    function  getCacheFree:Integer;
  public
    property    Owner: TAllocation read ( TAllocation(Inherited Owner) );
    Property    UseCache:Boolean read FUseCache write setuseCache;
    Property    CacheSize:Integer read FCacheSize write setCacheSize;
    Property    CacheUsed:Integer read getCacheUsed;
    Property    CacheFree:Integer read getCacheFree;
    constructor Create(AOwner: TAllocation); reintroduce;
  end;

  (* TAddress is a marshaled pointer type. JavaScript does not support
     pointers out of the box, so when dealing with memory allocations
     and offsets into such a buffer, which is what a pointer in essence
     represents -- you can replace FreePascal/Delphi pointer types with
     a marshaled pointer.

     Where you under FreePascal or Delphi would write:

        Move(Source^,target^,Size);

     Smart Pascal now supports:

        TMarshal.Move(TAddressSource.Create(FSource,0),
          TAddressTarget.Create(FTarget,0),FSource.Size);

     TMarshal supports variations of typical memory operations, both
     on the level of handle (TMemoryHandle) and TAddress pointers. *)
  EAddress  = Class(EW3Exception);
  TAddress  = partial class(TObject)
  private
    FOffset:    Integer;
    FBuffer:    TMemoryHandle;
  public
    Property    Entrypoint:Integer read FOffset;
    Property    Segment:TMemoryHandle read FBuffer;
    Property    Size:Integer read ( JArrayBuffer(FBuffer).byteLength );
    function    Addr(const Index:Integer):TAddress;
    Constructor Create(const aSegment:TMemoryHandle;
                const aEntrypoint:Integer);overload;virtual;
    Destructor  Destroy;Override;
  end;

  (* TUnmanaged is a static class with a collection of un-managed
     (non marshaled pointers) functions for allocating and accessing
     memory allocations. These are best suited for advanced users *)
  TUnManaged = Class static
  public
    class function  AllocMemA(const Size:Integer):TMemoryHandle;

    class procedure FreeMemA(const Memory:TMemoryHandle);

    class function  ReAllocMemA(Memory:TMemoryHandle;
                    Size:Integer):TMemoryHandle;

    class function  ReadMemoryA(const Memory:TMemoryHandle;
                    const Offset:Integer;
                    Size:Integer):TMemoryHandle;overload;

    class function  WriteMemoryA(const Memory:TMemoryHandle;
                    const Offset:Integer;
                    const Data:TMemoryHandle):Integer;

    class procedure FillMemoryA(const Memory:TMemoryHandle;
                    const Offset:Integer;
                    Size:Integer;
                    const Data:TMemoryHandle);
  end;

  (* TMarshal is a class which contains methods for allocating
     managed (marshaled) pointers, moving data quickly between memory
     segments - and also it provides some legacy methods from native
     object pascal, such as Move(), FillChar(), AllocMem() and FreeMem() *)
  TMarshal = class static
  public
    class property  UnManaged:TUnManaged;
    class function  AllocMem(const Size:Integer):TAddress;
    class procedure FreeMem(Const Segment:TAddress);

    class procedure Move(const Source:TAddress;
                    const Target:TAddress;
                    const Size:Integer);overload;

    class procedure Move(const Source:TMemoryHandle;
                    const SourceStart:Integer;
                    const Target:TMemoryHandle;
                    const TargetStart:Integer;
                    const Size:Integer);overload;

    class Procedure FillChar(const Target:TAddress;
                    const Size:Integer;
                    const Value:String);overload;

    class procedure FillChar(const Target:TAddress;
                    const Size:Integer;
                    const Value:Byte);overload;

    class procedure ReAllocMem(var Segment:TAddress;
                    const Size:Integer);

    class function  ReadMemory(const Segment:TAddress;
                    const Size:Integer):TByteArray;overload;

    class procedure WriteMemory(const Segment:TAddress;
                    const Data:TByteArray);

    class procedure Fill(Const Buffer:TMemoryHandle;Offset:Integer;
                    ByteLen:Integer;const Value:Byte);
  end;

implementation

//############################################################################
// TAllocationOptions
//############################################################################

constructor TAllocationOptions.Create(AOwner: TAllocation);
begin
  inherited Create(AOwner);
  FCacheSize:=4096;
  FUseCache:=true;
end;

function TAllocationOptions.getCacheFree:Integer;
begin
  result:=FCacheSize - getCacheUsed;
end;

function TAllocationOptions.getCacheUsed:Integer;
begin
  if FUseCache then
  result:=FCacheSize - (owner.Handle.length - owner.Size) else
  result:=0;
end;

Procedure TAllocationOptions.setUseCache(const Value:Boolean);
begin
  FUseCache:=Value;
end;

procedure TAllocationOptions.setCacheSize(value:Integer);
begin
  FCacheSize:=TInteger.EnsureRange(Value,1024,1024 * 1000);
end;

//############################################################################
// TAllocation
//############################################################################

Constructor TAllocation.Create;
Begin
  inherited Create;
  FOptions:=TAllocationOptions.Create(self);
end;

Destructor TAllocation.Destroy;
begin
  if (FHandle) then
  Release;
  FOptions.free;
  inherited;
end;

Procedure TAllocation.Transport(const Target:IDataTransport);
var
  mOffset:  Integer;
begin
  if assigned(target) then
  begin
    if not Empty then
    begin
      try
        mOffset:=Target.dataOffset;
        Target.dataWrite(mOffset,
        TDataType.TypedArrayToBytes(TW3DefaultBufferType(Handle)));
      except
        on e: exception do
        Raise EAllocation.CreateFmt
        ('Data transport failed, mechanism threw exception %s with error [%s]',
        [e.classname,e.message]);
      end;
    end;
  end else
  Raise EAllocation.Create
  ('Invalid transport interface, reference was NIL error');
end;

// INTERFACE: IDataTransport
function TAllocation.dataOffset:Integer;
begin
  result:=0;
end;

// INTERFACE: IDataTransport
function TAllocation.dataGetSize:Integer;
Begin
  result:=getSize;
end;

// INTERFACE: IDataTransport
function TAllocation.dataRead(const Offset:Integer;
         const ByteCount:Integer):TByteArray;
var
  mRef: TMemoryHandle;
begin
  mRef:=TUnManaged.ReadMemoryA(Handle,Offset,ByteCount);
  result:=TDatatype.TypedArrayToBytes(TW3DefaultBufferType(mRef));
end;

// INTERFACE: IDataTransport
procedure TAllocation.dataWrite(const Offset:Integer;
          const Bytes:TByteArray);
begin
  TUnManaged.WriteMemoryA(Handle,Offset,TDataType.BytesToTypedArray(Bytes));
end;

Procedure TAllocation.HandleAllocated;
begin
  // Decendants should override this method
end;

Procedure TAllocation.HandleReleased;
begin
  // Decendants should override this method
end;

procedure TAllocation.Allocate(Bytes:Integer);
var
  mSize:  Integer;
begin
  if (FHandle) then
  Release;

  if Bytes>0 then
  begin
    (* Round off to nearest factor of 16. This is required when
       working with pixel-buffers. And also faster to allocate *)
    mSize:=TInteger.ToNearest(Bytes,16);

    (* Allocate with cache? *)
    if FOptions.UseCache then
    inc(mSize,FOptions.CacheSize);

    FHandle:=TUnManaged.AllocMemA(mSize);
    FSize:=Bytes;
    HandleAllocated;
  end;
end;

procedure TAllocation.Release;
begin
  if (FHandle) then
  Begin
    FHandle.buffer:=NIL;
    FHandle:=null;
    FSize:=0;
    HandleReleased;
  end;
end;

procedure TAllocation.Grow(const Bytes:Integer);
begin
  if (FHandle) then
  Begin
    if FOptions.UseCache then
    begin
      if bytes < FOptions.CacheFree then begin inc(FSize,Bytes); exit; end else begin (* Cache exhausted, re-allocate *) ReAllocate(FSize+ Bytes); end; exit; end; (* No cache is used, simply grow the buffer *) inc(FSize,bytes); ReAllocate(FSize); end else allocate(bytes); end; procedure TAllocation.ReAllocate(const NewSize:Integer); var mSize: Integer; begin if (FHandle) then begin HandleReleased; (* Size in bytes *) mSize:=newSize; (* Allocate cache? *) if FOptions.UseCache then inc(mSize,FOptions.CacheSize); (* Re-allocate memory *) FHandle:=TUnManaged.ReAllocMemA(FHandle,mSize); (* Define size MINUS cache *) FSize:=newSize; end else Allocate(newSize); HandleAllocated; end; procedure TAllocation.Shrink(const Bytes:Integer); var mSize: Integer; begin if (FHandle) then begin (* Use memory caching? *) if FOptions.UseCache then begin (* How many bytes are left after scale? *) mSize:=TInteger.EnsureRange(getSize - bytes,0,MAX_INT); (* Data left to work with? *) if mSize>0 then
      begin

        (* More than defined-size PLUS cache? *)
        if mSize>(FSize + FOptions.CacheSize) then
        Begin
          (* Scale down to defined size, this retails data
             and also include the cache size *)
          ReAllocate(mSize);
        end else
        begin
          (* The data released is within the bounds of the
             defined cache size, so we simply adjust the exposed size *)
          FSize:=mSize;
        end;
      end else
      release;
      exit;
    end;

    mSize:=TInteger.EnsureRange(getSize - bytes,0,MAX_INT);
    if mSize>0 then
    ReAllocate(mSize) else
    Release;
  end;
end;

function TAllocation.getTotalSize:Integer;
begin
  if (FHandle) then
  result:=FHandle.length;
end;

function TAllocation.getSize:Integer;
begin
  result:=FSize;
end;

function TAllocation.getHandle:TMemoryHandle;
begin
  result:=FHandle;
end;

function TAllocation.getBufferHandle:TBufferHandle;
begin
  if (FHandle) then
  result:=FHandle.buffer else
  result:=null;
end;

//############################################################################
// TAbsolute
//############################################################################

class function TUnManaged.AllocMemA(const Size:Integer):TMemoryHandle;
begin
  if Size>0 then
  Result:=new TW3DefaultBufferType(Size) else
  result:=null;
end;

class procedure TUnManaged.FreememA(const Memory:TMemoryHandle);
begin
  if (memory) then
  begin
    // decouple buffer from type
    // this does not release memory, but "hints" to the GC
    // to mark the segment for level 1 release classification
    TW3DefaultBufferType(Memory).buffer := NIL;
  end;
end;

class function TUnManaged.ReAllocMemA(Memory:TMemoryHandle;
         Size:Integer):TMemoryHandle;
begin
  if (Memory) then
  begin
    if Size>0 then
    begin
      result:=new TW3DefaultBufferType(Size);
      TMarshal.Move(Memory,0,result,0,Size);
    end;
  end else
  result:=AllocMemA(Size);
end;

class procedure TUnManaged.FillMemoryA(const Memory:TMemoryHandle;
                const Offset:Integer;
                Size:Integer;
                const Data:TMemoryHandle);
var
  x:  Integer;
  mToWrite: Integer;
  mEnd: Integer;
begin
  if (memory) then
  Begin
    if offset>=0 then
    begin
      if offset<memory.length then
      begin
        if (data) then
        begin

          x:=offset;
          mEnd:=offset + Size-1;

          while x<mEnd do begin mToWrite:=Data.length; if (x + mToWrite-1) > mEnd then
            mToWrite:=(x + mToWrite-1) - mEnd;
            if mToWrite<1 then break; TMarshal.Move(Data,0,Memory,x,mToWrite); inc(x,mToWrite); end; end; end; end; end; end; class function TUnManaged.WriteMemoryA(const Memory:TMemoryHandle; const Offset:Integer; const Data:TMemoryHandle):Integer; var mTotal: Integer; begin if (Memory) then begin if (Data) then begin mTotal:=offset + data.length; if mTotal > memory.length then
      result:=memory.length-mTotal else
      result:=data.length;

      if result>0 then
      begin
        if offset + data.length <=memory.length then TW3DefaultBufferType(Memory).Set(JTypedArray(data),offset) else begin (* Copy range from source, this results in a new buffer *) var mChunk:=TW3DefaultBufferType(data).buffer.Slice(0,result-1); (* Create a typed array pointing to buffer *) var mTemp := new TW3DefaultBufferType( JTypedArray(mChunk) ); (* write memory from source to target *) TW3DefaultBufferType(Memory).Set(mTemp,offset); end; end; end; end; end; class function TUnManaged.ReadMemoryA(const Memory:TMemoryHandle; const Offset:Integer; Size:Integer):TMemoryHandle; var mTotal: Integer; begin if (Memory) then begin if Offset>=0 then
    begin
      mTotal:=offset + Size;
      if mTotal > memory.length then
      Size:=memory.length-mTotal;

      if Size>0 then
      result:=new TW3DefaultBufferType(JTypedArray(
      TW3DefaultBufferType(Memory).buffer.Slice(Offset,Size)));
    end;
  end;
end;

//############################################################################
// TMarshal
//############################################################################

class function TMarshal.ReadMemory(const Segment:TAddress;
               const Size:Integer):TByteArray;
var
  x:  Integer;
  mOffset:  Integer;
  mLongs: Integer;
  mHandle:  TW3DefaultBufferType;
Begin
  if  (segment<>NIL)
  and (size>0) then
  begin
    mHandle:=TW3DefaultBufferType( Segment.Segment );
    mOffset:=Segment.Entrypoint;

    mLongs:=Size shr 3;
    x:=0;
    while mLongs>0 do
    begin
      result.add ( mHandle[mOffset + x] ); inc(x);
      result.add ( mHandle[mOffset + x] ); inc(x);
      result.add ( mHandle[mOffset + x] ); inc(x);
      result.add ( mHandle[mOffset + x] ); inc(x);
      result.add ( mHandle[mOffset + x] ); inc(x);
      result.add ( mHandle[mOffset + x] ); inc(x);
      result.add ( mHandle[mOffset + x] ); inc(x);
      result.add ( mHandle[mOffset + x] ); inc(x);
      dec(mLongs);
    end;

    case Size mod 8 of
    1:  result.add ( mHandle[mOffset + x] );
    2:  begin
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] );
        end;
    3:  begin
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] );
        end;
    4:  begin
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] );
        end;
    5:  begin
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] );
        end;
    6:  begin
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] );
        end;
    7:  begin
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] ); inc(x);
        result.add ( mHandle[mOffset + x] );
        end;
    end;
  end;
end;

class procedure TMarshal.WriteMemory(const Segment:TAddress;
                const Data:TByteArray);
begin
  if  (Segment<>NIL)
  and (data.length>0) then
  JIntegerTypedArray(segment.Segment).Set(Data,segment.Entrypoint);
end;

class procedure TMarshal.FillChar(const Target:TAddress;
      const Size:Integer;
      const Value:Byte);
var
  mSegment: TW3DefaultBufferType;
  mIndex:   Integer;
Begin
  if Target<>NIl then
  begin
    mSegment:=TW3DefaultBufferType( Target.Segment );
    if VarIsValidRef(mSegment) then
    Begin
      mIndex:=Target.Entrypoint;
      TMarshal.Fill(Target.Segment,mIndex,Size,Value);
    end;
  end;
end;

class procedure TMarshal.Fill(Const Buffer:TMemoryHandle;Offset:Integer;
      ByteLen:Integer;const Value:Byte);
var
  mTotalSize: Integer;
  mTarget:    JDataView;
  mTemp:      TMemoryHandle;
  mLongs:     Integer;
  x:          Integer;
  mLongword:  Integer;
Begin
  if (buffer) then
  begin

    mTotalSize:=TW3DefaultBufferType(Buffer).byteLength;

    if  ( offset >=0 )
    and ( offset < mTotalSize) then begin (* clip the offset so we dont overload the buffer *) if offset + ByteLen > TW3DefaultBufferType(Buffer).byteLength then
      ByteLen:=mTotalSize - Offset;

      mTemp:=TUnManaged.AllocMemA(4);
      try
        (* Populate a longword with 4 bytes, so we can fill a longword
           for each write rather than a single byte *)
        mTemp[0]:=Value;
        mTemp[1]:=Value;
        mTemp[2]:=Value;
        mTemp[3]:=Value;


        (* Cache our 4-byte longword *)
        mLongword:=TDatatype.TypedArrayToUInt32(TW3DefaultBufferType(mTemp));

        (* setup a dataview for the target *)
        asm
          @mTarget = new DataView((@Buffer).buffer);
        end;

        (* We will be setting 4 bytes per write, 32 bytes per loop *)
        x:=Offset;
        mLongs:=ByteLen shr 5;

        while mLongs>0 do
        begin
          mTarget.setUint32(x,mLongword,CNT_LittleEndian);inc(x,4);
          mTarget.setUint32(x,mLongword,CNT_LittleEndian);inc(x,4);
          mTarget.setUint32(x,mLongword,CNT_LittleEndian);inc(x,4);
          mTarget.setUint32(x,mLongword,CNT_LittleEndian);inc(x,4);
          mTarget.setUint32(x,mLongword,CNT_LittleEndian);inc(x,4);
          mTarget.setUint32(x,mLongword,CNT_LittleEndian);inc(x,4);
          mTarget.setUint32(x,mLongword,CNT_LittleEndian);inc(x,4);
          mTarget.setUint32(x,mLongword,CNT_LittleEndian);inc(x,4);
          dec(mLongs);
        end;

        mLongs:=ByteLen mod 32;
        while mLongs>0 do
        begin
          mTarget.setUint8(x,Value);inc(x);
          dec(mLongs);
        end;

      finally
        mTemp.free;
      end;
    end;
  end;
end;

class Procedure TMarshal.FillChar(const Target:TAddress;
      const Size:Integer;
      const Value:String);
var
  mSegment: TW3DefaultBufferType;
  mByte:    Byte;
Begin
  if Target<>NIl then
  begin
    if Value.length>0 then
    begin
      mByte:=TDataType.CharToByte(Value);
      mSegment:=TW3DefaultBufferType( Target.Segment );
      if VarIsValidRef(mSegment) then
      Fill(Target.Segment,Target.Entrypoint,Size, mByte);
    end;
  end;
end;

class procedure TMarshal.Move( const Source:TMemoryHandle;
                          const SourceStart:Integer;
                          const Target:TMemoryHandle;
                          const TargetStart:Integer;
                          const Size:Integer);
var
  mRef:TW3DefaultBufferType;
Begin
  if  Source.valid
  and (SourceStart>=0)
  and Target.valid
  and (TargetStart>=0)
  and (Size>0) then
  begin
    (* Copy memory to move into sub-array *)
    mRef:=TW3DefaultBufferType(Source).SubArray(SourceStart,SourceStart+Size);

    (* Write memory to buffer *)
    TW3DefaultBufferType(Target).Set(mRef,TargetStart);
  end;
end;

class procedure TMarshal.Move(const Source:TAddress;
          const Target:TAddress;const Size:Integer);
Begin
  if Source<>NIL then
  Begin
    if Target<>NIl then
    begin
      if Size>0 then
      Move(Source.segment,Source.Entrypoint,
      target.segment,target.entrypoint,Size);
    end;
  end;
end;

class procedure TMarshal.ReAllocmem(var Segment:TAddress;
                const Size:Integer);
var
  mTemp:  TAddress;
  mSize:  Integer;
begin
  if segment<>NIL then
  begin
    mSize:=TW3DefaultBufferType(segment.Segment).length;

    mTemp:=AllocMem(Size);

    case (Size>mSize) of
    true:   move(segment,mtemp,mSize);
    false:  move(segment,mTemp,Size);
    end;

    SegMent.free;
    Segment:=NIL;

    Segment:=mTemp;
  end else
  SegMent:=AllocMem(Size);
end;

class function TMarshal.AllocMem(Const Size:Integer):TAddress;
var
  mBuffer:  JArrayBuffer;
  mArray:   TW3DefaultBufferType;
begin
  result:=NIL;
  if Size>0 then
  Begin
    mBuffer :=  new JArrayBuffer(Size);
    mArray  :=  new TW3DefaultBufferType(mBuffer,0,Size);
    result  :=  TAddress.Create(mArray,0);
  end;
end;

class procedure TMarshal.FreeMem(Const Segment:TAddress);
begin
  if Segment<>NIL then
  Segment.free;
end;

//############################################################################
// TAddress
//############################################################################

Constructor TAddress.Create(const aSegment:TMemoryHandle;
            const aEntrypoint:Integer);
begin
  inherited Create;
  if aSegment.defined
  and aSegment.valid then
  FBuffer:=aSegment else
  Raise EAddress.Create('Failed to derive address, invalid segment error');

  if aEntryPoint>=0 then
  FOffset:=aEntryPoint else
  Raise EAddress.Create('Failed to derive address, invalid entrypoint error');
end;

Destructor TAddress.Destroy;
begin
  FBuffer:=NIL;
  FOffset:=0;
  inherited;
end;

function TAddress.Addr(const Index:Integer):TAddress;
var
  mTarget:  Integer;
begin
  if Index >= 0 then
  Begin
    mTarget:=FOffset + Index;
    if (mTarget>=0) and (mTarget < TW3DefaultBufferType(FBuffer).byteLength) then
    result:=TAddress.Create(FBuffer,mTarget) else
    raise EAddress.Create
    ('Failed to derive address, entrypoint exceeds segment bounds error');
  end else
  Raise EAddress.Create
  ('Failed to derive address, invalid entrypoint error');
end;


end.

Delphi for Linux imminent

Ubuntu linux is sexy and stable

A little bird at Embarcadero let it slip that “Delphi for Linux is right around the corner”. I cant talk about the source of this info (for obvious reasons), but those that follow my blog … 🙂 EMB denied for weeks that iOS support via FPC was a fact after that was posted here, no doubt we will see the same this time.

But, If this indeed turns out to be the case, then Embarcadero is about to take multi-platform native development onto a whole new level. DX already makes C# look like a joke, and Linux support would be the proverbial frosting on the cake – opening up the world of high-end ubuntu services for every Delphi developer in the world.

Linux is the fastest growing Windows alternative these days, embraced by corporations, schools and governments around the globe at an alarming rate. So it does make good sense money wise.

As for how, what and who — that is for Embarcadero to avail when the time is right.

For now, it’s just a rumor (although from the horses mouth).

So to sum up: Every object pascal developer and company has worked HARD to put object pascal back on the map after borland got whopped by Microsoft. And just look at the coverage: Object pascal for iOS, Android, OS X and Windows is delivered by Delphi. JavaScript, NodeJS and the browser is covered by Smart Mobile Studio — and every platform under the sun is supported by freepascal and derived forks.

It’s happy days 🙂

Generic intrinsic wrapper

My new mug, because i have no image on topic

Threads. Love’em or hate’em, but sometimes exposing properties between your main Delphi application and your threads can be tricky. There are rules to accessing memory such as “several processes may read from the same memory, but you can never read and write at the same time”. If you get it wrong, you’ll produce a spectacular access violation.

So how do you safely expose properties in your TThread descendants which both the thread and your main VCL application can access? Well take your pick, from a mutex, a semaphore, synchronization calls all the way to brute-force TCriticalSection. You can even cleverly sculpt your properties read / write access so that data can be safely shared. But that is probably more painful than fun.

Keep it simple

My take on the problem is somewhat ad-hoc, depending on the situation and application of course. But a neat trick is to wrap intrinsic datatypes in bridge classes. Now before you state the obvious “hey, that’s what COM variants do!” — remember that Delphi now targets quite a number of platforms, so making stuff “all delphi” has it’s benefits.

And with generic’s it’s not much code either:

TLockedValue<T> = Class(TObject)
private
  FLock:      TMultiReadExclusiveWriteSynchronizer;
  FData:      T;
protected
  function    GetValue:T;
  procedure   SetValue(Value: T);
public
  Property    Value:T read getValue write setValue;
  Constructor Create;virtual;
  Destructor  Destroy;override;
end;
  
Constructor TLockedValue.Create;
begin
  inherited;
  FLock := TMultiReadExclusiveWriteSynchronizer.Create;
end;

Destructor TLockedValue.Destroy;
begin
  FLock.Free;
  inherited;
end;

function TLockedValue.GetValue:T;
begin
  FLock.BeginRead;
  try
    result:=FData;
  finally
    FLock.EndRead;
  end;
end;

procedure TLockedValue.SetValue(Value: T);
begin
  FLock.BeginWrite;
  try
    FData:=Value;
  finally
    FLock.EndWrite;
  end;
end;

Well, the use should be pretty obvious. And it makes even more sense the other way around – when threads want to write values back into the main VCL process. It’s also very handy for state flags which can be altered by multiple running threads (like counters) and so on…