// Author: Vlad Dumitrescu vlad_dumitrescu@hotmail.com
// You can do whatever you want with the code, if credit is given to the author.

unit ErlPort;

interface

uses
  classes,
  SyncObjs,
  OtpErlang
{$IFDEF debug},
  DbugIntf
{$ENDIF}
  ;

type
  TErlMailBox = class;

  TPortThreadR = class(TThread)
  private
    fmbox: TErlMailBox;
    fin: TStream;
    FInQ: TList;
    FDone: Boolean;
    cs: TCriticalSection;

  protected
    function read(s: TStream; var buf: Pointer): Integer;
    procedure Execute; override;

  public
    constructor Create(fi: TStream; mbox: TErlMailBox);
    destructor Destroy; override;

    property Done: Boolean read FDone;

    function HasData: boolean;
    function PeekBuffer(buf: Pointer): integer;
    function GetBuffer(buf: Pointer): integer;
  end;

  TErlMsgEvent = procedure of object;

  TErlMailBox = class(TComponent)
  private
    fin: TStream;
    fout: TStream;
    FReader: TPortThreadR;
    FOnMessage: TErlMsgEvent;

  protected
    function Write(s: TStream; buf: Pointer; len: integer): integer;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    // careful: this gets called inside the reader thread!
    property OnMessage: TErlMsgEvent read FOnMessage write FOnMessage;

    function HasMessages: Boolean;

    procedure SendBuffer(Buf: Pointer; len: integer);
    function PeekBuffer(var len: integer): Pointer;
    function GetBuffer(var len: integer): Pointer;

    procedure SendMessage(Msg: TOtpErlangObject);
    // these assume the Erlang part sends something like this
    //    port_command(P, term_to_binary(Message))
    function PeekMessage: TOtpErlangObject;
    function GetMessage: TOtpErlangObject;
  end;

implementation

uses
  Windows,
  SysUtils,
  Controls,
  OtpStreams,
  OtpExternal,
  dialogs;

function nice(s: string): string;
var
  i: Integer;
begin
  Result := IntToStr(Length(s)) + '-- ';
  for i := 1 to Length(s) do
    Result := Result + IntToStr(Ord(s[i])) + ' ';
end;

{$IFDEF debug}

procedure dump(s: string; buf: Pointer; len: integer);
var
  b: ^byte;
  i: integer;
begin
  senddebug('dump ' + s + ' (' + inttostr(len) + ')');
  b := buf;
  for i := 1 to len do
  begin
    senddebug(' ' + inttostr(i) + ': ' + inttostr(b^));
    inc(b);
  end;
end;

{$ENDIF}

function Convert(buf: Pointer; len: integer): TOtpErlangObject;
var
  b: TMemoryStream;
  o: TOtpStream;
begin
  dump('convert:', buf, len);
  try
    b := TMemoryStream.Create();
    try
      b.setsize(len);
      b.position := 0;
      b.Write(buf^, len);
      b.position := 0;

      o := TOtpStream.Create(b);
      try
        Result := TOtpErlangObject.decode(o);
      finally
        o.Free;
      end;
    finally
      b.Free;
    end;
  except
{$IFDEF debug}
    senddebugex('exception in convert', mtError);
{$ENDIF}
    Result := nil;
  end
end;

{ TChannelThreadR }

constructor TPortThreadR.Create(fi: TStream; mbox: TErlMailBox);
begin
  inherited Create(True);

  fin := fi;
  FInQ := TList.Create;
  FInQ.Capacity := 50;
  cs := TCriticalSection.Create;

  fmbox := mbox;

  Self.Resume;
end;

destructor TPortThreadR.Destroy;
begin
  cs.Acquire;
  try
    FInQ.Free;
  finally
    cs.Release;
  end;
  cs.Free;

  inherited;
end;

procedure TPortThreadR.Execute;
var
  n: Integer;
  b: Pointer;
begin
  while not Terminated do
  begin
    n := read(fin, b);
    if n > 0 then
    begin
      cs.Acquire;
      try
        FInQ.Add(b);
        if assigned(fmbox) and assigned(fmbox.FOnMessage) then
        begin
          fmbox.FOnMessage;
        end;
      finally
        cs.Release;
      end;
    end;
    sleep(1);
  end;

  FDone := True;
end;

function TPortThreadR.read(s: TStream; var buf: Pointer): Integer;
var
  i, got: integer;
  bf: ^byte;
  len: integer;
  b: byte;
begin
  s.read(b, 1);
  len := b shl 8;
  s.read(b, 1);
  len := len or b;

  if len > 0 then
  begin
    GetMem(buf, len + 4);
    Move(len, buf^, 4);

    got := 0;
    bf := buf;
    inc(bf, 4);
    repeat
{$I-}
      i := s.read(bf^, len - got);
{$I+}
      if i <= 0 then
      begin
        result := 0;
        exit;
      end;
      inc(got, i);
      Inc(bf, i);
    until (got >= len) or Terminated;
  end;
  Result := len;
end;

function TPortThreadR.HasData: boolean;
begin
  cs.Acquire;
  try
    result := FInQ.Count > 0;
  finally
    cs.Release;
  end;
end;

function TPortThreadR.PeekBuffer(buf: Pointer): integer;
var
  b: ^byte;
begin
  if not hasdata then
  begin
    result := 0;
    exit;
  end;
  cs.Acquire;
  try
    b := FInQ[0];
  finally
    cs.Release;
  end;
  Result := pinteger(buf)^;
  if assigned(buf) then
  begin
    inc(b, 4);
    Move(b, buf^, result);
  end;
end;

function TPortThreadR.GetBuffer(buf: Pointer): integer;
var
  b: ^byte;
begin
  if not hasdata then
  begin
    result := 0;
    exit;
  end;
  cs.Acquire;
  try
    b := FInQ[0];
  finally
    cs.Release;
  end;
  Result := pinteger(b)^;
  if assigned(buf) then
  begin
    inc(b, 4);
    Move(b^, buf^, result);

    cs.Acquire;
    try
      FInQ.Delete(0);
    finally
      cs.Release;
    end;
  end;
end;

{ TErlMailBox }

constructor TErlMailBox.Create(AOwner: TComponent);
begin
  inherited;

  fin := THandleStream.Create(GetStdHandle(STD_INPUT_HANDLE));
  fout := THandleStream.Create(GetStdHandle(STD_OUTPUT_HANDLE));

  FReader := TPortThreadR.Create(fin, self);
end;

destructor TErlMailBox.Destroy;
begin
  senddebug('destroy');
  FReader.Terminate;
  senddebug('terminate');
  FReader.WaitFor;
  senddebug('ended');
  FReader.Free;

  fin.Free;
  fout.Free;

  inherited;
end;

function TErlMailBox.HasMessages: Boolean;
begin
  Result := FReader.HasData;
end;

procedure TErlMailBox.SendBuffer(Buf: Pointer; len: integer);
begin
end;

function TErlMailBox.PeekBuffer(var len: integer): Pointer;
begin
  len := FReader.PeekBuffer(nil);
  if len = 0 then
    result := nil
  else
  begin
    GetMem(result, len);
    FReader.PeekBuffer(result);
  end;
end;

function TErlMailBox.GetBuffer(var len: integer): Pointer;
begin
  len := FReader.GetBuffer(nil);
  if len = 0 then
  begin
    result := nil
  end
  else
  begin
    GetMem(result, len);
    FReader.GetBuffer(result);
  end;
end;

function TErlMailBox.PeekMessage: TOtpErlangObject;
var
  buf: PChar;
  n: integer;
begin
  buf := PeekBuffer(n);
  if n = 0 then
    result := nil
  else
  begin
    try
      // skip version tag
      Result := Convert(buf + 1, n - 1);
    finally
      FreeMem(buf, n);
    end;
  end;
end;

function TErlMailBox.GetMessage: TOtpErlangObject;
var
  buf: PChar;
  n: integer;
begin
  buf := GetBuffer(n);
  if n = 0 then
  begin
    result := nil
  end
  else
  begin
    try
      // skip version tag
      Result := Convert(buf + 1, n - 1);
    finally
      FreeMem(buf, n);
    end;
  end;
end;

function TErlMailBox.Write(s: TStream; buf: Pointer; len: integer): integer;
var
  i, got: integer;
  bf: ^Byte;
  b: byte;
begin
  b := (len shr 8) and $FF;
  s.Write(b, 1);
  b := len and $FF;
  s.Write(b, 1);

  got := 0;
  bf := buf;
  repeat
{$I-}
    i := s.Write(bf^, len - got);
{$I+}
    if i <= 0 then
    begin
      result := -1;
      exit;
    end;
    inc(got, i);
    Inc(bf, i);
  until (got >= len);
  Result := len;
end;

procedure TErlMailBox.SendMessage(Msg: TOtpErlangObject);
var
  s: string;
  b: TStringStream;
  o: TOtpStream;
begin
  if not assigned(msg) then
    exit;
  b := TStringStream.Create(s);
  try
    o := TOtpStream.Create(b);
    try
      o.write1(versionTag);
      Msg.encode(o);
      s := b.DataString;
      Write(fout, PChar(s), length(s));
    finally
      o.Free;
    end;
  finally
    b.Free;
  end;
end;

end.